MS Access のモジュール差し替えツールを作ってみた

Microsoft Access では、外部データベース（リンクテーブルやパススルークエリ）を使わない限り、データベースはローカルテーブルとして、ソースコード（モジュール）と同じaccdbファイルに収められます。

本社の64ビット対応したコード（PtrSafeキーワードを含むDeclareステートメント）を、64ビットに移行が完了した地方営業所に配布しなければならないのですが、データベースは各拠点で個別に更新されており（ローカルテーブル）、コードだけ差し替えたい、というのが今回の要件です。

これには、VBE（VBA開発環境）のメニューからモジュールをエクスポートし、相手方でインポートしてもらう方法があり、これと同じことをVBE.ActiveVBProject.VBComponentsオブジェクトを使ってスクリプトに落とし込むのが良さげなのですが、どうも馴染みませんでした。

さらに調べてみると、SaveAsText、LoadFromTextという隠しコマンドがあるらしいので、試してみました。

概念図を示します。

ツールの使い方

Excelを開き、次のコードを標準モジュールに貼り付けます。

Option Explicit

Sub replaceModule()
    Dim ws As Worksheet  ' Excelオブジェクト
    Dim acApp As Object, db As Object  ' Accessオブジェクト
    Dim o As Object  ' 汎用オブジェクト
    Dim sBaseDir As String, sExportDir As String, sDistDir As String, sFile As String ' フォルダ／ファイル
    Dim i As Long, j As Long, s As String
    
    Const acQuery = 1  ' クエリ
    Const acForm = 2  ' フォーム
    Const acReport = 3  ' レポート
    Const acModule = 5  ' モジュール
    
    sBaseDir = ThisWorkbook.Path & "\"  ' 基準となるディレクトリ
    sExportDir = sBaseDir & "export\"  ' エクスポートファイルを置くフォルダ
    sDistDir = sBaseDir & "dist\"  ' 配布するAccessファイルを置くフォルダ
    
    sFile = sBaseDir & Dir(sBaseDir & "*.accdb")  ' 元となるAccessファイル
    If Dir(sFile) = "" Then
        MsgBox "元となるAccessファイルがありません"
        Exit Sub
    End If
    
    If Dir(sDistDir, vbDirectory) = "" Then
        MsgBox sDistDir & vbLf & "に配布するAccessファイルを置いて下さい", vbCritical
        MkDir sDistDir  ' 配布するAccessファイルを置くフォルダが無ければ作成
        Exit Sub
    End If
    
    If Dir(sExportDir, vbDirectory) = "" Then MkDir sExportDir  ' エクスポートファイルを置くフォルダを作成
    
    If MsgBox(sFile & vbLf & "　　▼" & vbLf & sDistDir, vbInformation + vbOKCancel) = vbCancel Then Exit Sub
    
    Set acApp = CreateObject("Access.Application")  ' Accessアプリケーションオブジェクト
    acApp.Visible = True  ' Accessアプリケーションを表示
    
    Set ws = Workbooks.Add.Sheets(1)  ' シート作成
    ws.Cells(1, 1) = "エクスポートファイル名"
    ws.Cells(1, 2) = "オブジェクト名"
    ws.Cells(1, 3) = "→配布先Accessファイル名"
    i = 2
    
    '----------------
    '  エクスポート
    '----------------
    acApp.OpenCurrentDatabase sFile  ' 元となるAccessファイルを開く
    Set db = acApp.DBEngine.Workspaces(0).OpenDatabase(sFile)
    
    For Each o In db.QueryDefs
        If Left(o.Name, 1) <> "~" Then
            s = sExportDir & o.Name & ".sql"
            ws.Cells(i, 1) = s
            ws.Cells(i, 2) = o.Name
            i = i + 1
            acApp.SaveAsText acQuery, o.Name, s
        End If
    Next
    For Each o In db.Containers("Forms").Documents
        s = sExportDir & o.Name & ".frm"
        ws.Cells(i, 1) = s
        ws.Cells(i, 2) = o.Name
        i = i + 1
        acApp.SaveAsText acForm, o.Name, s
    Next
    For Each o In db.Containers("Reports").Documents
        s = sExportDir & o.Name & ".rpt"
        ws.Cells(i, 1) = s
        ws.Cells(i, 2) = o.Name
        i = i + 1
        acApp.SaveAsText acReport, o.Name, s
    Next
    For Each o In db.Containers("Modules").Documents
        s = sExportDir & o.Name & ".bas"
        ws.Cells(i, 1) = s
        ws.Cells(i, 2) = o.Name
        i = i + 1
        acApp.SaveAsText acModule, o.Name, s
    Next
    
    acApp.CloseCurrentDatabase
    
    '--------------
    '  インポート
    '--------------
    j = 3
    sFile = Dir(sDistDir & "*.accdb")
    Do Until sFile = ""
        acApp.OpenCurrentDatabase sDistDir & sFile
        i = 2
        Do Until ws.Cells(i, 1) = ""
            ' 半角の濁点・半濁点がオブジェクト名に含まれていればスキップ
            If InStr(ws.Cells(i, 2), "ﾞ") > 0 Or InStr(ws.Cells(i, 2), "ﾟ") > 0 Then GoTo CONTINUE
            
            Select Case Right(ws.Cells(i, 1), 3)
            Case "sql"
                acApp.LoadFromText acQuery, ws.Cells(i, 2), ws.Cells(i, 1)
            Case "frm"
                acApp.LoadFromText acForm, ws.Cells(i, 2), ws.Cells(i, 1)
            Case "rpt"
                acApp.LoadFromText acReport, ws.Cells(i, 2), ws.Cells(i, 1)
            Case "bas"
                acApp.LoadFromText acModule, ws.Cells(i, 2), ws.Cells(i, 1)
            End Select
            ws.Cells(i, j) = sFile
CONTINUE:
            i = i + 1
        Loop
        acApp.CloseCurrentDatabase
        j = j + 1
        sFile = Dir()
    Loop
    
    ws.Cells.EntireColumn.AutoFit  ' 列幅の自動調整
End Sub

実行手順です。

1. 任意のフォルダを作成します。
2. このExcelマクロと、元となるAccessファイルを 1. のフォルダに置きます。
3. マクロ（replaceModule）を実行します。
4. distというフォルダが作成されます。
5. 配布するAccessファイル（複数可）を 4. のフォルダに置きます。
6. もう一度、マクロ（replaceModule）を実行します。
7. 配布するAccessファイル（複数可）が一括で修正されます。

制約事項は、モジュール名に半角の濁音・半濁音が含まれているとエラーになることですが、OfficeやWindowsのバージョンによっては再現しないかもです。

モジュールだけではなく、フォームやレポート、クエリの一括取り込みにも対応しています。必要なければコメントアウトして下さい。