Accessなしでデータベースを作成する。

DAOを使ってAccessなしでデータベース(MDB)を作成するサンプルです。
「ダウンロード」で紹介しているものです。   このサンプルは「ダウンロード」のMDB(ACCDB)生成/テーブル定義取得ツール」を利用しています。
ソースコードを変更することなく利用できるもので、「ダウンロード」の方ではコードの説明を行なっておりませんので、こちらで紹介します。 当初、このページにはADOXを使ったサンプルを掲載していたのですが、 ADOXではMDBの全機能が設定できないことから、 DAOに変更したものです。



MDBテーブル定義(テーブル操作サンプル).xlsm
(画像をクリックすると、このページのサンプルがダウンロードできます)

これはダウンロードした「MDB(ACCDB)SampleCorp1.zip」の中にある「MDB(ACCDB)テーブル定義(テーブル操作サンプル).xlsm」を開いたところです。
部署マスタ、役職マスタ、社員マスタ、配属マスタのテーブル定義がそれぞれのシートに並んだものですが、 このワークブックは当サイトの「ダウンロード」のMDB(ACCDB)生成/テーブル定義取得ツール」を利用しています。 つまり、このワークブックのマクロでこのテーブル定義に従ったデータベース(MDB)が作成できるのです。

マクロは変更しなくても通常は問題なく利用でき、MDB(ACCDB)ファイル名はマクロ起動直後に指定する仕組みになっています。
ですが、ここではマクロコードを紹介するページなので、MDB(ACCDB)ファイルの新規作成に限ってマクロコードを紹介します。 実際にダウンロードされたもののマクロコードにはMDB(ACCDB)ファイルからテーブル定義シートを作成する「テーブル定義情報の取得」や、 作成済みのMDB(ACCDB)ファイルにテーブルを追加する「テーブル定義情報の追加」も含まれているのですが、 ここでのマクロコードの紹介からは除外してあります。

マクロコードの紹介は実際は1つのモジュールに収まっているものでこのページの紹介部分だけで1000行弱になるものです。 一気に掲示しても解りにくいと思いますから3つのブロックに分けます。
最初のブロックがデータベース(MDB又はACCDB)作成、その中のテーブル作成の本体です。
2番目のブロックが各テーブル定義ワークシートの条理チェックをしている部分です。
最後のブロックは共通関数で、他のマクロでも使用されているものです。

外部から呼び出されるプロシージャ「MDBファイルの生成」以外はすべて本処理内の「サブ処理(Private)」です。
MDBファイルの生成」本体内では、まずMDB(ACCDB)ファイルの生成が行なわれますが、 MDBファイル内の各テーブルの作成はワークシートを巡回しながら「テーブルの追加(GP_ADD_Table)」が行ないます。
さらにその次にワークシートを巡回しながらシート名やフィールド名の日本語説明を「テーブル説明等の追加(GP_ADD_Setsumei)」が行ないます。
最後の「項目属性テーブル作成(GP_SetDataTypeTable)」は処理の先頭で設定シートからデータタイプごとの属性をテーブルに収容する処理ですが、 このテーブルには各データタイプでサイズ要求があるか、数値属性か、値要求判定があるか、空文字不可判定があるか、などの情報が得られて、 テーブルのフィールド作成の他、ワークシート単位のフィールドのチェック時にも利用されます。

'***************************************************************************************************
'   MDB(ACCDB)テーブル定義作成、MDB(ACCDB)生成
'
'   作成者:井上治  URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'***************************************************************************************************
'   [参照設定]
'   ・Microsoft Scripting Runtime
'   ・Windows Script Host Object Model
'   ・Microsoft Office 1x.0 Access database engine Object Library
'***************************************************************************************************
' 変更日付 Rev   変更履歴内容---------------------------------------------------------------------->
' 12/11/23(1.0.0)新規作成
' 16/12/04(1.1.0)チェック方法の改善等の見直し
' 16/12/05(1.1.0)チェック方法の改善等の見直し(不具合修正等)
' 17/01/08(1.1.0)ファイル名取得方法の改善、他修正
' 17/03/07(1.1.1)テンプレートだと現在パスの取得に失敗する件の対応
' 19/10/29(1.2.0)Declare記述の変更(64ビット版Excel対応)
' 19/11/17(1.3.0)参照設定変更(DAO⇒Access database engine),MDB・ACCDB兼用に変更
' 19/11/17(1.3.0)ファイル名受け取りの共通処理化、ファイル名チェックの追加
' 19/11/19(1.3.1)CreateDatabaseの第3引数でMDBとACCDBを見分けるように対応
' 19/11/20(1.3.2)MDB作成時は極力上書き保存されないように対応
' 19/11/25(1.3.3)ファイルフィルタをMDB,ACCDB両用(同時表示)に変更(作成時と取得時で区別)
'***************************************************************************************************
Option Explicit
'===================================================================================================
Private Const g_cnsSH0 = "設定"
Private Const g_cnsSH1 = "原紙"
Private Const g_cnsFilterC = "MDBファイル (*.mdb),*.mdb,ACCDBファイル (*.accdb),*.accdb" ' 作成時
Private Const g_cnsFilterR = "MDB(ACCDB)ファイル (*.mdb;*.accdb),*.mdb;*.accdb" ' 取得時
Private Const g_cnsYes = "はい"
Private Const g_cnsNo = "いいえ"
Private Const g_cnsKyoka = "許可"
Private Const g_cnsFuka = "不可"
Private Const g_cnsMaru = "○"
Private Const g_cnsBatsu = "×"
Private Const g_cnsNA = "-"
Private Const g_cnsCOM = ","
Private Const g_cnsDescription = "Description"
Private Const g_cnsAutoNumber = "オートナンバー型"
Private Const MAX_PATH = 260
'---------------------------------------------------------------------------------------------------
#If VBA7 Then
' ■ローカルドライブからマウントされているネットワークリソース名を取得する
Private Declare PtrSafe Function WNetGetConnection Lib "MPR.dll" _
    Alias "WNetGetConnectionA" _
    (ByVal lpszLocalName As String, _
     ByVal lpszRemoteName As String, _
     ByRef cbRemoteName As Long) As Long
#Else
' ■ローカルドライブからマウントされているネットワークリソース名を取得する
Private Declare Function WNetGetConnection Lib "MPR.dll" _
    Alias "WNetGetConnectionA" _
    (ByVal lpszLocalName As String, _
     ByVal lpszRemoteName As String, _
     ByRef cbRemoteName As Long) As Long
