Declare Function FindWindow Lib "user32" _
    Alias "FindWindowA" _
    (ByVal lpClassName As String, _
    ByVal lpWindowName As String) As Long

Declare Function SHFileOperation Lib "shell32.dll" _
    Alias "SHFileOperationA" _
    (lpFileOp As SHFILEOPSTRUCT) As Long

Type SHFILEOPSTRUCT
    hwnd As Long                    'ダイアログボックスの親ウィンドウのハンドル
    wFunc As Long                   '操作内容を指定する
    pFrom As String                 '操作元のファイル名、ディレクトリ名
    pTo As String                   '操作先のファイル名、ディレクトリ名
    fFlags As Integer               '操作内容を指定する
    fAnyOperationsAborted As Long   '処理終了前にキャンセルしたときは「1」
    hNameMappings As Long           'ファイルネームマッピングオブジェクト
    lpszProgressTitle As String     'ダイアログボックスのキャプション
End Type

Public BackupInterval As Date       '自動保存の処理間隔

Sub auto_open()
'
    Auto_Backup_Start

'auto_open に既に他のマクロが記述されている場合には、この１行だけを追加する
'
End Sub

Sub BackUpFileNameSet()             'プロパティのコメント欄にバックアップ先を指定
'
    Dim BackupFileName As Variant
    
    BackupFileName = Application.GetSaveAsFilename _
                    (FileFilter:="Microsoft Excel ファイル(*.xl*),*.xl*", _
                    Title:="バックアップ先ファイルの指定")
    
    If BackupFileName <> False Then
        If Right(BackupFileName, 4) = ".xl*" Then
            BackupFileName = Left(BackupFileName, Len(BackupFileName) - 4)
        End If
        MsgBox "バックアップ先に " & Chr$(13) & Chr$(13) & _
                BackupFileName & Chr$(13) & Chr$(13) & "を指定します。"
        BackupFileName = "[Backup] " & BackupFileName
        ActiveWorkbook.BuiltinDocumentProperties(5).Value = BackupFileName
    End If
'
End Sub

Sub AutoBackup()                    '自動保存とバックアップ
'
    Dim wb As Variant
    Dim udtSHFILEOPSTRUCT As SHFILEOPSTRUCT
    Dim rc As Long
    Dim strClassName As String          'クラス名
    Dim FO_COPY  As Variant             'コピー
    Dim FOF_NOCONFIRMATION As Variant   '確認なし
    
    FO_COPY = &H2&
    FOF_NOCONFIRMATION = &H10&
    strClassName = "XLMAIN"
    
    For Each wb In Workbooks
        If wb.BuiltinDocumentProperties(5).Value <> "" And _
           Left(wb.BuiltinDocumentProperties(5).Value, 9) = "[Backup] " And _
           wb.Saved <> True Then            '変更無しなら何もせず
                
            wb.Activate
            wb.Save                     'まずは保存
                
            With udtSHFILEOPSTRUCT
                .hwnd = FindWindow(strClassName, Application.Caption)
                .wFunc = FO_COPY
                .pFrom = wb.Path & "\" & wb.Name
                .pTo = Mid(wb.BuiltinDocumentProperties(5).Value, 10)
                .fFlags = FOF_NOCONFIRMATION
            End With
            rc = SHFileOperation(udtSHFILEOPSTRUCT)     'ファイルのコピーを実行
        End If
    Next
    
    Auto_Backup_Start
'
End Sub

Sub Auto_Backup_Start()		'保存の時間間隔の設定
'
    BackupInterval = Now + TimeValue("00:05:00")        '５分に設定（好みの時間設定にしてください）
    Application.OnTime EarliestTime:=BackupInterval, Procedure:="AutoBackup"
'
End Sub

Sub Auto_Backup_Stop()		'自動保存＆バックアップ機能をストップする場合はこのマクロを実行してください
'
    Application.OnTime EarliestTime:=BackupInterval, Procedure:="AutoBackup", _
                       Schedule:=False
'
End Sub