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.