バックアップ 自らを指定フォルダ内へバックアップ

VB&VBA
FROG ふろっぐ
 
  • オプション

    本文印刷

    お気に入りに追加

  • 検索

    Googlewwwjp-ia
     

    Googlewwwjp-ia
     
  • 情報

  • 関連

[VB&VBA][バックアップ 自らを指定フォルダ内へバックアップ]
Option Explicit


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 StringAs 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]A
ThisWorkbook.SaveAs FalsePath

'[新パス]+[新ファイル名]_作成 [B]A
NewPath = ThisWorkbook.Path & "\" & strFolname & "\" & DateTimeName & FileExtensionName(ThisWorkbook.Name)

'[真ファイル]を[新パス]+[新ファイル名]へ移動及び[新ファイル名]に変更 [B]B
Name TruePath As NewPath

'[真ファイル]_[真パス]+[真ファイル名]で保存 [C]C
ThisWorkbook.SaveAs TruePath

'[偽ファイル]削除 [C]D
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
'*********************************
'現在の日付と時刻から文字列作成
'*********************************
'ファイル名やフォルダ名に使用する場合など
'14文字(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






Production Japan Import Application. Since 1998