長く曲がりくねった道　〜　いろいろな話

'======================================================
'ﾌｫﾙﾀﾞ単位の名前の変更を行う、但しJPG及びGIFを対象とす
'既存のファイル名の先頭に撮影日付と時刻を追加する
'形式は、yyyymmdd-hhmm_既存名.JPGとする <---hhmmが3桁の場合があるので頭ゼロで4桁固定とする 20190520
'
'対象ﾌｫﾙﾀﾞにこのｽｸﾘﾌﾟﾄを配置し、ｽｸﾘﾌﾟﾄを実行する
'拡張子は大文字で統一する 2018.07.20
'======================================================
'
'ﾌｫﾙﾀﾞ名にｽﾍﾟｰｽ等が入っているとｴﾗｰになる
'MsgBoxは1ﾊﾞｲﾄ文字で最大約1024文字までしか表示出来ない
'
Option Explicit

Const cFiExt = "jpggif" '拡張子JPGとGIFを対象とする
dim FS
dim WShell
dim xMyPath
dim xLen

set FS=CreateObject("Scripting.FileSystemObject")
set WShell=CreateObject("Shell.Application")

'ｽｸﾘﾌﾟﾄのﾌｫﾙﾀﾞ名を取得
xMyPath=Replace(WScript.ScriptFullName, WScript.ScriptName, vbNullString)
if right(xMyPath,1)="\" then '右端が"\"の場合この"\"を削除
xLen=Len(xMyPath)
xMyPath=left(xMyPath,(xLen-1))
end if

FileRenameProc(xMyPath)

set FS = Nothing
set WShell=Nothing

'--------------------------------------------------
'　ﾌｧｲﾙ名の変更
'--------------------------------------------------
Function FileRenameProc(pSourceFolder)

dim objFolder,objFiles,objFi,Fi
dim Arr,Arr2,xx,tmp,NewName,LL
dim xLen,Ix
dim getymdhm
dim NewName2
dim objWSFolder
dim xOneChr
dim xDate
dim xTime
dim xHH
dim xMM

Set objFolder = FS.GetFolder(pSourceFolder)
Set objFiles = objFolder.Files

Set objWSFolder=WShell.Namespace(pSourceFolder)

tmp = ""
For Each Fi in objFiles
Arr =Split(Fi.Name,".")
xx = LCase(Arr(1)) 'アルファベットの大文字を小文字に変換
LL = UCase(Arr(1)) 'アルファベットの小文字を大文字に変換
If InStr(cFiExt,xx) > 0 Then
set objFi = FS.GetFile(Fi)
'NewName=Arr(0) & "b" & "." & LL '拡張子は大文字で統一

'GetDetailsOFはWSHのメソッド、12は撮影日時のパラメータ
getymdhm=objWSFolder.GetDetailsOF(objWSFolder.ParseName(Fi.name),12)
'PutInClipboardText getymdhm
'余計な文字"&3F"が入っているので削除
NewName2=""
for Ix=1 to len(getymdhm)
xOneChr=mid(getymdhm,Ix,1)
if Hex(Asc(xOneChr)) <> "3F" then
NewName2=NewName2 + xOneChr
end if
next

Arr2 =Split(NewName2," ")
xDate=Arr2(0)
xTime=Arr2(1)
xDate=Replace(xDate,"/","") '日付の/を外す
xTime=Replace(xTime,":","") '時刻の:を外す
xTime=Right("0"&xTime,4)
NewName2=xDate & "_" & xTime '日付と時刻の間のスペースを_に変更->"-"はエラーになる

Ix=Instr(1,Arr(0),NewName2)
If Ix = 0 Then '
NewName=NewName2 & "_" & Arr(0) & "." & LL '拡張子は大文字で統一
tmp = tmp & Fi.name & "->" & NewName & vbCrLf
objFi.Name = NewName
Else '変更済み若しくは撮影日付がない
tmp = tmp & Fi.name & "->" & " no change" & vbCrLf
End If

End If

Next
MsgBox tmp '表示文字数制限あり

set objFi = Nothing
Set objFiles = Nothing
Set objFolder = Nothing

End Function

'クリップボードに出力
Public Sub PutInClipboardText(ByVal str)
Dim cmd

cmd = "cmd /c ""echo " & str & "| clip"""
CreateObject("WScript.Shell").Run cmd, 0
End Sub

---

※画像をクリックすると拡大表示します