#End If
'---------------------------------------------------------------------------------------------------
' フィールドタイプテーブル
Private Type g_typFieldType
    Gyo As Long                                                     ' 行INDEX
    ShowType As String                                              ' 表示タイプ
    NeedSize As Boolean                                             ' サイズ要求
    AsNumeric As Boolean                                            ' 数値タイプ
    NeedValue As Boolean                                            ' 値要求
    NotBlank As Boolean                                             ' 空文字不可
    Memo As String                                                  ' メモ
    TypeString As String                                            ' タイプ文字列
    TypeValue As Integer                                            ' タイプ値
End Type
Private g_tblFieldType() As g_typFieldType                          ' フィールドタイプテーブル
Private g_lngFieldTypeMAX As Long                                   ' テーブルINDEX(項目タイプ)
Private g_lngIxAutoNumber As Long                                   ' テーブルINDEX(自動ナンバー)

'***************************************************************************************************
'* 処理名 :MDBファイルの生成
'* 機能  :テーブル定義情報からMDBを生成
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数  :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2012年11月23日
'* 作成者 :井上 治
'* 更新日 :2019年11月20日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Public Sub MDBファイルの生成()
    '-----------------------------------------------------------------------------------------------
    Const cnsTitle = "MDB(ACCDB)ファイルの生成"
    Dim objSh As Worksheet                                          ' ワークシート
    Dim objSh0 As Worksheet                                         ' ワークシート(設定)
    Dim objMdb As DAO.Database                                      ' DAO.Database
    Dim objFso As FileSystemObject                                  ' FileSystemObject
    Dim objFile As File                                             ' File
    Dim blnOpen As Boolean                                          ' Open判定
    Dim blnSaved As Boolean                                         ' Saved判定
    Dim strFilename As String                                       ' ファイル名
    Dim strFilename2 As String                                      ' ファイル名(パス無)
    Dim strPathname As String                                       ' フォルダ名
    Dim strExtU As String                                           ' 拡張子(大文字)
    Dim strErrMSG As String                                         ' エラーメッセージ
    blnSaved = ThisWorkbook.Saved
    '-----------------------------------------------------------------------------------------------
    ' 項目属性テーブル作成
    Call GP_SetDataTypeTable
    '-----------------------------------------------------------------------------------------------
    ' 登録内容の検査⇒チェックNGは終了
    If Not FP_CheckSheet Then Exit Sub
    Set objSh0 = ThisWorkbook.Worksheets(g_cnsSH0)                  ' 設定
    strFilename2 = Trim(objSh0.Cells(2, 16).Value)                  ' 初期ファイル
    strPathname = Trim(objSh0.Cells(2, 17).Value)                   ' 初期フォルダ
    '-----------------------------------------------------------------------------------------------
    ' MDB(ACCDB)ファイル名の受け取り
    If Not FP_GetMdbFilename(1, _
                             "作成するMDB(ACCDB)ファイルを指定して下さい。", _
                             strFilename, _
                             strPathname, _
                             strFilename2) Then GoTo CreateMDB_EXIT
    ' MDB(ACCDB)ファイル名チェック
    If Not FP_CheckMdbFilename(cnsTitle, 1, strFilename) Then GoTo CreateMDB_EXIT
    '-----------------------------------------------------------------------------------------------
    On Error GoTo CreateMDB_ERROR
    Set objFso = New FileSystemObject
    ' 当該MDBが既に存在する場合は一旦、削除する
    If objFso.FileExists(strFilename) Then
        If MsgBox("指定のデータベースファイルは既に存在しています。" & vbCr & _
                  "本生成処理を行なうと現データベースに登録されているデータは" & vbCr & _
                  "全て失われます。処理を行なってよろしいですか?", _
                  vbInformation + vbYesNo, cnsTitle) <> vbYes Then GoTo CreateMDB_EXIT
        Application.DisplayAlerts = False
        objFso.DeleteFile strFilename, True
        Application.DisplayAlerts = True
    End If
    '-----------------------------------------------------------------------------------------------
    ' 拡張子の取得
    strExtU = UCase(objFso.GetExtensionName(strFilename))
    ' MDB(ACCDB)を生成(拡張子を判定して種別を制御)
    If strExtU <> "ACCDB" Then
        ' MDBとして処理
        Set objMdb = DBEngine.CreateDatabase(strFilename, dbLangJapanese, dbVersion40)
    Else
        ' ACCDBとして処理(デフォルト)
        Set objMdb = DBEngine.CreateDatabase(strFilename, dbLangJapanese)
    End If
    blnOpen = True
    ' 設定シートにデータベース名を登録
    Set objFile = objFso.GetFile(strFilename)
    strFilename2 = objFile.Name                                     ' ファイル名
    strPathname = Left(strFilename, Len(strFilename) - Len(strFilename2) - 1) ' フォルダ名
    ' マウントされているネットワークリソース名を取得する
    If Mid$(strPathname, 2, 1) = ":" Then
        strPathname = FP_GetResourceNameFromLocalDrive(strPathname) & Mid$(strPathname, 3)
    Else
        strPathname = strPathname
    End If
    '-----------------------------------------------------------------------------------------------
    ' 初期DB名
    If objSh0.Cells(2, 16).Value <> strFilename2 Then
        objSh0.Cells(2, 16).Value = strFilename2
        blnSaved = False
    End If
    ' 初期フォルダ
    If objSh0.Cells(2, 17).Value <> strPathname Then
        objSh0.Cells(2, 17).Value = strPathname
        blnSaved = False
    End If
    '-----------------------------------------------------------------------------------------------
    ' 登録シートを巡回
    For Each objSh In ThisWorkbook.Worksheets
        ' 原紙、設定シートを除外
        If ((objSh.Name <> g_cnsSH0) And (objSh.Name <> g_cnsSH1)) Then
            '  テーブルの追加
            Call GP_ADD_Table(objMdb, objSh, cnsTitle)
        End If
    Next objSh
    objMdb.Close
    blnOpen = False
    DoEvents
    ' 項目名称、項目説明のセット
    Set objMdb = DBEngine.OpenDatabase(strFilename)
    blnOpen = True
    ' 登録シートを巡回
    For Each objSh In ThisWorkbook.Worksheets
        If ((objSh.Name <> g_cnsSH0) And (objSh.Name <> g_cnsSH1)) Then
            ' テーブル説明等の追加
            Call GP_ADD_Setsumei(objMdb, objSh)
        End If
    Next objSh
    GoTo CreateMDB_EXIT
'===================================================================================================
' エラー処理
CreateMDB_ERROR:
    strErrMSG = Err.Description
