Windows 用のファイル複製スクリプト(日時付加、二重拡張子対応)

Windows 用のファイル複製スクリプト

Windows のエクスプローラで、ファイルをコピー→貼り付けすると、元ファイルのコピーができます。
ですが、下記の点がちょっと不満でした。

• 二重拡張子に対応していない。「test.xxx.txt」をコピペすると「test.xxx - コピー.txt」のようになる。（「test - コピー.xxx.txt」のようになるべき）
• バックアップしたファイル名にファイル生成日時を入れたい。

そこで、ファイルを引数として渡したらファイルの複製を作るだけのスクリプトを用意してみました。
「test.xxx.txt」に対して「test_20220421_200859.xxx.txt」のようなファイル名でバックアップが生成されます。
同名のファイルが既に存在する場合は、「test_20220421_200859(1).xxx.txt」「test_20220421_200859(2).xxx.txt」のように番号が追加されていきます。今のところ連番は10個までです。

このスクリプトを「送る」に登録する

• 記事末尾のソースを「backup_file.vbs」の名前でローカルに保存します。文字コードは Shift_JIS としてください。
• エクスプローラで shell:sendto を指定すると、「送る」フォルダが開きますので、「送る」フォルダに backup_file.vbs へのショートカットを配置します。

使い方

• エクスプローラでバックアップしたいファイルを右クリックして、「送る」からbackup_file.vbsを実行してください。
• ファイルを複数選択している場合は、選択したファイルそれぞれについてバックアップを作成します。
• フォルダのバックアップは生成しません。

ソース

'
' backup_file.vbs
'

Dim oFileSys: Set oFileSys = CreateObject("Scripting.FileSystemObject")
Dim arg, n

Set arg = WScript.Arguments
For n = 0 To arg.Count - 1
	Backup arg.item(n)
Next

Sub Backup(ByVal sFile_full)
	Dim oFile, sFolderTo
	Dim d, sTime
	Dim sFile1, sFileExt, sFileNew, sFileNew_full
	Dim nPos
	Dim i

	If Not oFileSys.FileExists(sFile_full) Then
		MsgBox "ファイルが見つかりません" & vbCrLf & sFile_full
		Exit Sub
	End If

	Set oFile = oFileSys.GetFile(sFile_full)
	sFolderTo = oFile.ParentFolder.Path

	d = oFile.DateLastModified	'最終更新日時
	sTime = Year(d) & Right("0" & Month(d), 2) & Right("0" & Day(d), 2)
	sTime = sTime & "_" & Right("0" & Hour(d), 2) & Right("0" & Minute(d), 2) & Right("0" & Second(d), 2)

	'oFileSys.GetExtensionName は使わない
	sFile1 = oFile.Name
	nPos = Instr(sFile1, ".")
	If nPos = 0 Then
		sFileExt = ""
		sFileNew = sFile1 & "_" & sTime
	Else
		sFileExt = "." & Mid(sFile1, nPos + 1)
		sFileNew = Left(sFile1, nPos - 1) & "_" & sTime
	End If
	sFileNew_full = oFileSys.BuildPath(sFolderTo, sFileNew & sFileExt)

	For i = 1 To 11
		If Not oFileSys.FileExists(sFileNew_full) Then
			oFile.Copy(sFileNew_full)
			Exit Sub
		ElseIf i = 11 Then
			MsgBox sFileNew_full & " が既に存在します."
			Exit Sub
		End If
		sFileNew_full = oFileSys.BuildPath(sFolderTo, sFileNew & "(" & i & ")" & sFileExt)
	Next
End Sub