バックアップ バックアップ（FSO）
※より実装に近く表示させる為、コードの改行を避けています。スマホ等で閲覧される際は向きを変えてご覧ください。
※実装するバージョンによってはバージョンアップの仕様により動作しないコードもあります。実装には動作確認の上ご使用下さい。
Sub FileCopy() On Error GoTo ERROR Dim MyPath As String Dim TargetPath As String Dim blnCheck As Boolean Dim strChoice As String Dim Mypractice As Integer Dim FolderName As String Dim objFSO As Object Mytrial: Set objFSO = CreateObject("Scripting.FileSystemObject") 'FSO定義 MyPath = Application.ActiveWorkbook.Path '現在パス TargetPath = "\\PCname\c\My Documents\TEST\TEST" '目的のパス blnCheck = objFSO.Folderexists(TargetPath & "1\") 'フォルダー1の存在を確認 If blnCheck = False Then '無い場合 strchoice strChoice = MsgBox(TargetPath & " Path無いか、該当フォルダ不明です。もう一度実行しますか?" _ & vbCr & vbCr & "《はい》:この処理を中止します。" _ & vbCr & "《いいえ》:もう一度実行します。", vbYesNo, "ERROR") Select Case strChoice Case vbNo '《いいえ》 Set objFSO = Nothing Exit Sub Case vbYes '《はい》practice Set objFSO = Nothing GoTo Mytrial End Select End If For Mypractice = 1 To 5 FolderName = TargetPath & CStr(Mypractice) & "\" blnCheck = objFSO.Folderexists(FolderName) If blnCheck = False Then objFSO.copyfolder MyPath, TargetPath & CStr(Mypractice) MsgBox "<<BackUp>>終了", 0, "END" Set objFSO = Nothing Exit Sub End If Next Mypractice objFSO.deletefolder TargetPath & "1" Name TargetPath & "2" As TargetPath & "1" Name TargetPath & "3" As TargetPath & "2" Name TargetPath & "4" As TargetPath & "3" Name TargetPath & "5" As TargetPath & "4" objFSO.copyfolder MyPath, TargetPath & "5" Set objFSO = Nothing MsgBox "<<BackUp>>終了", 0, "END" Exit Sub ERROR: MsgBox "FileCopyを実行中エラー " & Err.Number & " 発生 ", vbCritical, "ERROR" End Sub |