'===================================================================================================
' 終了
CreateMDB_EXIT:
    ' MDB(ACCDB)を切断
    If blnOpen Then objMdb.Close
    Set objMdb = Nothing
    ' エラーがあるか
    If strErrMSG <> "" Then
        MsgBox strErrMSG, vbCritical, cnsTitle
    End If
    Set objFile = Nothing
    Set objSh0 = Nothing
    Set objFso = Nothing
    ThisWorkbook.Saved = blnSaved
    On Error GoTo 0
End Sub

'***************************************************************************************************
'  ■■■ サブ処理(Private) ■■■
'***************************************************************************************************
'* 処理名 :GP_ADD_Table
'* 機能  :テーブルの追加(サブ処理)
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数  :Arg1 = 対象MDB(DAO.Database)
'*      Arg2 = 対象シート(Excel.Worksheet)
'*      Arg3 = 処理タイトル(String)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2012年11月23日
'* 作成者 :井上 治
'* 更新日 :2016年12月04日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:シート上のエラーチェックが済んでいる前提
'***************************************************************************************************
Private Sub GP_ADD_Table(ByRef objMdb As DAO.Database, _
                         ByRef objSh As Worksheet, _
                         ByVal cnsTitle As String)
    '-----------------------------------------------------------------------------------------------
    Dim objTbl As DAO.TableDef                                      ' DAO.TableDef
    Dim objFld As DAO.Field                                         ' DAO.Field
    Dim objIdx As DAO.Index                                         ' DAO.Index
    Dim lngGyo As Long                                              ' 行INDEX
    Dim lngGyoMax As Long                                           ' 最終行INDEX
    Dim lngCol As Long                                              ' カラムINDEX
    Dim lngCol2 As Long                                             ' カラムINDEX
    Dim vntKeyName As Variant                                       ' キーフィールドIDテーブル
    Dim vntPriKey As Variant                                        ' プライマリ判定テーブル
    Dim strType As String                                           ' フィールドタイプ
    Dim tblFieldId() As String                                      ' フィールドIDテーブル
    Dim lngIx As Long                                               ' テーブルINDEX
    Dim lngIdxMAX As Long                                           ' INDEXテーブル最大INDEX
    Dim lngIdxNo As Long                                            ' INDEXナンバー

    ' テーブルを新規作成
    On Error Resume Next
    Set objTbl = objMdb.CreateTableDef(Trim(objSh.Cells(2, 3).Value))
    ' エラーがあれば終了
    If Err.Number <> 0 Then
        MsgBox Err.Description & vbCr & " (" & Trim(objSh.Cells(2, 3).Value) & ")", _
            vbExclamation, cnsTitle
        objMdb.Close
        End
    End If
    On Error GoTo 0
    lngGyoMax = objSh.Range("$E$" & objSh.Rows.Count).End(xlUp).Row
    vntKeyName = Array("Pri-Key", "Index_1", "Index_2", "Index_3", "Index_4", "Index_5")
    vntPriKey = Array(True, False, False, False, False, False)
    '-----------------------------------------------------------------------------------------------
    ' ワークシートの行を巡回⇒フィールドを作成
    For lngGyo = 4 To lngGyoMax
        ' フィールドの判定
        strType = Trim(objSh.Cells(lngGyo, 12).Value)
        lngIx = 0
        ' 項目属性テーブルを巡回
        Do While lngIx <= g_lngFieldTypeMAX
            If g_tblFieldType(lngIx).ShowType = strType Then Exit Do
            lngIx = lngIx + 1
        Loop
        ' フィールドの作成
        If g_tblFieldType(lngIx).NeedSize Then
            ' フィールド名,タイプ,サイズを指定
            Set objFld = objTbl.CreateField(Trim(objSh.Cells(lngGyo, 5).Value), _
                                            g_tblFieldType(lngIx).TypeValue, _
                                            objSh.Cells(lngGyo, 13).Value)
        Else
            ' フィールド名,タイプを指定
            Set objFld = objTbl.CreateField(Trim(objSh.Cells(lngGyo, 5).Value), _
                                            g_tblFieldType(lngIx).TypeValue)
        End If
        ' オートナンバー型の設定
        If g_tblFieldType(lngIx).ShowType = g_cnsAutoNumber Then
            objFld.Attributes = dbAutoIncrField
        End If
        ' 値要求のセット
        If g_tblFieldType(lngIx).NeedValue Then
            If objSh.Cells(lngGyo, 14).Value = g_cnsYes Then
                objFld.Required = True
            Else
                objFld.Required = False
            End If
        End If
        ' 空文字許可のセット
        If g_tblFieldType(lngIx).NotBlank Then
            If objSh.Cells(lngGyo, 15).Value = g_cnsKyoka Then
                objFld.AllowZeroLength = True
            Else
                objFld.AllowZeroLength = False
            End If
        End If
        ' フィールドを追加
        objTbl.Fields.Append objFld
    Next lngGyo
    '-----------------------------------------------------------------------------------------------
    ' Pri-Key,Indexの生成
    For lngCol = 6 To 11
        ' Pri-Key,Indexの登録を確認
        lngIdxMAX = -1
        ReDim tblFieldId(0)
        ' ワークシートの行を巡回⇒INDEXテーブルを作成
        For lngGyo = 4 To lngGyoMax
            If objSh.Cells(lngGyo, lngCol).Value <> "" Then
                lngIdxNo = objSh.Cells(lngGyo, lngCol).Value
                If lngIdxNo > lngIdxMAX Then
                    lngIdxMAX = lngIdxNo
                    ReDim Preserve tblFieldId(lngIdxMAX)
                End If
                tblFieldId(lngIdxNo) = objSh.Cells(lngGyo, 5).Value
            End If
        Next lngGyo
        ' INDEXがあるか
        If lngIdxMAX >= 1 Then
            ' Pri-Key,Indexを追加
            Set objIdx = objTbl.CreateIndex(vntKeyName(lngCol - 6))
            objIdx.Primary = vntPriKey(lngCol - 6)
            lngIx = 1
            Do While lngIx <= lngIdxMAX
                If tblFieldId(lngIx) <> "" Then
                    ' Indexにフィールドを追加
                    objIdx.Fields.Append objIdx.CreateField(tblFieldId(lngIx))
                End If
                lngIx = lngIx + 1
            Loop
            ' Pri-Key,Indexを追加
            objTbl.Indexes.Append objIdx
        End If
    Next lngCol
    ' テーブルを追加
    objMdb.TableDefs.Append objTbl
End Sub

