MDB(ACCDB)のテーブル定義内容を取得する。

作成済みのMDB(ACCDB)のテーブル定義内容をワークシート上に一覧表示します。
テーブルを作ってから「テーブル定義書」を作るようなものです。 本来は「データベース設計」なるものがあって、先に「テーブル定義書」を作成して、その「テーブル定義書」に従って実際のテーブルを作成するものです。
ですが、実際の運用場面では「設計」などは担当者の頭の中にあって、操作が簡単なこともあって先にテーブルを作ってしまって運用してしまうこともあるようです。 しかも後から機能拡張を繰り返し、当初の担当者も継続して担当しているとは限らないので、後から設計ドキョメントを見ても実体と合っているか分からない。
なんてことはありませんか?




このサンプルは「ダウンロード」のMDB(ACCDB)生成/テーブル定義取得ツール」を利用しています。
ソースコードを変更することなく利用できるもので、「ダウンロード」の方ではコードの説明を行なっておりませんので、こちらで紹介します。 当初、このページにはADOXを使ったサンプルを掲載していたのですが、 ADOXではMDB(ACCDB)の全機能が設定できないことから、 DAOに変更したものです。
サンプルをMDBACCDBの兼用版に変更しました。   従来は「MDB版」「ACCDB版」にワークブック自体が分かれていたのですが、統合手段が見つかったので、各ツールを「MDB(ACCDB)版」という形に変更しました。
※今回は64ビット版Officeでの動作確認も行ないました。
※既にサポート切れとなって年数経過したOffice2007以前のバージョンには対応していません。



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

これはダウンロードした「MDB(ACCDB)TableDefines1.zip」の中にある「MDB(ACCDB)テーブル定義.xltm」を開いたところです。
テンプレートはこのように「原紙」シートだけの状態になっていて「テーブル定義情報の取得」マクロを実行すると1テーブルが1シートになった「テーブル定義書」が作成されるというものです。

「テーブル定義情報の取得」の処理結果

同じく解凍されるサンプル「MDB(ACCDB)テーブル定義(テーブル操作サンプル).xltm」によりデータベースの生成ができるので、これで生成したデータベースを指定して取得するとこのようになります。

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

外部から呼び出されるプロシージャ「テーブル定義情報の取得」以外はすべて本処理内の「サブ処理(Private)」です。
「テーブル定義情報の取得」本体内ではまずMDB(ACCDB)ファイル名の取得及び接続が行なわれて、 続いて「項目属性テーブル作成(GP_SetDataTypeTable)」が呼び出されます。 ここまでが前処理です。
テーブル定義取得のメイン処理は「テーブル定義情報の取得」プロシージャの最後の方のテーブルを巡回する部分で1テーブル単位に「テーブル単位情報取得(GP_GetTableDefines)」が呼び出されます。

