2009/03/10

VBScriptで、日付付きFileBackup・・・


FileBackupper.vbs と .vbe を、暫定で今使ってるままをうpしました。
ファイル/フォルダ右クリックのコンテキストメニューに、
[バックアップ作成]を追加する機能はまだ付いていない版です。

デキルコトは、対象ファイル/フォルダの名称を、
"[元FileName] yyyymmdd hhnnss.[拡張子]" に 変え、コピーを取るだけ。

実働のブツなので使えますが、未使用関数が載ったままになってたりと、
効率が悪い部分が残っています。

改訂版も後日うpするので、コノ分は、あくまで、参考までに・・・

   FileBackupper.zip    
▲ を、右クリックしてファイルとして保存してください。

使い方は至って簡単、ファイルやフォルダをドラッグするだけ。
ショートカットでの利用も可。

    '***** ↓↓↓ScriptTitle↓↓↓ *********************************************************     
'File/Folder Backuper
'- Created by LazwardFox -

'TargetFile Autobackup
'ドラッグ(パラメータ指定)されたファイルを、
'名称に年月日時分秒を付けて同じフォルダ内にコピーをとる

'Update 20090209 2035
'Release 20060712 1736 フォルダのコピーにも対応させ、正式発行
'DevStart 20060413 1026

'***** ↓↓↓ ObjectDecralations ↓↓↓ *************************************************

Set Parameters = WScript.Arguments 'パラメーター取得
If Parameters.Count <= 0 Then
Wscript.Quit
End If

Set WSHShell = WScript.CreateObject("WScript.Shell")
Set Fs = WScript.CreateObject("Scripting.FileSystemObject") 'ファイル制御

'***** ↓↓↓ Decralations ↓↓↓ *************************************************

Public Target, Source, ThisScript
Public Extention, NameOnly, ProcessFolder
Dim SourceFolder, SourceFiles, SourceFile, RNameOnly
Public Result

Dim BackupFile, strFiles, strResult, SettedPF

'***** ↓↓↓MainRoutine↓↓↓ *********************************************************
ThisScriptFull = Wscript.ScriptFullName
ThisScript = Fs.GetBaseName(ThisScriptFull)

For Each SourceFile in Parameters
BackupFile = BackupName(SourceFile )
If Extention = "" Then
Fs.CopyFolder SourceFile, BackupFile
Control = "FolderCopy"
Else
Fs.CopyFile SourceFile, BackupFile
Control = "FileCopy"
End If
'ResultMake '▼▼▼▼▼▼▼▼▼▼▼▼▼▼▼▼▼▼▼▼▼▼▼▼▼▼▼▼▼▼▼▼▼▼
If strResult = "" then
strResult = vbCrlf & "● " & ProcessFolder & "  " & vbCrlf
SettedPF = ProcessFolder
Else
If SettedPF = ProcessFolder Then
Else
SettedPF = ProcessFolder
strResult = strResult & vbCrlf & vbCrlf & "● " & ProcessFolder & "  " & vbCrlf
End If
End If
strResult = strResult & vbCrlf & "  " & NameOnly & "  " & vbCrlf & vbTab & " ▼  " & vbCrlf & "  " & vbTab & RNameOnly & "  " & vbCrlf
'▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲
Next
Msgbox strResult,,ThisScript & " " & Control
Set Fs = Nothing
Set WSHShell = Nothing

Wscript.Quit

'***** ↓↓↓Functions↓↓↓ *********************************************************
'------------------------------------
'BackupName - バックアップ後の名称を構築
'- Created by LazwardFox -

'フルパスを返す
'結果表示用変数に値を代入
'NameOnly - ファイル名
'RNameOnly - 変換後ファイル名
'ファイル/フォルダの識別
'Extention - 値が空白で返されたら 対象はフォルダ

'注)完全な独立関数にはなっていない。

'Release 20060712 1743

Public Function BackupName(SourceName )
Dim FoldersFiles, FoldersCount, FileNamesEx, BlockCount, BackupString
FileNamesEx = Split(SourceName,".")
BlockCount = UBound(FileNamesEx)
If BlockCount > 0 Then 'File
Extention = "." & FileNamesEx(BlockCount)
Else 'Folder
Extention = ""
End If
BackupString = " " & iDT(""," ","",0) & Extention

