Accessの最適化修復時の問題に対応する為に作った自作ツール

Accessの最適化修復時の問題

レコードが無い テーブルの オートナンバー型 の採番が 1からスタートにリセット されてしまう。

手で対応はスーパーウルトラミラクル面倒

1. テーブルを一つ一つ 手で 開いて、レコードの有無確認…。
2. レコードが0なら 手で ダミーレコード挿入…。
3. 最適化修復し終わったら挿入したダミーレコードを 手で 消していく…。（テーブルを一つ一つ 手で 開いて…）

こんなこと、 とてもじゃないけどやりたくない のでツール作りました。
手でやると間違えるしね…。

自作ツールの概要

主に2つのことを行います。

1. 最適化修復対象Accessを開き、レコードが無いテーブルにダミーレコードをインサート。
   （最適化修復前の下処理）
2. 最適化修復をしたAccessを開き、ダミーレコードをインサートしたテーブルのレコード全削除。
   （最適化修復後の切り戻し）

自作ツールの中身

Accessで実装

ざっくり言うと 外部Accessファイルを操作するAccess です。

オブジェクトは下記3つ

参照設定は下記。

no_record_table

どのテーブルにダミーレコードを挿入したか の情報を持っておく器が主な役割です。

• ダミーレコードが挿入できなかったテーブル洗い出し
• テーブルのレコード全削除が問題無く行えたかの結果保持

としての役割もあります。

q_dummy

各種処理結果などを表示する為だけのダミークエリです。

root

ボタンが2つだけのフォーム。
ボタンは上から『btn_before_optimize』『btn_after_optimize』という名前。

ソースコード

Option Compare Database
Option Explicit


Private FILE_PATH_ As String


Private Sub btn_before_optimize_Click()
    
    
    '---------------------------------------------------------------------------------------------
    Dim sql_ As String
    Dim com_ As New ADODB.Command: com_.ActiveConnection = CurrentProject.Connection
    
    
    '---------------------------------------------------------------------------------------------
    '■ファイル選択
    Dim file_select_ As Long
    
    With Application.FileDialog(msoFileDialogOpen)
    
        .title = "ファイル選択"
        .Filters.Clear
        .Filters.Add "accdb", "*.accdb"
        .Filters.Add "mdb", "*.mdb"
        .FilterIndex = 1
        .AllowMultiSelect = False
        .InitialFileName = CurrentProject.Path & "\"
        
        file_select_ = .Show 'ダイアログを表示
        
        If file_select_ <> 0 Then
        
            FILE_PATH_ = Trim(.SelectedItems.Item(1))
            
        Else
            Exit Sub
        End If
        
    End With
    

    '---------------------------------------------------------------------------------------------
    If MsgBox(FILE_PATH_ & vbCrLf & vbCrLf & "実行OK？", vbYesNo + vbDefaultButton2, "確認") = vbNo Then
        Exit Sub
    End If
    
    
    '---------------------------------------------------------------------------------------------
    '■ファイルバックアップ
    
    Dim fso_ As New Scripting.FileSystemObject
    
    Dim backup_folder_path_ As String
    backup_folder_path_ = CurrentProject.Path & "\Backup_" & Format(Now(), "yyyymmdd_hhnn") & "\"
    Call fso_.CreateFolder(backup_folder_path_)
    Call fso_.CopyFile(FILE_PATH_, backup_folder_path_)
    
    
    '---------------------------------------------------------------------------------------------
    '■レコード0テーブル情報クリア
    com_.CommandText = "DELETE FROM no_record_table ;"
    com_.Execute
    
    
    '---------------------------------------------------------------------------------------------
    '■最適化対象Accessファイル開く
    Dim access_obj_ As New Access.Application
    access_obj_.OpenCurrentDatabase FILE_PATH_, True
    
    
    '---------------------------------------------------------------------------------------------
    '■最適化対象Accessファイル内のテーブル一覧ループ
    Dim obj_ As Object
    For Each obj_ In access_obj_.CurrentData.AllTables
        
        
        Select Case obj_.Attributes
        
            'システム情報やリンクテーブルのデータは除外
            Case 10, -2147483648#, 262154, 2, 2097152, 2097152, 537919488
                Debug.Print "対象外: " & obj_.Name
            
            Case Else
                
                If access_obj_.DCount("*", "[" & obj_.Name & "]") <> 0 Then
                
                    Debug.Print "対象外（レコードあり）: " & obj_.Name
                
                Else
                    
                    'レコード0テーブル情報にインサート
                    com_.CommandText = "INSERT INTO no_record_table (table_name) VALUES (@table_name) "
                    com_.NamedParameters = True
                    com_.Parameters("@table_name") = obj_.Name
                    com_.Execute
                    
                    'テーブルのカラムループして文字列系カラムあったらダミーレコードをインサート
                    Dim dbs_ As DAO.Database: Set dbs_ = access_obj_.CurrentDb
                    Dim tdf_ As DAO.TableDef: Set tdf_ = dbs_.TableDefs(obj_.Name)
                    
                    Dim fld_ As DAO.Field
                    For Each fld_ In tdf_.Fields
                        If fld_.Type = dbText Then
                            access_obj_.DoCmd.SetWarnings False
                            access_obj_.DoCmd.RunSQL "INSERT INTO " & obj_.Name & " ([" & fld_.Name & "]) SELECT 1 "
                            access_obj_.DoCmd.SetWarnings True
                            Exit For
                        End If
                    Next
                    
                    'ダミーレコードインサート結果を保持
                    sql_ = "UPDATE no_record_table SET record_count_after_dummy_insert = @count "
                    sql_ = sql_ & "WHERE table_name = @table_name "
                    com_.CommandText = sql_
                    com_.NamedParameters = True
                    com_.Parameters("@count") = access_obj_.DCount("*", obj_.Name)
                    com_.Parameters("@table_name") = obj_.Name
                    com_.Execute
                
                End If
                
        End Select
                
    Next
    
    
    '---------------------------------------------------------------------------------------------
    '■最適化対象Accessファイル閉じる
    access_obj_.Quit
    
    
    '---------------------------------------------------------------------------------------------
    '■ダミーレコードインサートできなかったテーブル確認
    '文字列系カラムが1つもないテーブルに対しては、このツールからダミーレコードをインサートできない。
    'そういったテーブルは仕方ないので表示した内容を参考に手動でダミーレコードをインサート。
    sql_ = "SELECT * FROM no_record_table WHERE record_count_after_dummy_insert = 0 "
    CurrentDb.QueryDefs("q_dummy").sql = sql_
    DoCmd.OpenQuery "q_dummy", acViewNormal, acReadOnly
    
    
    '---------------------------------------------------------------------------------------------
    MsgBox "処理終了", vbInformation, "通知"
    
    
