元々は、圧縮してログを保存したい->RAR買ってバッチファイル書けよ、簡単で楽だぞ->ソフトがポリシーで入れらんない->諦めろ->なんとかして、といわれて、書いたものです。
- 引数について
第1引数
バックアップ先、最後に \ 付ける
第2引数
バックアップファイルの最後に付ける識別子、特に指定せずとも可
第3引数
開始確認メッセージを表示するかどうか True で表示、False で非表示
第4引数
終了表示をするかどうか True で表示、False で非表示
第5引数
バックアップ履歴を残す数。0 を指定した場合は、履歴調整をしない。
第6引数
バックアップしたいファイルをフルパスで記載したファイルを指定
例："c:\Temp\zip-bkupV3.vbs" "c:\Temp\Backup" "FooterTest" "True" "True" "5" "c:\Temp\FileList.txt" - ファイルリストの書き方
○バックアップしたいファイルはフルパスで指定します。UNC も通りますが、相対パスは通りませんので、相対パスで記述はしないでください。。
○改行コードのみの行や、; から始まる行は無視されます。リストの整形にどうぞ。
○文字コードは VBS が解釈できる文字コードなら、何でも良いはずです。
○改行コードは CR + LF を使用してください。CR のみや LF のみの場合は正常動作しません。
○リストファイルの拡張子は何でも構いません。.txt でも .lst でも、無くても構いません。
例：
; テスト部分3
;
;バックアップ部分１
c:\hoge\hoge.csv
c:\hoge\hoge1.txt
; テスト部分2
;
d:\hoge\foo.bar
Option Explicit
'-- ZIP 形式でバックアップしてみる v3.00
'
' zip-bkupV3.vbs "第1引数" "第2引数" "第3引数" "第4引数" "第5引数" "第6引数"
' 第1引数 バックアップ先ディレクトリを指定
' 第2引数 バックアップファイルの最後に付ける識別子
' 第3引数 開始確認メッセージを表示するかどうか True で表示、False で非表示
' 第4引数 終了表示をするかどうか True で表示、False で非表示
' 第5引数 バックアップ履歴を残す数。0 の場合は、履歴調整をしない。
' 第6引数 バックアップしたいファイルをフルパスで記載したファイルを指定
'
' v2 との違い
' ファイルやフォルダの存在チェックをするようにした
' バックアップ一覧を記載したファイルを用意してもらい、そのファイルパスを引数に入れてもらうようにした
' その他いろいろ。
'
'-- 開始メッセージ（タイトル）
Dim strMsgTitle 'As String
strMsgTitle = "バックアップ処理"
'-- 終了メッセージ（タイトル）
Dim strMsgTitleEnd 'As String
strMsgTitleEnd = "バックアップ処理の完了"
'-- 終了メッセージ（本文）
Dim strMsgEnd 'As String
strMsgEnd = "バックアップ処理が完了しました" & vbCrlf & _
"※指定したファイル数やサイズによっては圧縮中の場合があります。" & vbCrlf & _
" 左上に進捗状況の画面が表示されている場合は、その画面が消えるまでお待ち下さい。"
Dim strSTOPMsg 'As String '-- エラー表示用
strSTOPMsg = ""
Call mainProcess
If Not strSTOPMsg = "" Then Msgbox strSTOPMsg, vbOKOnly + vbCritical, ""
Private Sub mainProcess
Dim Args 'As Object
Set Args = WScript.Arguments
'-- 引数の数チェック
If ArgsCountCheck() Then Exit Sub
'-- 引数の妥当性チェック
If ArgsValidityCheck() Then Exit Sub
'-- バックアップのメッセージボックスによる確認
If Args.Item(2) Then
If ProcessConfirm() Then Exit Sub
End If
'-- バックアップ処理
Call ZipCompress(Args.Item(0), Args.Item(1), Args.Item(5))
'-- バックアップファイル数調整処理
If Args.Item(4) <> 0 Then Call BkupFilesCheck(Args.Item(4), Args.Item(0))
'-- 結果表示
If (strSTOPMsg = "" And LCase(Args.Item(3)) = "true") Then _
Msgbox strMsgEnd, vbOkOnly, strMsgTitleEnd
End Sub
Private Sub ZipCompress(strBackupPath, strFileNameFooter, strBkupFileList)
Dim objSA 'As Object
Set objSA = WScript.CreateObject("Shell.Application")
Dim i 'As Integer
i = 0
Dim intArgCount 'As Integer
Dim strZipFileName 'As String
Dim copyFileName 'As String
Dim FileAry 'As Variant 'ファイル名格納用の配列
Dim blnFileValid 'As Boolean
blnFileValid = False
'-- \ 処理
If Right(strBackupPath, 1) <> "\" Then strBackupPath = strBackupPath & "\"
'-- zip ファイル名生成
strZipFileName = CreatZipFileName(strBackupPath, strFileNameFooter)
'-- zip ファイル作成
Call CreatZipFile(strZipFileName)
'-- バックアップファイル名を配列へ格納
FileAry = backupFileList(strBkupFileList)
'-- 対象ファイルを放り込む
With objSA.NameSpace(strZipFileName)
For intArgCount = 0 To UBound(FileAry)
'-- 何もないか ; で始まる場合は読み飛ばす
If Not (FileAry(intArgCount) = "" Or _
Left(FileAry(intArgCount),1) = ";") Then
'-- ファイル存在チェック
If FileValidityCheck(FileAry(intArgCount)) Then
blnFileValid = True
Exit For
End If
copyFileName = FileAry(intArgCount)
.CopyHere copyFileName
i = i + 1
Do Until .Items.Count = i
WScript.sleep 100
Loop
End If
Next
End With
Set objSA = Nothing
If blnFileValid Then
strSTOPMsg = "ファイル存在チェック：" & vbCrlf & _
"次のファイルが存在しないため、バックアップ処理を中断しました" & vbCrlf & _
" -> " & FileAry(intArgCount) & vbCrlf & _
"バックアップ対象が記載されたファイルを確認してください"
'-- ごみZIPファイル削除処理
Dim objFS 'As Object
Set objFS = CreateObject("Scripting.FileSystemObject")
objFS.GetFile(strZipFileName).Delete
Set objFS = Nothing
End If
End Sub
'-- バックアップファイル名を配列へ格納
Private Function backupFileList(strBkupFileList)
Dim FileAry 'As Variant 'ファイル名格納用配列
Dim objFSO 'As Object
Set objFSO = WScript.CreateObject("Scripting.FileSystemObject")
Dim objTS 'As Object
Set objTS = objFSO.OpenTextFile(strBkupFileList)
Dim strLines 'As String
strLines = objTS.ReadAll
Set objTS = Nothing
FileAry = Split(strLines, vbCrlf) '--ほんとは、CR のみ LF のみとかも考慮すべきなんだがなぁ...
backupFileList = FileAry
End Function
'-- ZIPファイル作成
Private Sub CreatZipFile(strZipFileName)
Dim objFSO 'As Object
Set objFSO = WScript.CreateObject("Scripting.FileSystemObject")
With objFSO.CreateTextFile(strZipFileName)
.Write "PK" & Chr(5) & Chr(6) & String(18,0)
.Close
End With
Set objFSO = Nothing
End Sub
'-- ZIPファイル名生成
Private Function CreatZipFileName(strBackupPath, strFileNameFooter) 'As String
Dim dateNow 'As Date
Dim dateArray(4) 'As Integer
Dim i 'As Integer
dateNow = Now
dateArray(0) = Month(dateNow)
dateArray(1) = Day(dateNow)
dateArray(2) = Hour(dateNow)
dateArray(3) = Minute(dateNow)
dateArray(4) = Second(dateNow)
For i = 0 to 4
If Len(dateArray(i)) = 1 then dateArray(i) = "0" & dateArray(i)
Next
CreatZipFileName = strBackupPath & Year(dateNow) & dateArray(0) & dateArray(1) & "-" & dateArray(2) & dateArray(3) & dateArray(4) & strFileNameFooter & ".zip"
End Function
'-- バックアップ数調整処理
Private Sub BkupFilesCheck(intLogCount, strBackupPath)
'-- \ 処理
If Right(strBackupPath, 1) <> "\" Then strBackupPath = strBackupPath & "\"
Dim objFS 'As Object
Set objFS = CreateObject("Scripting.FileSystemObject")
Dim objDir 'As Object
Set objDir = objFS.GetFolder(strBackupPath)
Dim FileAry()
ReDim FileAry(objDir.Files.Count)
Dim strFileName 'As String
Dim i 'As Integer
i = 0
For Each strFileName In objDir.Files
FileAry(i) = strFileName '-- ファイル名格納
i = i + 1
Next
'Call DispArray(FileAry)
'-- ファイル名で昇順ソート
Call QuickSort(FileAry, 0, UBound(FileAry))
'Call DispArray(FileAry)
'-- 残すべきファイル数の決定
intLogCount = UBound(FileAry) - intLogCount
If intLogCount > 0 Then
For i = 1 To intLogCount '-- ファイルソートすると、Null が先頭に来るので、1から開始
'Msgbox "削除するファイル:" & FileAry(i)
objFS.GetFile(FileAry(i)).Delete
Next
End If
Set objDir = Nothing
Set objFS = Nothing
End Sub
'-- QuickSort
Private Sub QuickSort(valArray, valLeft, valRight)
Dim valPivot 'As Variant
Dim valHoldLeft 'As Variant
Dim valHoldRight 'As Variant
Dim valTemp 'As Variant
valPivot = valArray(valLeft)
valHoldLeft = valLeft
valHoldRight = valRight
Do
While valArray(valHoldLeft) < valPivot
valHoldLeft = valHoldLeft + 1
Wend
While valArray(valHoldRight) > valPivot
valHoldRight = valHoldRight - 1
Wend
If valHoldLeft >= valHoldRight Then Exit Do
valTemp = valArray(valHoldLeft)
valArray(valHoldLeft) = valArray(valHoldRight)
valArray(valHoldRight) = valTemp
valHoldLeft = valHoldLeft + 1
valHoldRight = valHoldRight - 1
Loop
If valLeft < valHoldLeft - 1 Then QuickSort valArray, valLeft, valHoldLeft - 1
If valHoldRight + 1 < valRight Then QuickSort valArray, valHoldRight + 1, valRight
End Sub
'-- 配列内容を表示
Private Sub DispArray(valArray)
Dim valData 'As Variant
Dim strMsg 'As String
For Each valData In valArray
strMsg = strMsg & valData & vbCrlf
Next
MsgBox strMsg
End Sub
'-- バックアップのメッセージボックスによる確認
Private Function ProcessConfirm 'As Boolean
Dim blnStopFlag 'As Boolean
blnStopFlag = False
Dim Args 'As Object
Set Args = WScript.Arguments
Dim strMsg 'As String
Dim strSpace 'As String
strSpace = " -> "
strMsg = "次の設定でバックアップを行います。" & vbCrlf & vbCrlf & _
"○バックアップ先" & vbCrlf & strSpace & Args.Item(0) & vbCrlf & _
"○バックアップファイル名" & vbCrlf & strSpace & "yyyymmdd-hhmmss" & Args.Item(1) & ".zip" & vbCrlf & _
"○開始終了確認メッセージを表示する" & vbCrlf & strSpace & Args.Item(2) & vbCrlf & _
"○結果表示を行う" & vbCrlf & strSpace & Args.Item(3) & vbCrlf & _
"○バックアップ履歴数" & vbCrlf & strSpace & Args.Item(4) & vbCrlf & _
"○バックアップリスト" & vbCrlf & strSpace & Args.Item(5)
If Msgbox(strMsg, vbYesNo + vbDefaultButton2, strMsgTitle) = vbNo Then
blnStopFlag = True
strSTOPMsg = "中止しました。"
End If
ProcessConfirm = blnStopFlag
End Function
'-- 引数の妥当性チェック
Private Function ArgsValidityCheck() 'As Boolean
Dim blnStopFlag 'As Boolean
blnStopFlag = False
Dim Args 'As Object
Set Args = WScript.Arguments
'--第1引数チェック
If FolderValidityCheck(Args.Item(0)) Then
blnStopFlag = True
strSTOPMsg = "第1引数が不正です。" & vbCrlf & " 指定されたバックアップ先は存在しません"
End If
'--第3引数チェック
If Not (LCase(Args.Item(2)) = "true" Or _
LCase(Args.Item(2)) = "false") Then
blnStopFlag = True
strSTOPMsg = strSTOPMsg & vbCrlf & "第3引数が不正です。" & vbCrlf & " True か False を指定してください"
End If
'--第4引数チェック
If Not (LCase(Args.Item(3)) = "true" Or _
LCase(Args.Item(3)) = "false") Then
blnStopFlag = True
strSTOPMsg = strSTOPMsg & vbCrlf & "第4引数が不正です。" & vbCrlf & " True か False を指定してください"
End If
'--第6引数チェック ファイル存在チェック
If FileValidityCheck(Args.Item(5)) Then
blnStopFlag = True
strSTOPMsg = strSTOPMsg & vbCrlf & "第6引数が不正です。" & vbCrlf & " バックアップ対象を取得するリストファイルは存在しません"
End If
ArgsValidityCheck = blnStopFlag
End Function
'-- 引数の数チェック
Private Function ArgsCountCheck() 'As Boolean
Dim blnStopFlag 'As Boolean
blnStopFlag = False
Dim Args 'As Object
Set Args = WScript.Arguments
If Args.Count <> 6 Then
blnStopFlag = True
strSTOPMsg = "引数の数が不正です。[引数の数:" & Args.Count & "]" & vbCrlf & vbCrlf & _
"※このメッセージは、引数無しでこのスクリプトを呼び出した場合や、" & vbCrlf & _
" 引数の数が 6 以外の場合に表示されます。" & vbCrlf & _
" 引数の詳細は、このファイルをメモ帳等で開いてコメントを読んで。"
End If
ArgsCountCheck = blnStopFlag
End Function
'-- ファイル存在チェック
Private Function FileValidityCheck(strFilePath) 'As Boolean
Dim blnStopFlag 'As Boolean
blnStopFlag = False
Dim fso 'As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FileExists(strFilePath) Then blnStopFlag = True
FileValidityCheck = blnStopFlag
End Function
'-- フォルダ存在チェック
Private Function FolderValidityCheck(strDirPath) 'As Boolean
Dim blnStopFlag 'As Boolean
blnStopFlag = False
Dim fso 'As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(strDirPath) Then blnStopFlag = True
FolderValidityCheck = blnStopFlag
End Function
0 件のコメント:
コメントを投稿