「送る」で複数のファイルに一括で更新日付を付加する

下記を保存して「送る」フォルダ内に置く。
Rename.VBS (mirror)

「お忍びリネーム」にてファイル名の末尾に更新日付を付加する機会が多かったが、
Windows7環境に移行して以来正常に動作していないため、VBSにて同様の機能を再現した。

ファイルを選択して右クリック＞送る＞上記VBSを呼び出す。複数指定可。

リネーム結果がダイアログで表示される。邪魔ならコメントアウトする。

処理結果。ファイル名の末尾に更新年月日がYYYYMMDDHHMMSS形式で付加される。
「コピー」の文言は除去される。

Option Explicit
Const Usage="Usage: CScript.exe Rename.VBS files..."
Dim fso         ' FileSystemObject
Dim Path        ' 現状フルパス
Dim NewPath     ' 変換後フルパス
Dim OldFileName ' 現状ファイル名
Dim NewFileName ' 変更後ファイル名
Dim YMDHMS      ' 更新日付
Dim ext         ' 拡張子
Dim Msg         ' 処理完了時メッセージ
Dim Result      ' 処理結果
Dim k           ' 汎用
Dim Ans         ' 汎用

' 引数制限数変更
If WScript.Arguments.Count()<=0 Then
  WScript.Echo Usage
  WScript.Quit
End If

Set fso=CreateObject("Scripting.FileSystemObject")
For k=0 To WScript.Arguments.Count()-1
  Path=WScript.Arguments.Item(k)
  If fso.FileExists(Path) Then
    ext = fso.GetExtensionName(Path) ' 拡張子の取得
    YMDHMS = getNowYMDHMS(fso.GetFile(Path).DateLastModified) ' 更新日付取得
    OldFileName = fso.GetFileName(Path) ' 変更前ファイル名　ログ出力用
    NewFileName = fso.GetBaseName(Path) ' 拡張子除去したファイル名取得
    NewFileName = repReg(NewFileName," - コピー.*$|^コピー (|\([0-9]+\) )〜 ","") ' コピー〜の除去
    NewFileName = repReg(NewFileName,"_19\d{12}(\b)","$1") ' 年月日除去
    NewFileName = repReg(NewFileName,"_20\d{12}(\b)","$1") ' 年月日除去
    NewFileName = NewFileName & "_" & YMDHMS & "." & ext ' ファイル名組立て
    NewPath = fso.GetParentFolderName(Path) & "\" & NewFileName ' パス組立て
    
    If Path <> NewPath Then ' パスに変化がある場合のみリネーム実施
      Result="×"
      If fso.FileExists(NewPath) Then
        Ans=MsgBox("ファイル名と更新日付が同一のファイルが既に存在します。"&vbLf&vbLf&_
                   "現状　:"&OldFileName&vbLf& _
                   "変換後:"&NewFileName&vbLf&vbLf& _
                   "当ファイルを削除しますか？",_
                   vbYesNoCancel+vbQuestion,"ファイル削除の確認")
        If Ans = vbYes Then
          fso.DeleteFile(Path)
          Result="−"
        End If
      Else
        fso.MoveFile Path,NewPath ' リネーム
        Result="○"
      End If
      Msg = Msg & "　  " & OldFileName & vbLf & Result & "> " & NewFileName & vbLf
    End If
  End If
Next
If Len(Msg)>0 Then
  WScript.Echo("【結果】  ×：無視　−：削除　○：リネーム" & vbCrLf & Msg)
End If
WScript.Quit

' 正規表現でマッチした先頭の文言を抽出
' http://d.hatena.ne.jp/cloned/20090205/
Function getReg(ByVal argTarget, ByVal argPtn)
  Dim re,matches
  Set re = New RegExp
  re.Pattern = argPtn
  set matches = re.Execute(argTarget)
  If matches.Count = 0 Then
    getReg = argTarget
  Else
    getReg = matches.Item(0)
  End If
End Function

' 正規表現でマッチした文言を置換
Function repReg(ByVal argTarget, ByVal argPtn, ByVal argRep)
  Dim re,matches
  Set re = New RegExp
  re.Pattern = argPtn
  repReg = re.Replace(argTarget,argRep)
End Function

' 日付をYYYYMMDDHHMMSS形式に変換
' http://blog.livedoor.jp/akf0/archives/51369351.html
Function getNowYMDHMS(ArgDate)
  getNowYMDHMS = Year(ArgDate)
  getNowYMDHMS= getNowYMDHMS & Right("0" & Month(ArgDate)  , 2)
  getNowYMDHMS= getNowYMDHMS & Right("0" & Day(ArgDate)    , 2)
  getNowYMDHMS= getNowYMDHMS & Right("0" & Hour(ArgDate)   , 2)
  getNowYMDHMS= getNowYMDHMS & Right("0" & Minute(ArgDate) , 2)
  getNowYMDHMS= getNowYMDHMS & Right("0" & Second(ArgDate) , 2)
End Function