End Sub



Private Sub btn_after_optimize_Click()
    

    '---------------------------------------------------------------------------------------------
    If MsgBox(FILE_PATH_ & vbCrLf & vbCrLf & "実行OK？", vbYesNo + vbDefaultButton2, "確認") = vbNo Then
        Exit Sub
    End If
    
    
    '---------------------------------------------------------------------------------------------
    '■最適化対象Accessファイル開く
    Dim access_obj_ As New Access.Application
    access_obj_.OpenCurrentDatabase FILE_PATH_, True
    
    
    '---------------------------------------------------------------------------------------------
    '■ツール側で最適化前に控えておいた『レコード無しテーブル一覧』をループ
    Dim sql_ As String
    Dim com_ As New ADODB.Command: com_.ActiveConnection = CurrentProject.Connection
    
    Dim rst_ As New ADODB.Recordset
    rst_.Open _
        "no_record_table", _
        CurrentProject.Connection, _
        adOpenForwardOnly, _
        adLockReadOnly
    Do Until rst_.EOF

        'レコード削除実行
        access_obj_.DoCmd.SetWarnings False
        access_obj_.DoCmd.RunSQL "DELETE FROM [" & rst_.Fields("table_name") & "] "
        access_obj_.DoCmd.SetWarnings True
        
        '念の為レコード削除結果保持
        sql_ = "UPDATE no_record_table SET record_count_after_delete = @count "
        sql_ = sql_ & "WHERE table_name = @table_name "
        com_.CommandText = sql_
        com_.NamedParameters = True
        com_.Parameters("@count") = access_obj_.DCount("*", "[" & rst_.Fields("table_name") & "]")
        com_.Parameters("@table_name") = rst_.Fields("table_name")
        com_.Execute

    rst_.MoveNext: Loop
    rst_.Close
    
    
    '---------------------------------------------------------------------------------------------
    '■最適化対象Accessファイル閉じる
    access_obj_.Quit
    
    
    '---------------------------------------------------------------------------------------------
    '■レコード削除結果確認
    sql_ = "SELECT * FROM no_record_table WHERE record_count_after_delete <> 0 "
    CurrentDb.QueryDefs("q_dummy").sql = sql_
    DoCmd.OpenQuery "q_dummy", acViewNormal, acReadOnly
    
    
    '---------------------------------------------------------------------------------------------
    MsgBox "処理終了", vbInformation, "通知"
    
    
End Sub

ポイント

外部Access操作

下記のようにインスタンスすると外部Accessを操作できる。

Dim access_obj_ As New Access.Application
access_obj_.OpenCurrentDatabase "外部Accessのファイルパス", True

↓外部Accessに対してSQL実行したり…
access_obj_.DoCmd.RunSQL "SQL文"

↓外部Accessのレコード数とったり…
access_obj_.DCount("*", "[テーブル名]")

バックアップ

外部Accessに一時的にではあるが副作用を起こすので、処理前にバックアップとる。

ダミーレコードをインサートできないテーブルもある

頑張ればできるかもしれないが、コードが複雑になるのでやめた。
インサートできなかったテーブル一覧が表示されるようにして、それらは手動対応とする方針にした。

『全てを自動化する』 のが目的ではなく、 『手による処理が大幅に減る』 ことが目的なのでこれでよいという判断。

バージョン

Windows 10 Pro 21H2 OSビルド 19044.2130
Microsoft Access for Microsoft 365 MSO (バージョン 2209 ビルド 16.0.15629.20196) 32 ビット