起動時にデータmdbを開いてバックアップをとるモジュール

サーバーに置いてあったデータmdbを開くと「'AOIndex'は、このテーブルのインデックスではありません」のエラーが出て、開けなくなった。幸い、プログラムmdbからデータを見ることが出来た*1ので、作り直すことが出来た。
これに対処するため、プログラムmdbの AutoExec マクロに、サーバーにあるデータmdbのバックアップを取るモジュールを組み込んだ。ポイントは、

1. 1. バックアップ直前にデータmdbを開く
      • 「終了」のマクロを起動する。
      • これにより、開けなくなった直後を捉えられる‥‥のではないか。
   2. バックアップ（ファイルコピー）は、バッチファイルで行う。
      • コピー後ファイル名の接頭語として、“yyyymmddhhnn_” を付ける。
      • このため、バッチファイルは毎回作り直す。
   3. イニファイルの作り方で、バックアップを取る/取らないの指定ができる。

§メイン

Public Function BackupMDB() As Boolean
On Error GoTo Err_BackupMDB
Dim mbTitle As String
Dim dsn As Long, i As Long
Dim strCommand As String
Dim backupPath As String, backupFullPath As String, backupFileName As String
Dim strDate As String, batFullPath As String
Dim strDataMDBPath As String, strBackupPath As String, BackupFileSuu As Long
Dim strMDBName As String, exeAccess As String, cmdShell As String

    mbTitle = MYObjName & "/BackupMDB"
    VARAns = SysCmd(acSysCmdSetStatus, "ﾃﾞｰﾀMDBのﾊﾞｯｸｱｯﾌﾟ処理中です。")
    If getParameter(strDataMDBPath, strBackupPath, BackupFileSuu) = False Then Exit Function
    If BackupFileSuu = 0 Then Exit Function
        'ﾌｧｲﾙ名の接頭語
    strDate = Format(Now(), "yyyymmddhhnn") & "_"
        '相対ﾊﾟｽ→絶対ﾊﾟｽ。
    strDataMDBPath = get_PathName(strDataMDBPath)
    strBackupPath = get_PathName(strBackupPath)
        'ﾊﾞｯｸｱｯﾌﾟﾌｫﾙﾀﾞが無ければ作る。
    BOOLAns = make_ExDir(strBackupPath)
        '今日初めてか？
    If isFirst(strBackupPath) = False Then Exit Function
        '先に削除する。(後で削除すると、正常なﾊﾞｯｸｱｯﾌﾟを削除してしまう可能性がある)
    LNGAns = DeleteFiles(strBackupPath, BackupFileSuu)
        'msaccess.exeのﾊﾟｽ
    exeAccess = SysCmd(acSysCmdAccessDir) & "Msaccess.exe"
        'batﾌｧｲﾙのﾌﾙﾊﾟｽ
    batFullPath = CurrentProject.Path & "\" & BATFileName
        'batﾌｧｲﾙを作り替える。
    If Dir(batFullPath) <> "" Then Kill batFullPath
    dsn = FreeFile
    Open batFullPath For Output As #dsn
    strMDBName = Dir(strDataMDBPath & "*.mdb")
    Do While strMDBName <> ""
        backupFileName = strDate & strMDBName
        backupFullPath = strBackupPath & backupFileName
        cmdShell = """" & exeAccess & """ """ & strDataMDBPath & strMDBName & """ /xS_Quit"
        VARAns = Wait_Shell32(cmdShell, vbMinimizedNoFocus)
        strCommand = "COPY """ & strDataMDBPath & strMDBName & """ """ & backupFullPath & """"
        Print #dsn, strCommand
        strMDBName = Dir()
    Loop
    Print #dsn, "EXIT"
    Close #dsn
    DoEvents
    VARAns = Wait_Shell32(batFullPath, vbMinimizedNoFocus)
    BackupMDB = True
    
Exit_BackupMDB:
    VARAns = SysCmd(acSysCmdClearStatus)
    Exit Function
    
Err_BackupMDB:
    MsgBox Err.Number & "/" & Err.Description, vbCritical, mbTitle
    Resume Exit_BackupMDB
End Function

§イニファイルからバックアップ条件を読み出す

Public Function getParameter(argDataMDBPath As String, argBackupPath As String, argNissuu As Long) As Boolean
On Error GoTo Err_getParameter
Dim mbTitle As String
Dim i As Long
Dim iniFullPath As String, strSectionName As String, strKeyName As String
    
    mbTitle = MYObjName & "/getParameter"
    getParameter = False
    strSectionName = CurrentProject.Name
    i = InStrRev(strSectionName, ".", -1, vbTextCompare)
    strSectionName = Left(strSectionName, i - 1)
    iniFullPath = CurrentProject.Path & "\" & strSectionName & ".ini"
        'ｲﾆﾌｧｲﾙが無い時は終る。
    STRAns = Dir(iniFullPath)
    If STRAns = "" Then Exit Function
    
        'ﾃﾞｰﾀMDBのﾊﾟｽ
    strKeyName = "DataMDBPath"
    argDataMDBPath = get_iniString(iniFullPath, strSectionName, strKeyName)
        'ﾃﾞｰﾀMDBのﾊﾟｽ
    strKeyName = "BackupPath"
    argBackupPath = get_iniString(iniFullPath, strSectionName, strKeyName)
        'ﾊﾞｯｸｱｯﾌﾟ日数
    strKeyName = "NumberOfBackup"
    STRAns = get_iniString(iniFullPath, strSectionName, strKeyName)
    If STRAns = "" Then
        If argDataMDBPath = "" Then argNissuu = 0 Else argNissuu = DEFHozonNissuu
    Else
        argNissuu = Val(STRAns)
    End If
    getParameter = True
    
Exit_getParameter:
    Exit Function
    
Err_getParameter:
    MsgBox "イニファイルの取得に失敗しました。システム管理者に連絡してください。" _
            & Err.Number & "/" & Err.Description, vbCritical, mbTitle
    Resume Exit_getParameter
End Function

§今日最初の起動か？（バックアップは１日１回）

Public Function isFirst(argFolder As String) As Boolean
On Error GoTo Err_isFirst
Dim mbTitle As String
Dim i As Long
Dim FileName As String
Dim backupDate As Date

    mbTitle = MYObjName & "/isFirst"
    FileName = Dir(argFolder)
    Do Until FileName = ""
        VARAns = getDate(FileName)
        If Not IsNull(VARAns) Then
            backupDate = CDate(VARAns)
            If DateDiff("d", backupDate, Now) = 0 Then isFirst = False: Exit Function
        End If
        FileName = Dir()
    Loop
    isFirst = True
    
Exit_isFirst:
    Exit Function
    
Err_isFirst:
    MsgBox Err.Number & "/" & Err.Description, vbCritical, mbTitle
    Resume Exit_isFirst
End Function

§ファイル名からバックアップ日付を読み取る（接頭語が yyyymmddhhnn_ になっている）

Public Function getDate(argFileName As String) As Variant
On Error GoTo Err_getDate
Dim mbTitle As String
Dim i As Long

    mbTitle = MYObjName & "/getDate"
    getDate = Null
    STRAns = Left(argFileName, 8)
    If Len(STRAns) <> 8 Then Exit Function
    STRAns = Left(STRAns, 4) & "/" & Mid(STRAns, 5, 2) & "/" & Mid(STRAns, 7, 2)
    If IsDate(STRAns) Then getDate = CDate(STRAns)
    
Exit_getDate:
    Exit Function
    
Err_getDate:
    MsgBox Err.Number & "/" & Err.Description, vbCritical, mbTitle
    Resume Exit_getDate
End Function

§期限切れのファイルを削除する

Public Function DeleteFiles(argFolder As String, argFileSuu As Long) As Long
On Error GoTo Err_DeleteFiles
Dim mbTitle As String
Dim ctrDelete As Long, i As Long, SakujoKensuu As Long
Dim FileName As String, arrayFileName As String
Dim backupDate As Date
Dim SplitTBL As Variant, SplitCTR As Long

    mbTitle = MYObjName & "/DeleteFiles"
    DeleteFiles = 0
    arrayFileName = ""
    FileName = Dir(argFolder)
    Do Until FileName = ""
        If IsDate(getDate(FileName)) Then
            arrayFileName = arrayFileName & "," & FileName
        End If
        FileName = Dir()
    Loop
    If arrayFileName = "" Then Exit Function
    
    arrayFileName = Mid(arrayFileName, 2)
        '並び替える
    VARAns = get_SortStrings(arrayFileName)
    If IsNull(VARAns) Then Exit Function
    SplitTBL = Split(VARAns, ",", -1, vbTextCompare)
    SakujoKensuu = UBound(SplitTBL) - argFileSuu
    If SakujoKensuu < 0 Then Exit Function
    
    ctrDelete = 0
    For i = 0 To SakujoKensuu
        FileName = SplitTBL(i)
        Kill argFolder & FileName
        ctrDelete = ctrDelete + 1
    Next
    DeleteFiles = ctrDelete

Exit_DeleteFiles:
    Exit Function
    
Err_DeleteFiles:
    MsgBox Err.Number & "/" & Err.Description, vbCritical, mbTitle
    Resume Exit_DeleteFiles
End Function

*1:これが発見を遅らせた。