'***************************************************************************************************
'* 処理名 :GP_ADD_Setsumei
'* 機能  :テーブル説明等の追加(サブ処理)
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数  :Arg1 = 対象MDB(DAO.Database)
'*      Arg2 = 対象シート(Excel.Worksheet)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2012年11月23日
'* 作成者 :井上 治
'* 更新日 :2016年12月04日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub GP_ADD_Setsumei(ByRef objMdb As DAO.Database, ByRef objSh As Worksheet)
    '-----------------------------------------------------------------------------------------------
    Dim objTbl As DAO.TableDef                                      ' DAO.TableDef
    Dim objFld As DAO.Field                                         ' DAO.Field
    Dim objPpt As DAO.Property                                      ' DAO.Property
    Dim lngGyo As Long                                              ' 行INDEX
    Dim lngGyoMax As Long                                           ' 最終行INDEX
    Dim lngCol As Long                                              ' カラムINDEX
    Dim lngCol2 As Long                                             ' カラムINDEX
    Dim tblSetsumei(2 To 4) As String
    Dim strSetsumei As String                                       ' 項目名(日本語)

    ' 追加したテーブルを取り直す
    Erase tblSetsumei
    lngGyoMax = objSh.Range("$E$" & objSh.Rows.Count).End(xlUp).Row
    Set objTbl = objMdb.TableDefs(Trim(objSh.Cells(2, 3).Value))
    '-----------------------------------------------------------------------------------------------
    ' ワークシートの行を巡回
    For lngGyo = 4 To lngGyoMax
        ' 項目名称列を巡回
        For lngCol = 2 To 4
            ' ブランク以外
            If objSh.Cells(lngGyo, lngCol).Value <> "" Then
                ' 行範囲セル接続の対応
                tblSetsumei(lngCol) = Replace(objSh.Cells(lngGyo, lngCol).Value, vbLf, "")
                lngCol2 = lngCol + 1
                ' 下位列を一旦消去
                Do While lngCol2 <= 4
                    tblSetsumei(lngCol2) = ""
                    lngCol2 = lngCol2 + 1
                Loop
            End If
        Next lngCol
        strSetsumei = ""
        ' 項目名(日本語)をセット
        For lngCol = 2 To 4
            If tblSetsumei(lngCol) <> "" Then
                ' カンマで挟む
                If strSetsumei <> "" Then
                    strSetsumei = strSetsumei & g_cnsCOM
                End If
                strSetsumei = strSetsumei & tblSetsumei(lngCol)
            End If
        Next lngCol
        ' 項目説明を追加
        If objSh.Cells(lngGyo, 16).Value <> "" Then
            ' カンマで挟む
            If strSetsumei <> "" Then
                strSetsumei = strSetsumei & g_cnsCOM
            End If
            strSetsumei = strSetsumei & objSh.Cells(lngGyo, 16).Value
        End If
        ' 項目名称等をDescriptionにセット
        If strSetsumei <> "" Then
            Set objFld = objTbl.Fields(Trim(objSh.Cells(lngGyo, 5).Value))
            Set objPpt = objFld.CreateProperty(g_cnsDescription, dbText, strSetsumei)
            objFld.Properties.Append objPpt
        End If
    Next lngGyo
    '-----------------------------------------------------------------------------------------------
    ' テーブル名、説明のセット(最初の改行以降が説明)
    If ((objSh.Cells(1, 3).Value <> "") Or (objSh.Cells(1, 13).Value <> "")) Then
        strSetsumei = objSh.Cells(1, 3).Value & vbCrLf & _
                      Replace(objSh.Cells(1, 13).Value, vbLf, vbCrLf)
        Set objPpt = objTbl.CreateProperty(g_cnsDescription, dbText, strSetsumei)
        objTbl.Properties.Append objPpt
    End If
End Sub

'***************************************************************************************************
'* 処理名 :GP_SetDataTypeTable
'* 機能  :項目属性テーブル作成
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数  :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2012年11月23日
'* 作成者 :井上 治
'* 更新日 :2016年12月04日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub GP_SetDataTypeTable()
    '-----------------------------------------------------------------------------------------------
    Dim lngIx As Long                                               ' テーブルINDEX
    Dim lngGyo As Long                                              ' 行INGEX
    Dim objSh0 As Worksheet                                         ' 「設定」シート
    Set objSh0 = ThisWorkbook.Worksheets(g_cnsSH0)                  ' 設定
    g_lngIxAutoNumber = -1
    lngIx = -1
    lngGyo = 2
    ReDim g_tblFieldType(0)
    With objSh0
        If .FilterMode Then .ShowAllData
        ' 登録を巡回
        Do While lngGyo <= .Range("$A$" & .Rows.Count).End(xlUp).Row
            lngIx = lngIx + 1
            ReDim Preserve g_tblFieldType(lngIx)
            g_tblFieldType(lngIx).Gyo = lngGyo                      ' 行INDEX
            g_tblFieldType(lngIx).ShowType = .Cells(lngGyo, 1).Value  ' 表示タイプ
            g_tblFieldType(lngIx).NeedSize = .Cells(lngGyo, 2).Value = g_cnsMaru  ' サイズ要求
            g_tblFieldType(lngIx).AsNumeric = .Cells(lngGyo, 3).Value = g_cnsMaru ' 数値タイプ
            g_tblFieldType(lngIx).NeedValue = .Cells(lngGyo, 4).Value <> g_cnsBatsu   ' 値要求
            g_tblFieldType(lngIx).NotBlank = .Cells(lngGyo, 5).Value <> g_cnsBatsu    ' 空文字不可
            g_tblFieldType(lngIx).Memo = .Cells(lngGyo, 6).Value      ' メモ
            g_tblFieldType(lngIx).TypeString = .Cells(lngGyo, 7).Value ' タイプ文字列
            g_tblFieldType(lngIx).TypeValue = .Cells(lngGyo, 8).Value ' タイプ値
            ' 自動ナンバー位置の取得
            If g_tblFieldType(lngIx).ShowType = g_cnsAutoNumber Then
                g_lngIxAutoNumber = lngIx
            End If
            ' 次の行へ
            lngGyo = lngGyo + 1
        Loop
    End With
    g_lngFieldTypeMAX = lngIx
End Sub

以下は上記の「MDBファイルの生成」の初段階で呼び出されるワークシート上の「登録内容の検査」です。
問題がある場合はこちらの処理内でエラーメッセージが表示されて処理結果にFalseが返るので、 「MDBファイルの生成」に戻った段階で終了してしまいます。
「登録内容の検査」は呼び出し処理が先頭の「FP_CheckSheet」ですが、 ここからワークシート単位に「1シート分の内容妥当性チェック(FP_CheckSheetSUB)」が呼び出されてワークシート単位の検査を行ないます。
さらに「1シート分の内容妥当性チェック(FP_CheckSheetSUB)」からは、 1行単位に「1行単位の内容妥当性チェック(FP_CheckSheetSUB2)」と、 「Pri-Key,Indexの重複チェック(FP_CheckSheetSUB3)」が呼び出される構造になっています。
最後の「エラーメッセージ編集①(シート名付加)」「エラーメッセージ編集②(シート名、行番号付加)」は エラーメッセージを改行付き集積させる共通処理ですが、そのエラーメッセージは引数の「strMsg」がすべてByRef参照になっていて 上位に戻されるようになっています。

