Option Compare Database
Option Explicit
'--------------------------------------------------
'プロシージャの概要:
'処理名:prcExpVbaCodeLines
'概要:指定したExcelブック内のVBAモジュールを走査し、各コード行をAccessテーブル(t02a_Code)に出力する
'--------------------------------------------------
Public Sub prcExpVbaCodeLines()
Const C_FILE_PATH As String = _
"●" '解析対象ブックパス
Const C_TNAME_出力 As String = "t02a_Code"
Const STR_NOPRCNAME As String = "noPrcName"
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim xls As Excel.Application
Dim wbk As Excel.Workbook
Dim vbc As VBIDE.VBComponent
Dim vbiCode As VBIDE.CodeModule
Dim lngLineIndex As Long
Dim strModName As String
Dim strPrcName As String
Dim strFileName As String
Dim strLine As String
Dim lngPrcKind As Long
Dim strSQL As String
On Error GoTo ErrHandler
' ファイル名取得（パスから抽出）
strFileName = Mid(C_FILE_PATH, InStrRev(C_FILE_PATH, "\") + 1)
' ファイルが既に開いているかチェック
If fncBlnIsFileOpen(C_FILE_PATH) Then
MsgBox "対象ファイルが既に開かれています。" & vbCrLf & _
"ファイル名: " & strFileName & vbCrLf & vbCrLf & _
"ファイルを閉じてから再度実行してください。", _
vbExclamation, "処理中止"
Exit Sub
End If
' 現在DB取得
Set dbs = CurrentDb
' 出力テーブル初期化
strSQL = "DELETE * FROM " & C_TNAME_出力 & ";"
dbs.Execute strSQL, dbFailOnError
' オートナンバーを1にリセット
dbs.Execute "ALTER TABLE " & C_TNAME_出力 & " ALTER COLUMN LineID COUNTER(1,1);", dbFailOnError
' Excel起動（非表示）
Set xls = New Excel.Application
With xls
.Visible = True
.DisplayAlerts = False ' リンク更新等非表示
.AutomationSecurity = 3 ' マクロ自動実行を無効化
End With
' マクロ無効・リンク更新なしで開く
Set wbk = xls.Workbooks.Open( _
FileName:=C_FILE_PATH, _
UpdateLinks:=False, _
ReadOnly:=False, _
IgnoreReadOnlyRecommended:=True)
' 出力用テーブル開く
Set rst = dbs.OpenRecordset(C_TNAME_出力, dbOpenDynaset)
' 各モジュール処理実行
For Each vbc In wbk.VBProject.VBComponents
strModName = vbc.Name 'モジュール名
Set vbiCode = vbc.CodeModule
' コードモジュールを出力テーブル書き出し
For lngLineIndex = 1 To vbiCode.CountOfLines
strLine = vbiCode.Lines(lngLineIndex, 1) '（1行単位で抽出）
'エラーは"取得エラー"で取得
On Error Resume Next
strPrcName = vbiCode.ProcOfLine(lngLineIndex, lngPrcKind)
If Err.Number <> 0 Then
strPrcName = "取得エラー"
Err.Clear
End If
On Error GoTo ErrHandler
' プロシージャ名が存在しない場合
If strPrcName = "" Then strPrcName = STR_NOPRCNAME
'レコード追加
rst.AddNew
rst!ModuleName = strModName ' モジュール名
rst!ProcedureName = strPrcName ' プロシージャ名（取得できなければ"取得エラー"）
rst!CodeLine = strLine ' コード行
rst.Update
Next lngLineIndex
Next vbc
' 主要オブジェクト解放
Set rst = Nothing
wbk.Close False
Set wbk = Nothing
xls.Quit
Set xls = Nothing
' TrimCodeフィールド更新
strSQL = "UPDATE t02a_Code AS t02a SET t02a.TrimCode = Trim([CodeLine]);"
dbs.Execute strSQL
' TrimCodeテーブルへ追加
strSQL = "DELETE t.* FROM ｔ02b_TrimCode;"
dbs.Execute strSQL
strSQL = "INSERT INTO "
strSQL = strSQL & "t02b_TrimCode (ModName, PrcName, CodeLineID, TrimCode) "
strSQL = strSQL & "SELECT "
strSQL = strSQL & "t02a.ModuleName,t02a.ProcedureName,t02a.LineID,t02a.TrimCode "
strSQL = strSQL & "FROM t02a_Code As t02a "
strSQL = strSQL & "WHERE (((Nz ([CodeLine])) <> '')) "
strSQL = strSQL & "Order BY "
strSQL = strSQL & "t02a.ModuleName, t02a.ProcedureName,t02a.LineID;"
dbs.Execute strSQL
'DBオブジェクト開放
Set dbs = Nothing
' ステータスメーターのクリアと完了通知
prcUpdProgressMeter "", 0, 0
Debug.Print "処理終了：" & Now()
Exit Sub
ErrHandler:
Stop
' エラー発生時の処理
MsgBox "エラーが発生しました: " & Err.Description, vbExclamation
If Not wbk Is Nothing Then wbk.Close False
If Not xls Is Nothing Then xls.Quit
Set wbk = Nothing
Set xls = Nothing
Set rst = Nothing
Set dbs = Nothing
prcUpdProgressMeter "", 0, 0
End Sub
Excel