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