'***************************************************************************************************
'* 処理名 :FP_CheckSheet
'* 機能  :登録内容の検査
'---------------------------------------------------------------------------------------------------
'* 返り値 :チェック成否(Boolean)
'* 引数  :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2012年11月23日
'* 作成者 :井上 治
'* 更新日 :2019年11月17日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Function FP_CheckSheet() As Boolean
    '-----------------------------------------------------------------------------------------------
    Const cnsTitle = "MDB(ACCDB)ファイルの生成(処理前チェック)"
    Dim objSh As Worksheet                                          ' ワークシート
    Dim lngTableIdMAX As Long                                       ' テーブルIDテーブルINDEX
    Dim tblTableID() As String                                      ' テーブルIDテーブル
    Dim strMsg As String                                            ' エラーメッセージ
    lngTableIdMAX = -1
    strMsg = ""
    ReDim tblTableID(0)
    ' ワークシートを巡回
    For Each objSh In ThisWorkbook.Worksheets
        ' 設定と原紙を除く
        If ((objSh.Name <> g_cnsSH0) And (objSh.Name <> g_cnsSH1)) Then
            ' シート単位チェック
            If FP_CheckSheetSUB(objSh, _
                                lngTableIdMAX, _
                                tblTableID, _
                                strMsg) <> True Then Exit For
        End If
    Next objSh
    '-----------------------------------------------------------------------------------------------
    ' チェック結果
    If strMsg <> "" Then
        MsgBox strMsg, vbExclamation, cnsTitle
        FP_CheckSheet = False
    Else
        FP_CheckSheet = True
    End If
End Function

'***************************************************************************************************
'* 処理名 :FP_CheckSheetSUB
'* 機能  :登録内容の検査(1シート分の内容妥当性チェック)
'---------------------------------------------------------------------------------------------------
'* 返り値 :チェック成否(Boolean)
'* 引数  :Arg1 = チェック対象シート(Excel.Worksheet)
'*      Arg2 = テーブルIDテーブルINDEX(Long)
'*      Arg3 = テーブルIDテーブル(Array:String)
'*      Arg4 = エラーメッセージ(String)                        ※戻り値
'---------------------------------------------------------------------------------------------------
'* 作成日 :2012年11月23日
'* 作成者 :井上 治
'* 更新日 :2016年12月04日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Function FP_CheckSheetSUB(ByRef objSh As Worksheet, _
                                  ByRef lngTableIdMAX As Long, _
                                  ByRef tblTableID() As String, _
                                  ByRef strMsg As String) As Boolean
    '-----------------------------------------------------------------------------------------------
    Dim strTableID As String                                        ' 今回テーブルID
    Dim tblFieldId() As String                                      ' フィールドID重複判定テーブル
    Dim lngFieldIdMAX As Long                                       ' フィールドID重複判定MAX
    Dim lngIx As Long                                               ' テーブルINDEX
    Dim strAddMsg As String                                         ' メッセージTEMP
    Dim lngGyo As Long                                              ' 行INDEX
    Dim lngGyoMax As Long                                           ' データ最終行

    FP_CheckSheetSUB = False
    With objSh
        strTableID = Trim(.Cells(2, 3).Value)                       ' テーブルID
        ' テーブルIDなし
        If strTableID = "" Then
            Call GP_CheckSheetError1("「テーブルID」が登録されていません。", .Name, strMsg)
            Exit Function
        End If
        lngIx = 0
        '-------------------------------------------------------------------------------------------
        ' テーブルIDの重複判定
        Do While lngIx <= lngTableIdMAX
            ' 既に登録されたテーブルIDか
            If tblTableID(lngIx) = strTableID Then
                strAddMsg = "テーブルID「" & strTableID & "」が重複しています。"
                Call GP_CheckSheetError1(strAddMsg, .Name, strMsg)
                Exit Function
            End If
            ' 次へ
            lngIx = lngIx + 1
        Loop
        ' テーブルに追加
        lngTableIdMAX = lngIx
        ReDim Preserve tblTableID(lngTableIdMAX)
        tblTableID(lngTableIdMAX) = strTableID
        '-------------------------------------------------------------------------------------------
        ' 最終行の取得
        If .FilterMode Then .ShowAllData
        lngGyoMax = .Range("$E$" & .Rows.Count).End(xlUp).Row       ' 最終行
        ' 未登録チェック
        If lngGyoMax < 4 Then
            Call GP_CheckSheetError1("フィールド定義がありません。", .Name, strMsg)
            Exit Function
        End If
    End With
    '-----------------------------------------------------------------------------------------------
    lngFieldIdMAX = -1
    ReDim tblFieldId(0)
    ' 各フィールドのチェック
    For lngGyo = 4 To lngGyoMax
        ' 登録内容の検査(1行単位の内容妥当性チェック)
        Call GP_CheckSheetSUB2(objSh, _
                               lngGyo, _
                               lngFieldIdMAX, _
                               tblFieldId, _
                               strMsg)
    Next lngGyo
    '-----------------------------------------------------------------------------------------------
    ' Pri-Key,Indexの重複チェック
    Call GP_CheckSheetSUB3(objSh, lngGyoMax, strMsg)
    ' チェックOK
    FP_CheckSheetSUB = True
End Function

