§３　　 ビジネステクノロジー活用講座

■AccessMDBのVBAソースコードを可視化/一覧化する

MSAccessで書かれたソースコードが100万ステップ、それほど気軽に開発できるのがAccessです。しかし、どれが生きているモジュールか、どれが 不要で削除してよいか簡単に判別できなくなることもよくあります。こんな時にはMDBの中に定義されたVBAソースを１つのExcelシート上にまとめれば、解析も容易。 あとはExcelの機能でVBAを可視化、解析が簡単にできます。
以下のような解析画面はその下に添付したVBAソースをそのまま使用すれば、すぐに実行し、作成できます。

☆動かない場合にはお気軽にお問い合わせください☆

Excelに取り込んで作成したAccessMDBのVBAソースファイル一覧

AccessMDBの中の全VBAソースコードを取込み、表示

Excelのフィルタ機能やVBAで作成した関数レベルの一覧表

【AccessMDBのVBA可視化プログラム・ソース】

'
'  ソースをExportするプログラムです。実行時に解析したいMDBを指定すれば、カレントフォルダに\sourceフォルダが作成され、そのフォルダ下にVBAソースがExportされます。
'
Option Explicit

Private Sub CommandButton1_Click()
Dim inFileName, fs, inFile, outPath, outFolderName
Dim accessObj, vbproject, vbcComp, ext, moduleName
 
inFileName = GetFilename("c:\")  '取り込むMDBを選択
outPath = ThisWorkbook.Path
 
Set fs = CreateObject("Scripting.FileSystemObject")
Set inFile = fs.GetFile(inFileName)
outPath = outPath & "\source"
 
' 出力フォルダが存在していれば消して作り直す
If fs.FolderExists(outPath) Then
    fs.DeleteFolder (outPath)
End If
fs.CreateFolder (outPath)
Set outFolderName = fs.GetFolder(outPath)
 
'mdbを開く
Set accessObj = CreateObject("Access.Application")
accessObj.OpenCurrentDatabase (inFileName)
 
' モジュールをテキスト化
Set vbproject = accessObj.VBE.ActiveVBProject
 
For Each vbcComp In vbproject.VBComponents
    Select Case vbcComp.Type
        Case 100, 1         'Module
            ext = ".bas"
        Case 2              'class
            ext = ".cls"
        Case 3              'Form
            ext = ".frm"
        Case Else
            ext = ""
   End Select

   moduleName = Replace(vbcComp.Name, "/", "_")
   vbcComp.Export (outFolderName.Path & "\" & moduleName & ext)
Next
accessObj.Application.Quit

MsgBox "完了しました"

End Sub

'ファイル選択
Function GetFilename(pathname) As String
Dim FN As String
With Application.FileDialog(msoFileDialogFilePicker)
  .InitialFileName = pathname
  If .Show = -1 Then
    FN = .SelectedItems(1)
  Else
    FN = ""
  End If
End With
GetFilename = FN
End Function


'
'  上記のExportデータを一括してExcelシートに読込み、関数一覧などを作成するVBAです。
'
Dim out_ctr As Long

'全ソース読込み
Private Sub CommandButton1_Click()
    Dim foldername As String
    Dim i As Long
    Dim x, y As String
    Dim buff As String
            
    out_ctr = 0
    Worksheets("Sheet1").Cells.ClearContents
    Worksheets("Sheet2").Cells.ClearContents
      
    foldername = GetFoldername("c:\")
    If foldername <> "" Then
      Call getFileList(foldername)
      
      out_ctr = 1
      i = 1
      Do Until Worksheets("Sheet1").Cells(i, 1) = ""
        x = Worksheets("sheet1").Cells(i, 2)
        j = InStrRev(x, ".")
        y = StrConv(Mid(x, j, 10), vbLowerCase)
        If y = ".bas" Or y = ".cls" Or y = ".frm" Then
          Open Worksheets("Sheet1").Cells(i, 1) & "\" & Worksheets("Sheet1").Cells(i, 2) For Input As #1
          num = 0
          Do Until EOF(1)
            Line Input #1, buff
            num = num + 1
            y = StrConv(buff, vbLowerCase)
            If InStr(1, y, "function ") > 0 And InStr(1, y, "end function") < 1 Or _
               InStr(1, y, "sub ") > 0 And (InStr(1, y, "end sub") < 1 Or InStr(1, y, "exit sub") < 1) Then

              Worksheets("Sheet2").Cells(out_ctr, 1) = Worksheets("sheet1").Cells(i, 1)
              Worksheets("Sheet2").Cells(out_ctr, 2) = Worksheets("sheet1").Cells(i, 2)
              Worksheets("Sheet2").Cells(out_ctr, 3) = buff
              Worksheets("Sheet2").Cells(out_ctr, 4) = num

              out_ctr = out_ctr + 1
            
            End If
            
          Loop
          Close #1
        End If
        i = i + 1
      Loop
    End If
    
End Sub

'ファイル一覧作成
Sub getFileList(DirPath As String)
    Dim buff As String, fl As Object
    buff = Dir(DirPath & "\*.*")
    Do While buff <> ""
        out_ctr = out_ctr + 1
        Cells(out_ctr, 1) = DirPath
        Cells(out_ctr, 2) = buff
        buff = Dir()
    Loop
    With CreateObject("Scripting.FileSystemObject")
        For Each fl In .GetFolder(DirPath).SubFolders
            Call getFileList(fl.Path)
        Next fl
    End With
End Sub

'フォルダ選択
Function GetFoldername(pathname) As String
Dim FN As String
With Application.FileDialog(msoFileDialogFolderPicker)
  .InitialFileName = pathname
  If .Show = -1 Then
    FN = .SelectedItems(1)
  Else
    FN = ""
  End If
End With
GetFoldername = FN
End Function

Excelシートに取り込めば、あとはExcelの検索やフィルタ機能、さらにはVBAを使えば本格的なプログラム解析まで簡単に可能です。 システムエンジニアの手作業に依存せず、エンジニアよりも安く、早く、正確に作業が可能です。ぜひお試しください。