AccessVBAでフロントエンド/バックエンド分割：プログラム更新でデータを消さない起動時リンクチェック

Option Compare Database
Option Explicit

'--- バックエンドに置くテーブル（カンマ区切り）---
Private Const c_LINK_TABLES As String = "T_社員,T_部署"
'--- データファイルかどうかの判定に使うテーブル ---
Private Const c_CHECK_TABLES As String = "T_社員,T_部署"

'=========================================================
'  プロシージャ名：gf_GET_BE_PATH
'  機能　　：現在リンクしているデータファイルのフルパスを返します。
'
'  【戻り値】
'    データファイルのフルパス（リンクが無い場合は長さ0）
'=========================================================
Public Function gf_GET_BE_PATH() As String
    On Error Resume Next
    Dim l_db As DAO.Database      ' Database
    Dim l_td As DAO.TableDef      ' テーブル定義
    Dim l_pos As Long             ' "DATABASE=" の位置
    gf_GET_BE_PATH = ""
    Set l_db = CurrentDb          ' 変数に入れておく（下の注意参照）
    Set l_td = l_db.TableDefs(Split(c_LINK_TABLES, ",")(0))
    If l_td Is Nothing Then Exit Function
    '=== Connect は ";DATABASE=C:\data\社員管理_データ.accdb" の形 ===
    l_pos = InStr(1, l_td.Connect, "DATABASE=", vbTextCompare)
    If l_pos > 0 Then gf_GET_BE_PATH = Mid(l_td.Connect, l_pos + 9)
End Function

'=========================================================
'  プロシージャ名：gf_CHECK_LINK
'  機能　　：データファイルへのリンクが有効かを判定します。
'
'  【戻り値】
'    True  … リンク先が存在し、実際に読み取りできる
'    False … 未リンク・リンク切れ・読み取り不可
'
'  【処理概要】
'    ・リンク対象のテーブルがすべてリンクテーブルか確認
'    ・リンク先のファイルが存在するか確認
'    ・実際に1件読み取れるか確認（壊れたファイル等の検出）
'=========================================================
Public Function gf_CHECK_LINK() As Boolean
    On Error GoTo err_CHECK_LINK
    Dim l_db As DAO.Database      ' Database
    Dim l_td As DAO.TableDef      ' テーブル定義
    Dim l_rs As DAO.Recordset     ' 読み取り確認用
    Dim l_name As Variant         ' テーブル名
    Dim l_path As String          ' リンク先パス
    gf_CHECK_LINK = False
    Set l_db = CurrentDb
    '=== すべてリンクテーブルになっているか ===
    For Each l_name In Split(c_LINK_TABLES, ",")
        Set l_td = l_db.TableDefs(l_name)          ' 無ければエラー → False
        If Len(l_td.Connect) = 0 Then Exit Function
    Next l_name
    '=== リンク先ファイルが存在するか ===
    l_path = gf_GET_BE_PATH()
    If Len(l_path) = 0 Then Exit Function
    If Len(Dir(l_path)) = 0 Then Exit Function
    '=== 実際に読み取れるか ===
    For Each l_name In Split(c_LINK_TABLES, ",")
        Set l_rs = l_db.OpenRecordset("SELECT TOP 1 * FROM [" & l_name & "]", dbOpenSnapshot)
        l_rs.Close
    Next l_name
    gf_CHECK_LINK = True
    Exit Function
err_CHECK_LINK:
    gf_CHECK_LINK = False
End Function

'=========================================================
'  プロシージャ名：gf_SELECT_BE_FILE
'  機能　　：データファイル（accdb）を選択するダイアログを表示します。
'
'  【戻り値】
'    選択されたファイルのフルパス（キャンセル時は長さ0）
'=========================================================
Public Function gf_SELECT_BE_FILE() As String
    Dim l_fd As Object            ' FileDialog
    gf_SELECT_BE_FILE = ""
    Set l_fd = Application.FileDialog(3)    ' 3 … msoFileDialogFilePicker
    With l_fd
        .Title = "データファイルを選択してください"
        .AllowMultiSelect = False
        .Filters.Clear
        .Filters.Add "Accessデータベース", "*.accdb"
        .InitialFileName = CurrentProject.Path & "\"
        If .Show = True Then gf_SELECT_BE_FILE = .SelectedItems(1)
    End With
