◆ [VBScript] 更新日時を元にファイルをリネームする
こんばんワイン。どーもボキです。

iPhoneに限った話ではないが、デバイスの保存画像ファイルをすべて吸い上げると、
ファイル名がリセットされ、また同じ名前でファイルが作られる。

同じ名前のファイルが存在する場合、同じフォルダに保存できず不便なため、
ファイルの更新日時情報からファイル名を変更するスクリプトを作成した。

使い方は、以下の実行プログラムをメモ帳にペーストし、vbsファイルとして保存、実行するだけ。
図のようにフォルダ選択ダイアログが表示される。

なお、VBSファイルへのフォルダ/ファイルドロップでも処理可能。
a0021757_13225160.gif
実行プログラム
'==============================================================================='
Set objWS = CreateObject("WScript.Shell")
Set objFS = CreateObject("Scripting.FileSystemObject")

If WScript.Arguments.Count = 0 Then
If Not SelectDirectory("処理するフォルダを選択",0,dpth) Then WSCript.Quit

objWS.Run "CScript """ & WScript.ScriptFullName & """ """ & dpth & """"
WScript.Quit ' 引数を渡し再起動
Else
SetScriptHost("CScript") ' ドロップだとWScriptとなるためCScriptで再起動

For i = 0 To WScript.Arguments.Count -1: Do
s = WScript.Arguments.Item(i)

If objFS.FileExists(s) Then
ProcFile(s)
Else
SearchFile(s)
End If
Loop Until 1: Next
End If

r = objWS.PopUp("処理が終了しました。",3,"終了メッセージ",64)
'================================================================================

' -------------------------------------------------------------------------------
' フォルダ内のファイル検索
Sub SearchFile(DPath)
Set Folder = objFS.GetFolder(DPath)

' フォルダ内のフォルダ
For Each SubFolder In Folder.SubFolders: Do
SearchFile(SubFolder.Path)
Loop Until 1: Next

' フォルダ内のファイル
For Each File In Folder.Files: Do
ProcFile(File.Path)
Loop Until 1: Next
End Sub
' -------------------------------------------------------------------------------'
' ファイル処理本体
Function ProcFile(FPath)
Dim i,s,ttl,ext,dpth,dnam,fnam0,fnam,fpth
ProcFile = False
'If LCase(Right(FPath, Len(FPath) -InStrRev(FPath,"."))) <> "csv" Then Exit Function

dpth = objFS.GetParentFolderName(FPath) &"\"
'dnam = objFS.GetFileName(objFS.GetParentFolderName(FPath))
fnam0 = objFS.GetFileName(FPath)

s = objFS.GetFile(FPath).DateLastModified
'If Len(s)=18 Then s = Replace(s, "
", " 0") ' h→hh
ttl = Mid(s,3,2) & Mid(s,6,2) & Mid(s,9,2) ' yymmdd
ext = Right(FPath, Len(FPath) -InStrRev(FPath,"
.") +1) ' 拡張子

fnam = ttl & ext
fpth = dpth & fnam
If objFS.FileExists(fpth) Then
i = 1
fnam = ttl &"
_"& IntToStr0(i,1) & ext
fpth = dpth & fnam
While objFS.FileExists(fpth)
i = i+1
fnam = ttl &"
_"& IntToStr0(i,1) & ext
fpth = dpth & fnam
Wend
End If
dprintf(fnam0 &"
"& fnam)
objFS.GetFile(FPath).Name = fnam

ProcFile = True
End Function
' -------------------------------------------------------------------------------
' 実行ホストを切り替える
Sub SetScriptHost(HostName)
If InStr(LCase(WSCript.FullName), LCase(HostName)) <> 0 Then Exit Sub

s = HostName & "
""" & WScript.ScriptFullName & """"
If WScript.Arguments.Count > 0 Then
For i = 0 To WScript.Arguments.Count -1
s = s &"
""" & WScript.Arguments.Item(i) & """"
Next
End If
CreateObject("
WScript.Shell").Run s
WScript.Quit
End Sub
'-------------------------------------------------------------------------------
' フォルダ選択ダイアログ
Function SelectDirectory(sCaption, sInitDir, sSelectDir)
Dim objFS,objSA,dpth

SelectDirectory = False
Set objFS = CreateObject("
Scripting.FileSystemObject")
Set objSA = CreateObject("
Shell.Application")

Set objFolder = objSA.BrowseForFolder(0, sCaption, 0, sInitDir)
If objFolder Is Nothing Then Exit Function ' キャンセル

If objFolder.Items.Item Is Nothing Then
dpth = CreateObject("
WScript.Shell").SpecialFolders("Desktop") &"\" ' デスクトップ
Else
dpth = objFolder.Items.Item.Path &"
\"
End If
If Not objFS.FolderExists(dpth) Then Exit Function '指定異常 (ゴミ箱とか)

sSelectDir = dpth
SelectDirectory = True
End Function
'-------------------------------------------------------------------------------
' 0付き文字に変換
Function IntToStr0(Value, Digits)
Dim i,cnt,s

s = CStr(Value)
cnt = Digits - Len(s)
For i = 0 To cnt
s = "
0" & s
Next
IntToStr0 = s
End Function
' -------------------------------------------------------------------------------
' デバッグ ※ここだけ抜粋してもOK
Dim objDbg
' クラス'
Class TDebug
Dim FCScript

' 初期化処理
Private Sub Class_Initialize()
FCScript = InStr(LCase(WSCript.FullName), "
cscript") > 0
End Sub

' 終了処理
Private Sub Class_Terminate()
If Not FCScript Then Exit Sub

WScript.StdOut.WriteLine NOW & "
[END]"
WScript.StdIn.ReadLine
End Sub

' CScriptホストかどうか
Public Property Get CScript
CScript = FCScript
End Property

' デバッグメッセージ処理
Public Sub dprintf(v)
Dim i,s,ityp
If Not FCScript Then Exit Sub

s = v
ityp = VarType(v)
If ityp = vbBoolean Then
s = CStr(v)
ElseIf VarType(v) >= vbArray Then
s = "
"
For i = 0 to UBound(v)
s = s & "
dprintf(" &i& ")=" & v(i) & vbCRLF
Next
End If
WScript.Echo s
End Sub
End Class
' 関数
Sub dprintf(v)
If VarType(objDbg) = vbEmpty Then
Set objDbg = New TDebug
objDbg.dprintf(NOW & "
" & WScript.ScriptFullName)
End If
objDbg.dprintf(v)
End Sub
' -------------------------------------------------------------------------------



[PR]
by yozda | 2014-12-13 17:46 | プログラミング | Trackback | Comments(0)
トラックバックURL : http://yozda.exblog.jp/tb/20514147
トラックバックする(会員専用) [ヘルプ]
<< [動画] B'z 哀し... [VBScript] 指定時間... >>