'***************************************************************************************************
'   MDB(ACCDB)テーブル定義取得/MDB(ACCDB)作成/テーブル追加処理
'
'   作成者:井上治  URL:http://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からテーブル定義情報を取得
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数  :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2012年11月23日
'* 作成者 :井上 治
'* 更新日 :2019年11月17日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Public Sub テーブル定義情報の取得()
    '-----------------------------------------------------------------------------------------------
    Const cnsTitle = "MDB(ACCDB)テーブル定義情報の取得"
    Dim objSh As Worksheet                                          ' ワークシート
    Dim objSh0 As Worksheet                                         ' ワークシート(設定)
    Dim objSh1 As Worksheet                                         ' ワークシート(原紙)
    Dim objMdb As DAO.Database                                      ' DAO.Database
    Dim objTbl As DAO.TableDef                                      ' DAO.TableDef
    Dim objFld As DAO.Field                                         ' DAO.Field
    Dim objIdx As DAO.Index                                         ' DAO.Index
    Dim objFso As FileSystemObject                                  ' FileSystemObject
    Dim objFile As File                                             ' File
    Dim objMsgIcon As VbMsgBoxStyle                                 ' メッセージアイコン
    Dim blnOpen As Boolean                                          ' Open判定
    Dim cntSh As Long                                               ' シート数
    Dim strFilename As String                                       ' ファイル名
    Dim strFilename2 As String                                      ' ファイル名(パス無)
    Dim strPathname As String                                       ' フォルダ名
    Dim strErrMSG As String                                         ' エラーメッセージ
    objMsgIcon = vbExclamation
    cntSh = ThisWorkbook.Worksheets.Count
    ' シート数チェック
    If cntSh > 2 Then
        strErrMSG = "本処理は「原紙」シートのみの状態で行なって下さい。"
        GoTo GetTableInfo_EXIT
    End If
    '-----------------------------------------------------------------------------------------------
    ' MDB(ACCDB)ファイル名の受け取り
    If Not FP_GetMdbFilename(0, _
                             "定義情報を取得するMDB(ACCDB)ファイルを指定して下さい。", _
                             strFilename) Then Exit Sub
    ' MDB(ACCDB)ファイル名チェック
    If Not FP_CheckMdbFilename(cnsTitle, 0, strFilename) Then Exit Sub
    '-----------------------------------------------------------------------------------------------
    On Error GoTo GetTableInfo_ERROR
    ' MDB(ACCDB)に接続
    Set objMdb = DBEngine.OpenDatabase(strFilename)
    blnOpen = True
    ' 画面描画停止
    Call GP_StopScreen
    ' 本ブックをアクティブに
    If ActiveWorkbook.Name <> ThisWorkbook.Name Then ThisWorkbook.Activate
    ' 原紙シートを取得
    Set objSh0 = ThisWorkbook.Worksheets(g_cnsSH0)                  ' 設定
    Set objSh1 = ThisWorkbook.Worksheets(g_cnsSH1)                  ' 原紙
    Set objFso = New FileSystemObject
    ' 設定シートにデータベース名を登録
    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
    objSh0.Cells(2, 16).Value = strFilename2                        ' 初期DB名
    objSh0.Cells(2, 17).Value = strPathname                         ' 初期フォルダ
    ' 項目属性テーブル作成
    Call GP_SetDataTypeTable
    ' 原紙シートを初期化(念のため!)
    With objSh1
        .Rows("4:" & .Rows.Count).ClearContents
        .Range("$C$1:$K$1,$C$2:$E$2,$M$1:$Q$2").ClearContents
    End With
    ' テーブルを順次取得
    For Each objTbl In objMdb.TableDefs
        ' テーブル単位情報取得
        Call GP_GetTableDefines(objTbl, ThisWorkbook, objSh1)
    Next objTbl
    GoTo GetTableInfo_EXIT
'===================================================================================================
' エラー処理
GetTableInfo_ERROR:
    strErrMSG = Err.Description
    objMsgIcon = vbCritical
'===================================================================================================
' 終了
GetTableInfo_EXIT:
    ' MDB(ACCDB)を切断
    If blnOpen Then objMdb.Close
    Set objMdb = Nothing
    ' 画面描画再開
    Call GP_StartScreen
    ' エラーがあるか
    If strErrMSG <> "" Then
        MsgBox strErrMSG, objMsgIcon, cnsTitle
    End If
    Set objFile = Nothing
    Set objFso = Nothing
    Set objSh1 = Nothing
    Set objSh0 = Nothing
    On Error GoTo 0
End Sub

