バックアップ 自らを指定フォルダ内へバックアップ
※より実装に近く表示させる為、コードの改行を避けています。スマホ等で閲覧される際は向きを変えてご覧ください。
※実装するバージョンによってはバージョンアップの仕様により動作しないコードもあります。実装には動作確認の上ご使用下さい。
Sub Backup() '************************************ '自らを指定フォルダ内へバックアップ '************************************ '使用サブルーチン及びファンクション '--- BkOrBackUp (バックアップエンジン) '--- BKUFolder (フォルダ作成) '--- DateTimeName (ファイル名作成) Dim str(4) As String, BkFaolName As String BkFaolName = "バックアップ" 'バックアップを作るフォルダ名 str(1) = "現在の変更や入力後のバックアップを開始します。" str(2) = "※環境によってはやや時間を要します。" str(3) = "バックアップをキャンセルしました。" If MsgBox(str(1) & vbCr & vbCr & str(2), vbOKCancel, FileName) = vbCancel Then 'Cancelした場合 MsgBox str(3), vbInformation, FileName Exit Sub End If str(4) = BkOrBackUp(BkFaolName) If str(4) = "" Then MsgBox "バックアップを完了出来ませんでした。", vbCritical, FileName Else MsgBox "バックアップを完了しました。" & vbCr & vbCr & _ "完了場所" & vbCr & str(4), vbInformation, FileName End If End Sub Function BkOrBackUp(strFolname As String) As String '******************************** 'ファイルのコピー(バックアップ) '******************************** 'コピー(バックアップ)したパス～ファイル名を返す 'エクセルブック限定 Dim TruePath As String, FalsePath As String Dim FalseName As String, NewPath As String BKUFolder strFolname On Error GoTo TheERR: '=================================================================== 'バックアップの仕組みと解説 '=================================================================== '[真ファイル]_[真パス]+[真ファイル名]取得 [A]① TruePath = ThisWorkbook.Path & "\" & ThisWorkbook.Name '[偽ファイル名]_作成(DateTimeName=ファイル名 FileExtensionName=拡張子) [A]① FalseName = DateTimeName & FileExtensionName(ThisWorkbook.Name) '[偽パス]+[偽ファイル名]_作成 [A]① FalsePath = ThisWorkbook.Path & "\" & FalseName '[真ファイル]を[偽パス]+[偽ファイル名]で保存 [B]② ThisWorkbook.SaveAs FalsePath '[新パス]+[新ファイル名]_作成 [B]② NewPath = ThisWorkbook.Path & "\" & strFolname & "\" & DateTimeName & FileExtensionName(ThisWorkbook.Name) '[真ファイル]を[新パス]+[新ファイル名]へ移動及び[新ファイル名]に変更 [B]③ Name TruePath As NewPath '[真ファイル]_[真パス]+[真ファイル名]で保存 [C]④ ThisWorkbook.SaveAs TruePath '[偽ファイル]削除 [C]⑤ Kill (FalsePath) BkOrBackUp = NewPath Exit Function TheERR: MsgBox "ファイルのコピー(バックアップ)エラー！", vbCritical, FileName BkOrBackUp = "" End Function Sub BKUFolder(folName As String) '************************************** '目的のフォルダを検索、無い場合作成する '************************************** 'バックアップ用 Dim strFl_mn As String Dim dirFile As String 'パラメータ 'フォルダ名(パスも含む) strFl_mn = ThisWorkbook.Path & "\" & folName '無い場合目的フォルダを作成 If Dir$(strFl_mn, vbDirectory) = "" Then MkDir strFl_mn End If End Sub Function DateTimeName() As String '********************************* '現在の日付と時刻から文字列作成 '********************************* 'ファイル名やフォルダ名に使用する場合など '１４文字(yyyymmddhhnnss)で返します。 '年年年年月月日日時時分分秒秒 Dim str As String str = Now DateTimeName = Format(str, "yyyy") & Format(str, "mm") & Format(str, "dd") _ & Format(str, "hh") & Format(str, "nn") & Format(str, "ss") End Function 'Private Sub testDateTimeName() ' MsgBox DateTimeName 'End Sub |