End Function

'=========================================================
'  プロシージャ名：gf_VALIDATE_BE
'  機能　　：指定ファイルがこのシステムのデータファイルかを確認します。
'
'  【引数】
'    strPath ：確認するaccdbのフルパス
'
'  【戻り値】
'    長さ0     … 正常
'    それ以外  … エラー内容（画面表示用）
'=========================================================
Public Function gf_VALIDATE_BE(strPath As String) As String
    On Error GoTo err_VALIDATE_BE
    Dim l_be As DAO.Database      ' データファイル
    Dim l_name As Variant         ' テーブル名
    Dim l_td As DAO.TableDef      ' テーブル定義
    Dim l_found As Boolean        ' 実体のテーブルが見つかったか
    Dim l_miss As String          ' 見つからなかったテーブル
    If Len(Dir(strPath)) = 0 Then
        gf_VALIDATE_BE = "指定されたファイルが見つかりません。"
        Exit Function
    End If
    '=== 読み取り専用で開いて、必要なテーブルが「実体で」あるか確認 ===
    Set l_be = DBEngine.OpenDatabase(strPath, False, True)
    For Each l_name In Split(c_CHECK_TABLES, ",")
        l_found = False
        For Each l_td In l_be.TableDefs
            '--- リンクテーブル（別のフロントエンド等）は数えない ---
            If l_td.Name = l_name And Len(l_td.Connect) = 0 Then l_found = True: Exit For
        Next l_td
        If Not l_found Then l_miss = l_miss & "　・" & l_name & vbCrLf
    Next l_name
    l_be.Close
    If Len(l_miss) > 0 Then
        gf_VALIDATE_BE = "選択されたファイルは、このシステムのデータファイルではないようです。" & vbCrLf & _
                         "次のテーブルが見つかりません。" & vbCrLf & l_miss
    End If
    Exit Function
err_VALIDATE_BE:
    gf_VALIDATE_BE = "ファイルを開けませんでした。" & vbCrLf & Err.Description
End Function

'=========================================================
'  プロシージャ名：gf_LINK_TABLES
'  機能　　：指定したデータファイルへ、全テーブルのリンクを
'            作り直します。
'
'  【引数】
'    strPath ：データファイルのフルパス
'
'  【戻り値】
'    True  … 正常終了
'    False … 中止またはエラー
'
'  【処理概要】
'    ・同名のローカルテーブル（リンクでない実体）があれば中止
'      （リンク作成のために削除すると、データが消えるため）
'    ・既存のリンクを削除し、新しいパスでリンクを作成
'=========================================================
Public Function gf_LINK_TABLES(strPath As String) As Boolean
    On Error GoTo err_LINK_TABLES
    Dim l_db As DAO.Database      ' Database
    Dim l_td As DAO.TableDef      ' テーブル定義
    Dim l_name As Variant         ' テーブル名
    Dim l_local As String         ' ローカル実体のテーブル
    Set l_db = CurrentDb
    '=== ローカルの実体テーブルが無いか確認 ===
    For Each l_td In l_db.TableDefs
        For Each l_name In Split(c_LINK_TABLES, ",")
            If l_td.Name = l_name And Len(l_td.Connect) = 0 Then
                l_local = l_local & "　・" & l_name & vbCrLf
            End If
        Next l_name
    Next l_td
    If Len(l_local) > 0 Then
        MsgBox "次のテーブルがこのファイル内に実体として存在するため、リンクを中止しました。" & vbCrLf & _
               l_local, vbExclamation
        Exit Function
    End If
    '=== リンクを作り直す ===
    For Each l_name In Split(c_LINK_TABLES, ",")
        On Error Resume Next
        l_db.TableDefs.Delete l_name            ' 無ければ何もしない
        On Error GoTo err_LINK_TABLES
        Set l_td = l_db.CreateTableDef(l_name)
        l_td.Connect = ";DATABASE=" & strPath
        l_td.SourceTableName = l_name
        l_db.TableDefs.Append l_td
    Next l_name
    l_db.TableDefs.Refresh
    Application.RefreshDatabaseWindow           ' ナビゲーションウィンドウを更新
    gf_LINK_TABLES = True
    Exit Function
