PC, Windows7, ソフトウェア, デジカメ

FlashAirではひとつずつしかファイルの保存ができないのでVBScriptでまとめて転送

コメントする
このエントリーをはてなブックマークに追加

前回も書きましたが、東芝のFlashAirはファイルの転送をまとめてすることができません。ただし、FlashAirそのものはSDカードの形をした無線LANのhttpサーバなので、受信側で工夫をすると、まとめてコピーをすることができます。今回は「自由区☆彡」さんのブログに掲載されているスクリプトを利用させていただきました。

スクリプトとしては、htmlの中から、ファイル名を取りだして、ダウンロードするというものです。ローカルに同名ファイルある場合は上書きはしません。

改良点（自分仕様）としては、以下の3点です。

  1. DCIMフォルダを決め打ちし、その中のフォルダを選択できるようにしました。
    デジカメでよく使われるDCIMフォルダの中にカメラごとのフォルダを作る形式に対応しました。
  2. テンポラリーファイルを削除するようにしました。
    同じフォルダにあるテンポラリーファイルと同名のファイルは容赦なく削除されます。
  3. スクリプトの途中に行を追加することで、複数の別のキーワード（自分仕様では拡張子を設定）でダウンロードできるようにした。
    デフォルトでは、JPGとJPEという文字列が含まれるファイルがダウンロードされます。必要があれば、38行目あたりを追加してください。

他にも、メッセージを自分が読みやすいように日本語にしたりしています。
使い方は、無線LANでFlashAirに接続した状態でスクリプトをダブルクリックします。接続できていれば、DCIM下のフォルダが取得され、、DOSのバッチファイルの様に番号選択式でフォルダの一覧が出ます。その中から任意のフォルダを選択すると、スクリプトが置いてあるフォルダに画像ファイル全てがコピーされます。
フォルダの選択はリストボックスなどが利用できないので、DOSのバッチファイルのように番号選択式です。

FlashAir FlashAir

FlashAirなどの無線LAN内蔵SDカードの注意点としてはカメラの省電力機構でSDカードへの電源供給がOFFになると、PCとのリンクが切れてしまうことです。こちらはカメラ側の設定で回避できることも多いです。

スクリプトの一部には「おそらくはそれさえも平凡な日々」さんの「VBScriptにおけるpushの決定版」を利用させていただきました。またスクリプトのほとんどは「自由区☆彡」さんのブログに掲載されているものです。

最後にスクリプトです。FlashAir.VBSなどの名前で保存して下さい。Windows 7で動作確認しました。

Option Explicit

Dim objSrvHTTP, Stream, Fso
Set objSrvHTTP = Wscript.CreateObject("MSXML2.XMLHTTP")
Set Stream = Wscript.CreateObject("ADODB.Stream")
Set Fso = Wscript.CreateObject( "Scripting.FileSystemObject" )

Dim strCurPath, obj, strUrl, strChr, strChrArr()
strCurPath = WScript.ScriptFullName
Set obj = Fso.GetFile( strCurPath )
Set obj = obj.ParentFolder
strCurPath = obj.Path

Dim inpStr
Dim strVal
Dim aryStrings
Dim lngPos
Dim objFso, objFile

Dim iMsg

Dim objFsoChk	 ' FileSystemObject
Dim strFile	 ' Exist FileName&Path

Dim title
Dim dir()

'プログラムタイトル
title = "FlashAir ファイルコピー"

'ディレクトリを取得 (http://flashair/DCIM)
strUrl = "http://flashair/DCIM"

'コピーするファイルを検索する検索 大文字小文字区別なし 半角3文字まで 長いファイル名には非対応
'RAWファイル等を転送する場合には行を追加
push strChrArr,"JPG"
push strChrArr,"JPE"
'push strChrArr,"NEF"
'push strChrArr,"ORF"
'push strChrArr,"CR2"

'テンポラリーファイル名
'同名のファイルがある場合は起動時、正常終了時に削除されるので注意
dim tempDCIM, tempDir
tempDCIM = "~dcim.tmp"
tempDir = "~dir.tmp"

'テンポラリーファイルがあれば削除
DelTemp

'ディレクトリを検索するためにHTMLを保存
on error resume next
Call objSrvHTTP.Open("GET", strUrl, False )
if Err.Number <> 0 then
	Wscript.Echo Err.Description
	Wscript.Quit
end if

objSrvHTTP.Send
if Err.Number <> 0 then
	Wscript.Echo Err.Description
	Wscript.Quit
end if

Stream.Open
Stream.Type = 1 ' Binary
Stream.Write objSrvHTTP.responseBody
Stream.SaveToFile strCurPath & "\" & tempDir, 2
Stream.Close