'***************************************************************************************************
'* 処理名 :GP_CheckSheetSUB2
'* 機能  :登録内容の検査(1行単位の内容妥当性チェック)
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数  :Arg1 = チェック対象シート(Excel.Worksheet)
'*      Arg2 = 行INDEX(Long)
'*      Arg3 = フィールドID重複判定テーブル最大INDEX(Long)
'*      Arg4 = フィールドID重複判定テーブル(Array:String)
'*      Arg5 = エラーメッセージ(String)                        ※戻り値
'---------------------------------------------------------------------------------------------------
'* 作成日 :2016年12月04日
'* 作成者 :井上 治
'* 更新日 :2016年12月05日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub GP_CheckSheetSUB2(ByRef objSh As Worksheet, _
                              ByVal lngGyo As Long, _
                              ByRef lngFieldIdMAX As Long, _
                              ByRef tblFieldId() As String, _
                              ByRef strMsg As String)
    '-----------------------------------------------------------------------------------------------
    Dim lngCol As Long                                              ' カラムINDEX
    Dim lngIx As Long                                               ' テーブルINDEX
    Dim strName As String                                           ' フィールド名
    Dim strType As String                                           ' 項目タイプ
    Dim strAddMsg As String                                         ' メッセージTEMP
    With objSh
        '-------------------------------------------------------
        ' 項目名称
        For lngCol = 2 To 4
            ' カンマが含まれるか
            If InStr(1, .Cells(lngGyo, lngCol).Value, g_cnsCOM, vbTextCompare) <> 0 Then
                strAddMsg = "「項目名称」にカンマは使えません。"
                Call GP_CheckSheetError2(strAddMsg, .Name, lngGyo, strMsg)
            End If
        Next lngCol
        '-------------------------------------------------------
        ' フィールドID
        strName = Trim(.Cells(lngGyo, 5).Value)
        ' フィールドID未入力か
        If strName = "" Then
            strAddMsg = "「フィールドID」が未入力です。"
            Call GP_CheckSheetError2(strAddMsg, .Name, lngGyo, strMsg)
        Else
            lngIx = 0
            ' テーブルID重複判定テーブルを巡回
            Do While lngIx <= lngFieldIdMAX
                If tblFieldId(lngIx) = strName Then Exit Do
                lngIx = lngIx + 1
            Loop
            ' 重複か
            If lngIx <= lngFieldIdMAX Then
                strAddMsg = "フィールドID「" & strName & "」が重複しています。"
                Call GP_CheckSheetError2(strAddMsg, .Name, lngGyo, strMsg)
            Else
                ' テーブルID重複判定テーブルに追加
                lngFieldIdMAX = lngFieldIdMAX + 1
                ReDim Preserve tblFieldId(lngFieldIdMAX)
                tblFieldId(lngFieldIdMAX) = strName
            End If
        End If
        '-------------------------------------------------------
        ' フィールドタイプ(属性)
        strType = Trim(.Cells(lngGyo, 12).Value)
        ' タイプ未入力か
        If strType = "" Then
            strAddMsg = "「属性」が未入力です。"
            Call GP_CheckSheetError2(strAddMsg, .Name, lngGyo, strMsg)
        Else
            lngIx = 0
            ' 項目属性テーブルを巡回
            Do While lngIx <= g_lngFieldTypeMAX
                If g_tblFieldType(lngIx).ShowType = strType Then Exit Do
                lngIx = lngIx + 1
            Loop
            ' 属性範囲外
            If lngIx > g_lngFieldTypeMAX Then
                strAddMsg = "「属性」が範囲外の値です。"
                Call GP_CheckSheetError2(strAddMsg, .Name, lngGyo, strMsg)
            Else
                ' サイズ
                If g_tblFieldType(lngIx).NeedSize Then
                    If .Cells(lngGyo, 13).Value = "" Then
                        strAddMsg = "「サイズ」が未入力です。"
                        Call GP_CheckSheetError2(strAddMsg, .Name, lngGyo, strMsg)
                    ElseIf Not IsNumeric(.Cells(lngGyo, 13).Value) Then
                        strAddMsg = "「サイズ」が数値ではありません。"
                        Call GP_CheckSheetError2(strAddMsg, .Name, lngGyo, strMsg)
                    ElseIf .Cells(lngGyo, 13).Value < 1 Then
                        strAddMsg = "「サイズ」が範囲外の値です。"
                        Call GP_CheckSheetError2(strAddMsg, .Name, lngGyo, strMsg)
                    End If
                End If
                ' 値要求
                If g_tblFieldType(lngIx).NeedValue Then
                    If ((.Cells(lngGyo, 14).Value = "") Or _
                        (.Cells(lngGyo, 14).Value = g_cnsNA)) Then
                        strAddMsg = "「値要求」が指定されていません。"
                        Call GP_CheckSheetError2(strAddMsg, .Name, lngGyo, strMsg)
                    End If
                End If
                ' 空文字許可
                If g_tblFieldType(lngIx).NotBlank Then
                    If ((.Cells(lngGyo, 15).Value = "") Or _
                        (.Cells(lngGyo, 15).Value = g_cnsNA)) Then
                        strAddMsg = "「空文字」が指定されていません。"
                        Call GP_CheckSheetError2(strAddMsg, .Name, lngGyo, strMsg)
                    End If
                End If
            End If
        End If
    End With
End Sub

'***************************************************************************************************
'* 処理名 :GP_CheckSheetSUB3
'* 機能  :登録内容の検査(Pri-Key,Indexの重複チェック)
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数  :Arg1 = チェック対象シート(Excel.Worksheet)
'*      Arg2 = 最終行INDEX(Long)
'*      Arg3 = エラーメッセージ(String)                        ※戻り値
'---------------------------------------------------------------------------------------------------
'* 作成日 :2016年12月04日
'* 作成者 :井上 治
'* 更新日 :2016年12月04日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub GP_CheckSheetSUB3(ByRef objSh As Worksheet, _
                              ByRef lngGyoMax As Long, _
                              ByRef strMsg As String)
    '-----------------------------------------------------------------------------------------------
    Dim lngIx As Long                                               ' テーブルINDEX
    Dim lngIdxMAX As Long                                           ' INDEXテーブル最大INDEX
    Dim lngGyo As Long                                              ' 行INDEX
    Dim lngCol As Long                                              ' カラムINDEX
    Dim lngIdxNo As Long                                            ' INDEXナンバー
    Dim strAddMsg As String                                         ' メッセージTEMP
    Dim strKeyName As String                                        ' キーフィールドID(表示)
    Dim vntKeyName As Variant                                       ' キーフィールドIDテーブル
    Dim tblIDX() As Long                                            ' INDEXテーブル
    vntKeyName = Array("Pri-Key", "Index①", "Index②", "Index③", "Index④", "Index⑤")
    With objSh
        ' Pri-Key,Index列を巡回
        For lngCol = 6 To 11
            ' Pri-Key,Index列単位処理
            strKeyName = "「" & vntKeyName(lngCol - 6) & "」"
            ' INDEXテーブルを初期化
            lngIdxMAX = -1
            ReDim tblIDX(0)
            ' 登録行を巡回
            For lngGyo = 4 To lngGyoMax
                ' ブランク行を除く
                If .Cells(lngGyo, lngCol).Value <> "" Then
                    ' 非数値か
                    If Not IsNumeric(.Cells(lngGyo, lngCol).Value) Then
                        strAddMsg = strKeyName & "が数字ではありません。"
                        Call GP_CheckSheetError2(strAddMsg, .Name, lngGyo, strMsg)
                    ElseIf .Cells(lngGyo, lngCol).Value < 0 Then
                        ' マイナス値
                        strAddMsg = strKeyName & "が範囲外の値です。"
                        Call GP_CheckSheetError2(strAddMsg, .Name, lngGyo, strMsg)
                    ElseIf .Cells(lngGyo, lngCol).Value > 0 Then
                        ' ゼロ以外は重複チェックへ
                        lngIdxNo = .Cells(lngGyo, lngCol).Value
                        ' 新たなINDEXか
                        If lngIdxNo > lngIdxMAX Then
                            ' 要素を追加
                            lngIdxMAX = lngIdxNo
                            ReDim Preserve tblIDX(lngIdxMAX)
                            tblIDX(lngIdxMAX) = lngIdxNo
                        ElseIf tblIDX(lngIdxNo) = 0 Then
                            ' 未使用INDEXは番号をセット
                            tblIDX(lngIdxNo) = lngIdxNo
                        Else
                            ' 重複
                            strAddMsg = strKeyName & "同一レベル番号が重複しています。"
                            Call GP_CheckSheetError2(strAddMsg, .Name, lngGyo, strMsg)
                        End If
                    End If
                End If
            Next lngGyo
            ' INDEXテーブルが登録されたか
            If lngIdxMAX >= 1 Then
                ' INDEXテーブルを巡回
                For lngIx = 1 To lngIdxMAX
                    If tblIDX(lngIx) = 0 Then
                        strAddMsg = strKeyName & "レベル番号が欠落しています。:" & lngIx
                        Call GP_CheckSheetError1(strAddMsg, .Name, strMsg)
                    End If
                Next lngIx
            End If
        Next lngCol
    End With