err_LINK_TABLES:
    MsgBox "【gf_LINK_TABLES】リンク中にエラー発生" & vbCrLf & _
           "番号：" & Err.Number & vbCrLf & _
           "内容：" & Err.Description, vbCritical
    gf_LINK_TABLES = False
End Function

'=========================================================
'  プロシージャ名：gf_STARTUP
'  機能　　：起動時にリンクを確認し、切れていれば
'            データファイルを選択してリンクし直します。
'            AutoExecマクロから呼び出します。
'
'  【処理概要】
'    ・リンク切れならファイル選択 → 確認 → 更新 → リンクを繰り返す
'    ・ファイル選択をキャンセルしたらAccessを終了する
'    ・最後にデータファイルの更新要否を確認してメニューを開く
'=========================================================
Public Function gf_STARTUP()
    Dim l_path As String          ' 選択されたファイル
    Dim l_msg As String           ' 確認結果
    Do While Not gf_CHECK_LINK()
        MsgBox "データファイルに接続できません。" & vbCrLf & _
               "データファイルを選択してください。", vbExclamation
        l_path = gf_SELECT_BE_FILE()
        If Len(l_path) = 0 Then
            '=== キャンセル時は終了 ===
            DoCmd.Quit acQuitSaveNone
            Exit Function
        End If
        l_msg = gf_VALIDATE_BE(l_path)
        If Len(l_msg) > 0 Then
            MsgBox l_msg, vbExclamation
        ElseIf gf_UPDATE_BE(l_path) Then
            '=== 必要ならテーブル追加等を反映してからリンク ===
            If gf_LINK_TABLES(l_path) Then MsgBox "リンクが完了しました。", vbInformation
        End If
    Loop
    '=== リンクが正常でも、プログラム更新で変更が必要な場合がある ===
    If Not gf_UPDATE_BE(gf_GET_BE_PATH()) Then
        DoCmd.Quit acQuitSaveNone
        Exit Function
    End If
    DoCmd.OpenForm "F_メニュー"
End Function

'=========================================================
'  プロシージャ名：gf_UPDATE_BE
'  機能　　：データファイルにテーブル・列の追加を反映します。
'            変更内容は pf_UPDATE_ITEMS に書きます。
'
'  【引数】
'    strPath ：データファイルのフルパス
'
'  【戻り値】
'    True  … 正常終了（変更が無かった場合も含む）
'    False … エラー発生
'
'  【処理概要】
'    ・読み取り専用で開き、必要な変更があるかだけを確認
'    ・変更が無ければ何もしない
'    ・変更があればバックアップを作成してから反映し、
'      リンクを作り直す
'=========================================================
Public Function gf_UPDATE_BE(strPath As String) As Boolean
    On Error GoTo err_UPDATE_BE
    Dim l_be As DAO.Database      ' データファイルを直接開く
    Dim l_items As String         ' 必要な変更の一覧
    Dim l_bak As String           ' バックアップファイル
    '=== 必要な変更があるか確認（読み取り専用）===
    Set l_be = DBEngine.OpenDatabase(strPath, False, True)
    l_items = pf_UPDATE_ITEMS(l_be, False)
    l_be.Close
    Set l_be = Nothing
    If Len(l_items) = 0 Then
        gf_UPDATE_BE = True
        Exit Function
    End If
    '=== バックアップ（同じフォルダに日時付きでコピー）===
    l_bak = Left(strPath, InStrRev(strPath, ".") - 1) & "_" & Format(Now(), "yyyymmddhhnnss") & "_bak.accdb"
    FileCopy strPath, l_bak
    '=== 変更を反映 ===
    Set l_be = DBEngine.OpenDatabase(strPath)
    Call pf_UPDATE_ITEMS(l_be, True)
    l_be.Close
    Set l_be = Nothing
    '=== 追加した列・テーブルをリンクに反映 ===
    If Not gf_LINK_TABLES(strPath) Then Exit Function
    MsgBox "データファイルを更新しました。" & vbCrLf & l_items & vbCrLf & _
           "バックアップ：" & l_bak, vbInformation
    gf_UPDATE_BE = True
    Exit Function