'ディレクトリを検索
on error resume next
Set objFso = CreateObject("Scripting.FileSystemObject")
Set objFile = objFso.OpenTextFile(strCurPath & "\" & tempDir, 1, False)
If Err.Number > 0 Then
	WScript.Echo "Open Error"
	WScript.Quit
end if

Set objFsoChk = WScript.CreateObject("Scripting.FileSystemObject")
If Err.Number > 0 Then
	WScript.Echo "Open Error"
	WScript.Quit
Else
	Do Until objFile.AtEndOfStream

		'ディレクトリを表す行の開始文字
		strChr = "DCIM"
		strVal = objFile.ReadLine
		lngPos = InStr(1, UCase(strVal), UCase(strChr))
		if lngPos <> 0 then
			aryStrings = Split(strVal, ",")
			push dir,aryStrings(1)
		end if
	Loop
End If
on error goto 0

Dim dircount
Dim intCounter
Dim msgText
msgText = "コピー元ディレクトリを番号で選択してください" & vbCrLf
For intCounter = LBound(dir) To UBound(dir)
	msgText = msgText & intCounter & " : " & dir(intCounter) & vbCrLf
Next

Dim dirInput
dirInput = InputBox(msgText,title)

If IsEmpty(dirInput) = true Then
	msgBox("番号を選んでください")
	Wscript.Quit
End If
If cInt(dirInput) < LBound(dir) Then
	msgBox(LBound(dir) & "より小さい番号は選択できません")
	Wscript.Quit
End If
If UBound(dir) < cInt(dirInput) Then
	msgBox(UBound(dir) & "より大きい番号は選択できません")
	Wscript.Quit
End If
strUrl = strUrl & "/" & dir(dirInput)

msgBox strUrl & "からコピーを開始します", vbInformation + vbOKOnly , title

'----- Get URL html src code text
on error resume next
Call objSrvHTTP.Open("GET", strUrl, False )
if Err.Number <> 0 then
	Wscript.Echo Err.Description
	Wscript.Quit
end if

objSrvHTTP.Send
if Err.Number <> 0 then
	Wscript.Echo Err.Description
	Wscript.Quit
end if

Stream.Open
Stream.Type = 1 ' Binary
Stream.Write objSrvHTTP.responseBody
Stream.SaveToFile strCurPath & "\" & tempDCIM, 2
Stream.Close

'----- Read html src code text file
on error resume next
Set objFso = CreateObject("Scripting.FileSystemObject")
Set objFile = objFso.OpenTextFile(strCurPath & "\" & tempDCIM, 1, False)
If Err.Number > 0 Then
	WScript.Echo "Open Error"
	WScript.Quit
end if

Set objFsoChk = WScript.CreateObject("Scripting.FileSystemObject")
If Err.Number > 0 Then
	WScript.Echo "Open Error"
	WScript.Quit
Else
	Do Until objFile.AtEndOfStream

		strVal = objFile.ReadLine
		lngPos = 0
		For intCounter = LBound(strChrArr) To UBound(strChrArr)
			lngPos = lngPos + InStr(1, UCase(strVal), UCase(strChrArr(intCounter)))
		Next
		if lngPos <> 0 then
			aryStrings = Split(strVal, ",")

			'----- CurFile Exist Check
			strFile = strCurPath & "\" & aryStrings(1)
			If objFsoChk.FileExists(strFile) = False Then

				'----- get URL FileName
				Call objSrvHTTP.Open("GET", strUrl & "/" & aryStrings(1) , False )
				if Err.Number <> 0 then
					Wscript.Echo Err.Description
					Wscript.Echo strUrl & "/" & aryStrings(1)
					Wscript.Quit
				end if

				objSrvHTTP.Send
				if Err.Number <> 0 then
					Wscript.Echo Err.Description
					Wscript.Quit
				end if

				Stream.Open
				Stream.Type = 1 ' Binary
				Stream.Write objSrvHTTP.responseBody
				Stream.SaveToFile strFile, 2
				Stream.Close
			End If

		end if
	Loop
End If
on error goto 0

objFile.Close
Set objFile = Nothing
Set objFso = Nothing
Set objFsoChk = Nothing

DelTemp
iMsg = MsgBox("コピーを完了しました", vbInformation + vbOKOnly ,title)

Sub DelTemp
	'テンポラリーファイルを削除
	Set objFsoChk = WScript.CreateObject("Scripting.FileSystemObject")
	strFile = strCurPath & "\" & tempDCIM
	If objFsoChk.FileExists(strFile) = True Then
		Set objFso = WScript.CreateObject("Scripting.FileSystemObject")
		objFso.DeleteFile strCurPath & "\" & tempDCIM,True
		Set objFso = Nothing
	End If
	Set objFsoChk = WScript.CreateObject("Scripting.FileSystemObject")
	strFile = strCurPath & "\" & tempDir
	If objFsoChk.FileExists(strFile) = True Then
		Set objFso = WScript.CreateObject("Scripting.FileSystemObject")
		objFso.DeleteFile strCurPath & "\" & tempDir,True
		Set objFso = Nothing
	End If
End Sub

Sub push(arr,elm)
  Dim i,tmp : i = 0
    If IsArray(arr) Then
      For Each tmp In arr
        i = 1
        Exit For
      Next
      If i=1 Then
        Redim Preserve arr(Ubound(arr)+1)
      Else
        Redim arr(0)
      End If
    Else
      arr = Array(0)
    End If
    If IsObject(elm) Then
      Set arr(Ubound(arr)) = elm
    Else
      arr(Ubound(arr)) = elm
    End If
End Sub

関連記事

コメントを残す

メールアドレスが公開されることはありません。 ※ が付いている欄は必須項目です

SPAM防止のため数字と漢数字の算数の計算をお願いします。 * Time limit is exhausted. Please reload CAPTCHA.