作成済みのMDB(ACCDB)のテーブル定義内容をワークシート上に一覧表示します。
テーブルを作ってから「テーブル定義書」を作るようなものです。
本来は「データベース設計」なるものがあって、先に「テーブル定義書」を作成して、その「テーブル定義書」に従って実際のテーブルを作成するものです。
ですが、実際の運用場面では「設計」などは担当者の頭の中にあって、操作が簡単なこともあって先にテーブルを作ってしまって運用してしまうこともあるようです。 しかも後から機能拡張を繰り返し、当初の担当者も継続して担当しているとは限らないので、後から設計ドキョメントを見ても実体と合っているか分からない。
なんてことはありませんか？
このサンプルは「ダウンロード」の「MDB(ACCDB)生成／テーブル定義取得ツール」を利用しています。
ソースコードを変更することなく利用できるもので、「ダウンロード」の方ではコードの説明を行なっておりませんので、こちらで紹介します。 当初、このページにはADOXを使ったサンプルを掲載していたのですが、 ADOXではMDB(ACCDB)の全機能が設定できないことから、 DAOに変更したものです。
ですが、実際の運用場面では「設計」などは担当者の頭の中にあって、操作が簡単なこともあって先にテーブルを作ってしまって運用してしまうこともあるようです。 しかも後から機能拡張を繰り返し、当初の担当者も継続して担当しているとは限らないので、後から設計ドキョメントを見ても実体と合っているか分からない。
なんてことはありませんか？
このサンプルは「ダウンロード」の「MDB(ACCDB)生成／テーブル定義取得ツール」を利用しています。
ソースコードを変更することなく利用できるもので、「ダウンロード」の方ではコードの説明を行なっておりませんので、こちらで紹介します。 当初、このページにはADOXを使ったサンプルを掲載していたのですが、 ADOXではMDB(ACCDB)の全機能が設定できないことから、 DAOに変更したものです。
(画像をクリックすると、このページのサンプルがダウンロードできます)
これはダウンロードした「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: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からテーブル定義情報を取得
'---------------------------------------------------------------------------------------------------
'* 返り値 ：(なし)
'* 引数 ：(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 ：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 >>--------------------------------------