'***************************************************************************************************
'  ■■■ サブ処理(Private) ■■■
'***************************************************************************************************
'* 処理名 :GP_GetTableDefines
'* 機能  :テーブル単位情報取得(サブ処理:テーブル単位)
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数  :Arg1 = 対象テーブル(objTbl As DAO.TableDef)
'*      Arg2 = 対象ワークブック(Excel.Workbook)
'*      Arg3 = 原紙シート(Excel.Worksheet)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2016年12月04日
'* 作成者 :井上 治
'* 更新日 :2017年01月08日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:シート上のエラーチェックが済んでいる前提
'***************************************************************************************************
Private Sub GP_GetTableDefines(ByRef objTbl As DAO.TableDef, _
                               ByRef objWbk As Workbook, _
                               ByRef objSh1 As Worksheet)
    '-----------------------------------------------------------------------------------------------
    Dim objFld As DAO.Field                                         ' DAO.Field
    Dim objIdx As DAO.Index                                         ' DAO.Index
    Dim objSh As Worksheet                                          ' ワークシート
    Dim strName As String                                           ' フィールド名
    Dim strSetsumei As String                                       ' 項目名(日本語)
    Dim vntSetsumei As Variant                                      ' 説明(配列)
    Dim lngIx As Long                                               ' テーブルINDEX
    Dim lngGyo As Long                                              ' 行INDEX
    Dim lngGyo1 As Long                                             ' 行INDEX
    Dim lngGyo2 As Long                                             ' 行INDEX
    Dim lngGyoMax As Long                                           ' 最終行INDEX
    Dim lngCol As Long                                              ' カラムINDEX
    Dim lngCol2 As Long                                             ' カラムINDEX
    Dim cntIdx As Long                                              ' INDEX件数
    Dim intType As Integer                                          ' フィールドタイプ

    strName = objTbl.Name
    If Left(strName, 4) <> "MSys" Then
        ' 原紙をコピーする
        objSh1.Copy After:=objWbk.Worksheets(objWbk.Worksheets.Count)
        Set objSh = ActiveSheet
        With objSh
            '-----------------------------------------------
            ' シート名にテーブル名をセット
            .Name = strName
            .Cells(2, 3).Value = strName
            On Error Resume Next
            strSetsumei = ""
            strSetsumei = objTbl.Properties(g_cnsDescription)       ' 説明
            ' エラー無視
            If Err.Number <> 0 Then Err.Clear
            On Error GoTo 0
            ' 説明テキストがある
            If strSetsumei <> "" Then
                ' 説明をテーブル名と説明に分ける
                lngIx = InStr(1, strSetsumei, vbCrLf, vbTextCompare)
                If lngIx <> 0 Then
                    .Cells(1, 3).Value = Left(strSetsumei, lngIx - 1)
                    .Cells(1, 13).Value = _
                        Replace(Mid(strSetsumei, lngIx + 2), vbCrLf, vbLf)
                Else
                    .Cells(1, 3).Value = strSetsumei
                End If
            End If
            '-----------------------------------------------
            lngGyo = 3
            ' テーブル内のフィールドを順次取得
            For Each objFld In objTbl.Fields
                lngGyo = lngGyo + 1
                .Cells(lngGyo, 1).FormulaR1C1 = "=ROW()-4"          ' (0起算)
                '-------------------------------------------
                On Error Resume Next
                strSetsumei = ""
                strSetsumei = objFld.Properties(g_cnsDescription)   ' 説明
                ' エラー無視
                If Err.Number <> 0 Then Err.Clear
                On Error GoTo 0
                ' 説明テキストがある
                If strSetsumei <> "" Then
                    vntSetsumei = Split(strSetsumei, g_cnsCOM, -1, vbTextCompare)
                    ' 配列取得ができた
                    If IsArray(vntSetsumei) Then
                        lngIx = 0
                        lngCol = 1
                        Do While lngIx <= UBound(vntSetsumei)
                            lngCol = lngCol + 1
                            .Cells(lngGyo, lngCol).Value = vntSetsumei(lngIx)
                            If lngCol >= 4 Then Exit Do
                            lngIx = lngIx + 1
                        Loop
                        If UBound(vntSetsumei) >= 3 Then
                            strSetsumei = ""
                            lngIx = 3
                            Do While lngIx <= UBound(vntSetsumei)
                                If strSetsumei <> "" Then
                                    strSetsumei = strSetsumei & g_cnsCOM
                                End If
                                strSetsumei = strSetsumei & vntSetsumei(lngIx)
                                lngIx = lngIx + 1
                            Loop
                            .Cells(lngGyo, 16).Value = strSetsumei
                        End If
                    Else
                        .Cells(lngGyo, 2).Value = strSetsumei
                    End If
                End If
                '-------------------------------------------
                .Cells(lngGyo, 5).Value = objFld.Name               ' フィールド名
                intType = objFld.Type
                ' 設定シートからフィールドのタイプを探す
                lngIx = 0
                ' 項目属性テーブルを巡回
                Do While lngIx <= g_lngFieldTypeMAX
                    If g_tblFieldType(lngIx).TypeValue = intType Then Exit Do
                    lngIx = lngIx + 1
                Loop
                ' 見つからない処置
                If lngIx > g_lngFieldTypeMAX Then
                    ' 本処理で対応できないタイプの場合
                    .Cells(lngGyo, 12).Value = "???(" & intType & ")"
                Else
                    ' 整数型か
                    If intType = 4 Then
                        ' 長整数型の場合はオートナンバーか判定で置換え
                        If objFld.Attributes = dbAutoIncrField Then lngIx = g_lngIxAutoNumber
                    End If
                    .Cells(lngGyo, 12).Value = g_tblFieldType(lngIx).ShowType
                    ' サイズ要求か
                    If g_tblFieldType(lngIx).NeedSize Then
                        .Cells(lngGyo, 13).Value = objFld.Size      ' サイズ
                    End If
                    ' 値要求か
                    If g_tblFieldType(lngIx).NeedValue Then
                        If objFld.Required Then
                            .Cells(lngGyo, 14).Value = g_cnsYes     ' 値要求
                        Else
                            .Cells(lngGyo, 14).Value = g_cnsNo
                        End If
                    Else
                        .Cells(lngGyo, 14).Value = g_cnsNA
                    End If
                    ' 空文字不可か
                    If g_tblFieldType(lngIx).NotBlank Then
                        If objFld.AllowZeroLength Then
                            .Cells(lngGyo, 15).Value = g_cnsKyoka   ' 空文字列
                        Else
                            .Cells(lngGyo, 15).Value = g_cnsFuka
                        End If
                    Else
                        .Cells(lngGyo, 15).Value = g_cnsNA
                    End If
                End If
            Next objFld
            lngGyoMax = lngGyo
            '-----------------------------------------------
            ' Indexをシートに展開
            lngCol2 = 6
            For Each objIdx In objTbl.Indexes
                ' プライマリキーは判定
                If objIdx.Primary = True Then
                    lngCol = 6
                Else
                    lngCol2 = lngCol2 + 1
                    lngCol = lngCol2
                    If lngCol > 11 Then Exit For                    ' 外部キーは5件まで
                End If
                ' インデックスのフィールドを探す
                cntIdx = 0
                For Each objFld In objIdx.Fields
                    strName = objFld.Name
                    cntIdx = cntIdx + 1
                    lngGyo = 4
                    Do While lngGyo <= lngGyoMax
                        If .Cells(lngGyo, 5).Value = strName Then
                            .Cells(lngGyo, lngCol).Value = cntIdx
                            Exit Do
                        End If
                        lngGyo = lngGyo + 1
                    Loop
                Next objFld
            Next objIdx
            '-----------------------------------------------
            ' 項目名称のセル処理(セル結合)
            ' 項目名称列を巡回
            For lngCol = 2 To 4
                lngGyo = 4
                ' 行を巡回
                Do While lngGyo <= lngGyoMax
                    ' 文字列があるか
                    If .Cells(lngGyo, lngCol).Value <> "" Then
                        lngGyo1 = lngGyo
                        lngGyo2 = lngGyo
                        lngGyo = lngGyo + 1
                        ' 行方向に同じ文字列のセルがあるか
                        Do While ((lngGyo <= lngGyoMax) And _
                                  (.Cells(lngGyo, lngCol).Value = .Cells(lngGyo1, lngCol).Value))
                            lngGyo2 = lngGyo
                            lngGyo = lngGyo + 1
                        Loop
                        ' 縦結合の判定
                        If lngGyo2 > lngGyo1 Then
                            ' 2行目以降をクリア
                            .Range(.Cells(lngGyo1 + 1, lngCol), .Cells(lngGyo2, lngCol)).ClearContents
                            ' 結合させて自動改行
                            With .Range(.Cells(lngGyo1, lngCol), .Cells(lngGyo2, lngCol))
                                .Merge
                                .WrapText = True
                            End With
                        ElseIf lngCol < 4 Then
                            lngCol2 = lngCol + 1
                            ' 単一行の場合は右側と結合させるか判定
                            Do While lngCol2 <= 4
                                If .Cells(lngGyo1, lngCol2).Value <> "" Then Exit Do
                                lngCol2 = lngCol2 + 1
                            Loop
                            If lngCol2 > 4 Then
                                With .Range(.Cells(lngGyo1, lngCol), .Cells(lngGyo1, 4))
                                    .Merge
                                    .WrapText = False
                                End With
                            End If
                        End If
                    Else
                        ' 次の行へ
                        lngGyo = lngGyo + 1
                    End If
                Loop
            Next lngCol
        End With
    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

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

'***************************************************************************************************
'  ■■■ 共通サブ処理(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

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