ドラッグアンドドロップだけでファイルのバックアップを作成するツール

レガシーなプログラム開発や事務処理を行なう時、バックアップを取る人は多いと思います。

1ファイルや2ファイルならまだしも、10ファイル20ファイルのバックアップを取るとそれだけで10分ぐらいかかりますよね。

仮にファイルのバックアップ作業が毎日5分あったとしたら…1ヵ月分の作業時間をざっくり計算すると　20日 × 5分 = 100分！？

ツマラナイ作業に約1時間半も費やしていることになります。

ドラッグアンドドロップだけでファイルのバックアップを作成するツール

VBSならファイルをドラッグアンドドロップするだけで filename.txt から filename_yyyymmdd.txt のバックアップを作成できます。

コードはこちら。

'引数がなかったら即終了
If WScript.Arguments.Length = 0 Then
	MsgBox "名前を変更したいファイルをドラッグし、このアイコンにドロップしてください", vbOKOnly + vbInformation, "ツールの使い方"
	WScript.Quit
End If

Dim strArg, objFSO, objFLD, strSource, strDestination, strDrive, strCurrentDirectory, strBkDirectory

Set objFSO = CreateObject("Scripting.FileSystemObject")
strArg = WScript.Arguments(0)

'カレントドライブとカレントディレクトリの取得（NWフォルダとUNCフォルダ対応）
If Right(strArg, 1) = ":" Then
	strCurrentDirectory = objFSO.GetDrive(strArg)
Else
	strCurrentDirectory = objFSO.GetParentFolderName(strArg)
End If

'バックアップフォルダ
'-----------------------------------
If MsgBox("バックアップフォルダを指定しますか？",  vbYesNo + vbQuestion) = vbYes Then
	strBkDirectory = InputBox("バックアップ先フォルダ名の入力をお願いします。" & vbCrlf & vbCrlf & "フォルダが無い場合自動生成します。", "入力")
End If

strBkDirectory = strCurrentDirectory & "\" & strBkDirectory

If objFSO.FolderExists(strBkDirectory) = False Then
	Set objFLD = objFSO.CreateFolder(strBkDirectory)
	MsgBox "新しいフォルダが作成されました。" & vbCrlf & vbCrlf & strBkDirectory
End If
'-----------------------------------

For Each strArg In WScript.Arguments
	Set strSource = objFSO.GetFile(strArg)
	strDestination = strBkDirectory  & "\" & objFSO.GetBaseName(strSource.Name) & "_" & Replace(Date(), "/", "") & "." & objFSO.GetExtensionName(strSource.Name)
	objFSO.CopyFile strSource, strDestination
Next

'引数がなかったら即終了

If WScript.Arguments.Length = 0 Then

MsgBox "名前を変更したいファイルをドラッグし、このアイコンにドロップしてください", vbOKOnly + vbInformation, "ツールの使い方"

WScript.Quit

End If

Dim strArg, objFSO, objFLD, strSource, strDestination, strDrive, strCurrentDirectory, strBkDirectory

Set objFSO = CreateObject("Scripting.FileSystemObject")

strArg = WScript.Arguments(0)

'カレントドライブとカレントディレクトリの取得（NWフォルダとUNCフォルダ対応）

If Right(strArg, 1) = ":" Then

strCurrentDirectory = objFSO.GetDrive(strArg)

Else

strCurrentDirectory = objFSO.GetParentFolderName(strArg)

End If

'バックアップフォルダ

'-----------------------------------

If MsgBox("バックアップフォルダを指定しますか？", vbYesNo + vbQuestion) = vbYes Then

strBkDirectory = InputBox("バックアップ先フォルダ名の入力をお願いします。" & vbCrlf & vbCrlf & "フォルダが無い場合自動生成します。", "入力")

End If

strBkDirectory = strCurrentDirectory & "\" & strBkDirectory

If objFSO.FolderExists(strBkDirectory) = False Then

Set objFLD = objFSO.CreateFolder(strBkDirectory)

MsgBox "新しいフォルダが作成されました。" & vbCrlf & vbCrlf & strBkDirectory

End If

'-----------------------------------

For Each strArg In WScript.Arguments

Set strSource = objFSO.GetFile(strArg)

strDestination = strBkDirectory & "\" & objFSO.GetBaseName(strSource.Name) & "_" & Replace(Date(), "/", "") & "." & objFSO.GetExtensionName(strSource.Name)

objFSO.CopyFile strSource, strDestination

vbsコードを任意の場所にSJISで保存してください。
バックアップファイルを作成したいファイルをドラッグアンドドロップしてください。
以上

さらに便利な使い方

「ファイルをバックアップするツール、どこに格納したっけな」というように困ることがあるかもしれません。

そんな時こそマウスを右クリックして”送る”にvbsのショートカットを設置しておいてください。

ちなみに”送る”はファイル名を指定して実行から「Shell:sendto」で呼び出せます。

あとはファイルを選択して右クリックして”送る”からVBSをチョイスすることでバックアップが作成されます。

備忘録

UNCパスのフォルダ（¥¥Server¥folder）でも使えますよ。

バックアップフォルダに自動で作成するようさらに改変しました。

フォルダへのポップアップ確認が煩わしい場合は '---- の中をすべてコメントアウトしてください。

著作権等

プログラムをカスタマイズして2次利用する際は当ブログへのリンクをお願いします。

商用利用は禁止です。

参考にしたソース

reime様のソースを元にカスタマイズを加え、日付のバックアップ＆コピーにしました。

コードはこれ。簡単。FileSystemObjectとFor Eachループが使えれば理解できると思う。 pic.twitter.com/SMJdY1Ik8s

— reime (@_reime) December 11, 2021