err_UPDATE_BE:
    MsgBox "【gf_UPDATE_BE】データファイル更新中にエラー発生" & vbCrLf & _
           "番号：" & Err.Number & vbCrLf & _
           "内容：" & Err.Description, vbCritical
    If Not l_be Is Nothing Then l_be.Close
    gf_UPDATE_BE = False
End Function

'=========================================================
'  プロシージャ名：pf_UPDATE_ITEMS
'  機能　　：データファイルに必要な変更を確認・実行します。
'            リリースごとに【変更内容】の部分を追記します。
'
'  【引数】
'    p_db      ：データファイル
'    p_Execute ：False … 確認だけ / True … 実行する
'
'  【戻り値】
'    必要な変更の一覧（無ければ長さ0）
'=========================================================
Private Function pf_UPDATE_ITEMS(p_db As DAO.Database, p_Execute As Boolean) As String
    Dim l_items As String
    '=== 【変更内容】ここから ===
    '--- v1.1：社員にメールアドレスを追加 ---
    If Not pf_FIELD_EXISTS(p_db, "T_社員", "メールアドレス") Then
        l_items = l_items & "　・T_社員にメールアドレスを追加" & vbCrLf
        If p_Execute Then
            p_db.Execute "ALTER TABLE T_社員 ADD COLUMN メールアドレス TEXT(100)", dbFailOnError
            Call ps_ALLOW_ZERO_LENGTH(p_db, "T_社員", "メールアドレス")
        End If
    End If
    '--- v1.1：資格マスタを追加 ---
    If Not pf_TABLE_EXISTS(p_db, "M_資格") Then
        l_items = l_items & "　・M_資格を作成" & vbCrLf
        If p_Execute Then
            p_db.Execute "CREATE TABLE M_資格 (資格コード LONG CONSTRAINT PK_M_資格 PRIMARY KEY, " & _
                         "資格名 TEXT(50))", dbFailOnError
            Call ps_ALLOW_ZERO_LENGTH(p_db, "M_資格")
        End If
    End If
    '=== 【変更内容】ここまで ===
    pf_UPDATE_ITEMS = l_items
End Function

'--- テーブルの有無 ---
Private Function pf_TABLE_EXISTS(p_db As DAO.Database, p_Table As String) As Boolean
    Dim l_td As DAO.TableDef
    For Each l_td In p_db.TableDefs
        If l_td.Name = p_Table Then pf_TABLE_EXISTS = True: Exit Function
    Next l_td
End Function

'--- 列の有無 ---
Private Function pf_FIELD_EXISTS(p_db As DAO.Database, p_Table As String, p_Field As String) As Boolean
    Dim l_fld As DAO.Field
    If Not pf_TABLE_EXISTS(p_db, p_Table) Then Exit Function
    For Each l_fld In p_db.TableDefs(p_Table).Fields
        If l_fld.Name = p_Field Then pf_FIELD_EXISTS = True: Exit Function
    Next l_fld
End Function

'--- テキスト列の「空文字列の許可」をはいにする ---
'    p_Field を指定したときはその列だけ、省略時はテーブルの全テキスト列
'    （既存テーブルに列を足すときは、既存列の設定を変えないよう必ず指定する）
Private Sub ps_ALLOW_ZERO_LENGTH(p_db As DAO.Database, p_Table As String, Optional p_Field As String = "")
    Dim l_fld As DAO.Field
    '=== DDLで作ったテーブル・列は Refresh しないと見えない ===
    p_db.TableDefs.Refresh
    p_db.TableDefs(p_Table).Fields.Refresh
    For Each l_fld In p_db.TableDefs(p_Table).Fields
        If Len(p_Field) = 0 Or l_fld.Name = p_Field Then
            If l_fld.Type = dbText Or l_fld.Type = dbMemo Then l_fld.AllowZeroLength = True
        End If
    Next l_fld
End Sub