FoldersFiles = Split(SourceName,"\")
FoldersCount = UBound(FoldersFiles)
If Extention = "" Then 'Folder
NameOnly = SourceName
ProcessFolder = SourceName
RNameOnly = SourceName & BackupString
BackupName = RNameOnly
Else 'File
NameOnly = FoldersFiles(FoldersCount)
ProcessFolder = Replace(SourceName, NameOnly, "")
BackupName = Replace(SourceName, Extention, BackupString)
RNameOnly = Replace(BackupName, ProcessFolder, "")
End If
End Function

Public Function FolderSelector()
OnFolder = UpdatesCopy()
For Each SourceFile In SourceFolder.SubFolders
Set SourceFolder = SourceFile
OnFolder = UpdatesCopy()
'▼ Tester ▼▼▼▼▼▼▼▼▼▼▼▼▼▼▼▼▼▼▼▼▼
msgbox "2 - サブフォルダ数 - " & OnFolder,,ThisScript
'▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲
If OnFolder = 0 Then
Else
Set LSourceFolder = SourceFolder
For Each tSourceFolder In LSourceFolder.SubFolders
Set SourceFolder = tSourceFolder
FolderSelector()
Set tSourceFolder = SourceFolder
Next
Set SourceFolder = LSourceFolder
End If
Next
End Function

'------------------------------------
'UpdatesCopy
'- Created by LazwardFox -

Public Function UpdatesCopy()
'▼ Tester ▼▼▼▼▼▼▼▼▼▼▼▼▼▼▼▼▼▼▼▼▼
If SourceFolder.Files.Count = 0 Then
If SourceFolder.Name="" Then
FolderName = "Root"
Else
FolderName = SourceFolder.Name
End If
msgbox "3 - " & FolderName & vbCrLf & "対象フォルダにファイルが無い",,"UpdatesCopy"
Else
tResult = SourceFolder.name & " - " & SourceFolder.Files.Count & vbCrLf
End If
'▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲

For Each SourceFile In SourceFolder.Files
tResult = tResult & SourceFile.Path & vbcrlf
Next

'▼ Tester ▼▼▼▼▼▼▼▼▼▼▼▼▼▼▼▼▼▼▼▼▼
tResult = Replace(tResult & "_", vbcrlf & "_","")
If Not tResult = "_" Then
msgbox "4 - ファイル一覧" & vbCrLf & tResult,,ThisScript
End If
'▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲

UpdatesCopy = SourceFolder.SubFolders.Count
End Function

'------------------------------------
'iDT - 日時文字列 ないし 日/時配列取得 for VBScript
'- Created by LazwardFox -


' Update 20090228 0458 変数宣言変更
' Update 20090223 0959 時刻桁処理変更
' Update 20090223 0253 Len記述忘れ修正
' Update 20090223 0135 変数宣言忘れ修正
' Update 20090210 0218
' Update 20090210 0115
' Release 20090209 2035

' iDT (
' dSplitter - DateSplitString (Normal - "/")
' ,dtSeparater - Date/Time SepaleteString (Normal - " ")
' ,tSplitter - TimeSplitString (Normal - ":")
' ,Control - 配列化 0 or 1 (Default - 1)
' )

Public Function iDT(dSplitter,dtSeparater,tSplitter,Control)
Dim nX, nD, nS, strHMS, sResult 'Update 20090228 0458
nX = Now()
nD = FormatDateTime(Date(),0)
nS = ":" & Split(CStr(FormatDateTime(nX,3)),":")(2) 'Update 20090223 0951
strHMS = FormatDateTime(nX,4) & nS 'Update 20090223 0951
If tSplitter = ":" Then
Else
strHMS = Replace(strHMS,":",tSplitter)
End If
sResult = Cstr(Replace(nD,"/",dSplitter)) & "*" & strHMS
If Control = 1 Then
iDT = Split(sResult,"*")
Else
iDT = Replace(sResult,"*",dtSeparater)
End If
End Function


しかし、リリース2006年かぁ・・・(遠い目) ファイル文字列処理に初々しさがあるよねw

ちなみに、もっと程度の低い版なら、2004年にはあったw
更に前だとWinBatch版、もっと前はBatファイルだったなぁ・・・(更に遠い目)

もう、過去のHDDクラッシュで、ソース紛失してるケド^_^;
<そのまま使えるVBscript 日付 添付 バックアップ ファイル フォルダ>

0 件のコメント:

コメントを投稿