End Sub

'***************************************************************************************************
'* 処理名 :GP_CheckSheetError1
'* 機能  :エラーメッセージ編集①(シート名付加)
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数  :Arg1 = 今回エラーメッセージ(String)
'*      Arg2 = シート名(String)
'*      Arg3 = エラーメッセージ累積(String)                    ※戻り値
'---------------------------------------------------------------------------------------------------
'* 作成日 :2016年12月04日
'* 作成者 :井上 治
'* 更新日 :2016年12月04日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub GP_CheckSheetError1(ByVal strAddMsg As String, _
                                ByVal strSheetName As String, _
                                ByRef strMsg As String)
    '-----------------------------------------------------------------------------------------------
    strAddMsg = strAddMsg & "(シート名:" & strSheetName & ")"
    ' エラーメッセージ累積
    Call GP_AppendMessage(strAddMsg, strMsg)
End Sub

'***************************************************************************************************
'* 処理名 :GP_CheckSheetError2
'* 機能  :エラーメッセージ編集②(シート名、行番号付加)
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数  :Arg1 = 今回エラーメッセージ(String)
'*      Arg2 = シート名(String)
'*      Arg3 = 行番号(Long)
'*      Arg4 = エラーメッセージ累積(String)                    ※戻り値
'---------------------------------------------------------------------------------------------------
'* 作成日 :2016年12月04日
'* 作成者 :井上 治
'* 更新日 :2016年12月04日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub GP_CheckSheetError2(ByVal strAddMsg As String, _
                                ByVal strSheetName As String, _
                                ByVal lngGyo As Long, _
                                ByRef strMsg As String)
    '-----------------------------------------------------------------------------------------------
    Dim strAddMsg2 As String                                        ' メッセージWORK
    strAddMsg2 = lngGyo & "行目、" & strAddMsg & "(シート名:" & strSheetName & ")"
    ' エラーメッセージ累積
    Call GP_AppendMessage(strAddMsg2, strMsg)
End Sub

以下は共通処理で他のモジュールにも実装しているものです。

'***************************************************************************************************
'  ■■■ 共通サブ処理(Private) ■■■
'***************************************************************************************************
'* 処理名 :FP_GetMdbFilename
'* 機能  :MDB(ACCDB)ファイル名受け取り
'---------------------------------------------------------------------------------------------------
'* 返り値 :処理成否(Boolean)                          ※キャンセルはFalseが返る
'* 引数  :Arg1 = 処理モード(Integer)                 ※0=OpenFilename, 1=SaveAsFilename
'*      Arg2 = ダイアログタイトル(String)
'*      Arg3 = 受け取ったファイル名(String)        ※Ref参照
'*      Arg4 = 初期フォルダ名(String)             ※Option
'*      Arg5 = 初期ファイル名(String)             ※Option(SaveAsFilename時)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2019年11月17日
'* 作成者 :井上 治
'* 更新日 :2019年11月25日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Function FP_GetMdbFilename(ByVal intMode As Integer, _
                                   ByVal strCaption As String, _
                                   ByRef strFilename As String, _
                                   Optional ByVal strPathname As String = "", _
                                   Optional ByVal strFilename2 As String = "") As Boolean
    '-----------------------------------------------------------------------------------------------
    Dim objWsh As WshShell                                          ' WshShell
    Dim strCurrentPathSV As String                                  ' カレントフォルダ(退避)
    Dim vntFileName As Variant                                      ' ファイル名(受取)
    Set objWsh = New WshShell                                       ' WshShell
    ' 初期フォルダ指定がなければ自ブックフォルダ
    If strPathname = "" And ThisWorkbook.Path <> "" Then
        strPathname = ThisWorkbook.Path
    End If
    On Error Resume Next
    strCurrentPathSV = objWsh.CurrentDirectory
    ' 一旦、カレントフォルダを変更
    If strPathname <> "" Then
        objWsh.CurrentDirectory = strPathname
    End If
    On Error GoTo 0
    ' MDB(ACCDB)ファイル名の受け取り
    If intMode <> 0 Then
        ' GetSaveAsFilename
        vntFileName = Application.GetSaveAsFilename(strFilename2, g_cnsFilterC, , strCaption)
    Else
        ' GetOpenFilename
        vntFileName = Application.GetOpenFilename(g_cnsFilterR, , strCaption)
    End If
    ' カレントフォルダの復旧
    If strCurrentPathSV <> "" Then
        On Error Resume Next
        objWsh.CurrentDirectory = strCurrentPathSV
        On Error GoTo 0
    End If
    Set objWsh = Nothing
    ' キャンセル確認
    If VarType(vntFileName) = vbBoolean Then
        FP_GetMdbFilename = False
    Else
        strFilename = vntFileName
        FP_GetMdbFilename = True
    End If
End Function

'***************************************************************************************************
'* 処理名 :FP_CheckMdbFilename
'* 機能  :MDB(ACCDB)ファイル名チェック
'---------------------------------------------------------------------------------------------------
'* 返り値 :チェック成否(Boolean)
'* 引数  :Arg1 = 処理タイトル(String)
'*      Arg2 = 処理モード(Integer)                 ※0=OpenFilename, 1=SaveAsFilename
'*      Arg3 = ファイル名(String)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2019年11月17日
'* 作成者 :井上 治
'* 更新日 :2019年11月17日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Function FP_CheckMdbFilename(ByVal strTitle As String, _
                                     ByVal intMode As Integer, _
                                     ByVal strFilename As String) As Boolean
    '-----------------------------------------------------------------------------------------------
    Dim objFso As FileSystemObject                                  ' FileSystemObject
    Dim objMsgIcon As VbMsgBoxStyle                                 ' メッセージアイコン
    Dim strExtU As String                                           ' 拡張子(大文字)
    Dim strErrMSG As String                                         ' エラーメッセージ
    On Error GoTo CheckMdbFilename_ERROR
    Set objFso = New FileSystemObject
    objMsgIcon = vbExclamation
    ' ファイル存在チェック(OpenFilename時)
    If intMode = 0 Then
        ' 存在しなければエラー
        If Not objFso.FileExists(strFilename) Then
            strErrMSG = "指定のファイルが存在しません。" & vbCr & strFilename
        End If
    End If
    strExtU = UCase(objFso.GetExtensionName(strFilename))
    ' 拡張子判定
    If ((strExtU <> "MDB") And (strExtU <> "ACCDB")) Then
        strErrMSG = "指定のファイルはMDB(ACCDB)ではありません。" & vbCr & strFilename
    End If
    GoTo CheckMdbFilename_EXIT
'===================================================================================================
' エラー処理
CheckMdbFilename_ERROR:
    strErrMSG = Err.Description
    objMsgIcon = vbCritical
'===================================================================================================
' 終了
CheckMdbFilename_EXIT:
    ' エラーがあるか
    If strErrMSG <> "" Then
        MsgBox strErrMSG, objMsgIcon, strTitle
    End If
    FP_CheckMdbFilename = strErrMSG = ""
    On Error GoTo 0
    Set objFso = Nothing
End Function

'***************************************************************************************************
'* 処理名 :FP_GetResourceNameFromLocalDrive
'* 機能  :ネットワークドライブシンボルからネットワークリソースを取得
'---------------------------------------------------------------------------------------------------
'* 返り値 :UNCパス(String)
'* 引数  :Arg1 = ドライブを含む文字列(String)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2012年11月23日
'* 作成者 :井上 治
'* 更新日 :2012年11月23日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Function FP_GetResourceNameFromLocalDrive(strDrv As String) As String
    '-----------------------------------------------------------------------------------------------
    Dim strBuf As String                                            ' API用文字列バッファ
    Dim strDriveName As String                                      ' ドライブシンボル
    Dim lngLen As Long                                              ' 文字列長

    strDriveName = Left$(strDrv, 1) & ":"
    On Error GoTo GetResourceNameFromLocalDrive_ERROR
    strBuf = String$(MAX_PATH + 1, vbNullChar)
    WNetGetConnection strDriveName, strBuf, MAX_PATH
    '取得したパス名から必要な文字列だけを抽出
    lngLen = InStr(1, strBuf, vbNullChar)
    ' 取得できたか
    If lngLen > 1 Then
        FP_GetResourceNameFromLocalDrive = Left$(strBuf, lngLen - 1)
    Else
        FP_GetResourceNameFromLocalDrive = strDriveName
    End If
    On Error GoTo 0
    Exit Function

'---------------------------------------------------------------------------------------------------
GetResourceNameFromLocalDrive_ERROR:
    FP_GetResourceNameFromLocalDrive = strDriveName
    On Error GoTo 0
End Function

'***************************************************************************************************
'* 処理名 :GP_StopScreen
'* 機能  :画面描画停止
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数  :Arg1 = ステータスバーガイド(String)                    ※Option
'*      Arg2 = マウスカーソル指定(Boolean)                     ※Option
'---------------------------------------------------------------------------------------------------
'* 作成日 :2012年11月23日
'* 作成者 :井上 治
'* 更新日 :2016年12月04日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub GP_StopScreen(Optional strGUIDE As String = "", _
                          Optional swOmitWait As Boolean = False)
    '-----------------------------------------------------------------------------------------------
    With Application
        .ScreenUpdating = False                                     ' 画面描画停止
        .Calculation = xlCalculationManual                          ' 自動計算停止
        ' ガイド指定
        If strGUIDE <> "" Then .StatusBar = strGUIDE                ' ステータスバー
        ' マウスカーソル指定
        If swOmitWait <> True Then .Cursor = xlWait                 ' マウスカーソル(砂時計)
        .EnableEvents = False                                       ' イベントを抑制
    End With
End Sub

'***************************************************************************************************
'* 処理名 :GP_StartScreen
'* 機能  :画面描画再開
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数  :Arg1 = ステータスバーガイド(String)                    ※Option
'---------------------------------------------------------------------------------------------------
'* 作成日 :2012年11月23日
'* 作成者 :井上 治
'* 更新日 :2016年12月04日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub GP_StartScreen(Optional ByVal strGUIDE As String = "")
    '-----------------------------------------------------------------------------------------------
    With Application
        ' 自動計算再開
        If .Calculation <> xlCalculationAutomatic Then
            .Calculation = xlCalculationAutomatic                   ' 自動計算開始
        End If
        .Cursor = xlDefault                                         ' マウスカーソル(標準)
        ' ガイド指定
        If strGUIDE <> "" Then
            .StatusBar = strGUIDE                                   ' ステータスバー
        Else
            .StatusBar = False
        End If
        .EnableEvents = True                                        ' イベント抑制解除
        .ScreenUpdating = True                                      ' 画面描画復旧
    End With
End Sub

'***************************************************************************************************
'* 処理名 :GP_AppendMessage
'* 機能  :エラーメッセージ累積
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数  :Arg1 = 今回追加メッセージ(String)
'*      Arg2 = 表示用累積メッセージ(String)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2016年12月04日
'* 作成者 :井上 治
'* 更新日 :2016年12月04日
'* 更新者 :井上 治
'* 機能説明:改行を加えながらメッセージを追加する
'* 注意事項:
'***************************************************************************************************
Private Sub GP_AppendMessage(ByRef strAddMsg As String, ByRef strMsg As String)
    '-----------------------------------------------------------------------------------------------
    If strMsg <> "" Then strMsg = strMsg & vbCrLf
    strMsg = strMsg & strAddMsg
End Sub

'------------------------------------------<< End of Source >>--------------------------------------