VBAでメタプログラミング 動的にテスト関数を検索して実行する

2010/08/30
2012/11/12
 しめじ(smeghead)

VBAは、言語的には、VB6ベースの言語で、自由も無い言語ですが、エクセルを読んだり書いたりするような、ちょっとしたツールを作成するのには便利だったりする。でもさすがにVBなので、プログラミングしてるといろんなところで我慢しなければならないことが多い。


以前、ユニットテストモジュールみたいなものがあった方がいいかと思ったこともあったけど、引数の無いSubを定義して、カーソルがSubのところにある状態でF5を押すだけで、そのテストメソッドを実行することができるので、今はこの方法でテストメソッドを実行している。assert文は、Debug.Assertというのがあるが、これまた微妙なもので、引数がTrueになるときにはなにも起こらず、引数がFlaseになるときはデバッグモード(ブレイクポイントで止まった状態になる)になるだけ。テストの自動化は難しそうだけど、今はこれを使ってテストメソッドを書いてる。


メタプログラミング(風)

テストメソッドが増えてくると、纏めて実行したい。しかし、TestSuite用のメソッドを自分で作ってテストメソッドが増えたら、TestSuiteもメンテするというのは、辛い。そこで、test_で始まる引数も戻り値も無い関数一覧を実行するという仕組みを作ってみることにした。

モジュール・クラスのソースコードを取得してテストメソッドを検索する

最近の言語のように動的に、動的に定義されているメソッド一覧などを取得する機能は無さそうだったので、モジュールやクラスのソースコードを取得して、解析してtest_で始まる関数(Sub)を探すことにした。モジュールやクラスのソースコードを取得することができるというのも驚きだったけど、検索すると意外と多くヒットするので、これは良く知られていることなのかもしれない。

Function GetAllTestMethodNames() As Collection
  Dim testSubs As Collection
  Set testSubs = New Collection
  Dim m As Object
  For Each m In ThisWorkbook.VBProject.VBComponents
    Dim moduleName As String
    moduleName = m.name
    Dim codeModule As Object
    Set codeModule = m.codeModule
    If codeModule.CountOfLines > 1 Then
      Dim content As String
      content = codeModule.Lines(1, codeModule.CountOfLines)
      Dim line As Variant
      For Each line In Split(content, vbNewLine)
        Dim subIndex As Integer, parenIndex As Integer
        Dim subName As String
        subIndex = InStr(line, "Sub ")
        parenIndex = InStr(line, "(")
        If subIndex > 0 And parenIndex > subIndex Then
          subName = Mid(line, subIndex + Len("Sub "), parenIndex - (subIndex + Len("Sub ")))
          If Left(subName, Len("test_")) = "test_" Then
            Debug.Print "found." & subName
            Call testSubs.Add(moduleName & "." & subName)
          End If
        End If
      Next
    End If
  Next
  Set GetAllTestMethodNames = testSubs
End Function

これで、テストメソッドの一覧をコレクションで取得することができるようになった。

モジュールの作成・削除

次は、生成したTestSuiteを格納するメソッドを配置する場所を作成したり削除したりする関数を作成した。

Sub deleteModule1()
  On Error Resume Next
  Dim component As Object
  For Each component In ThisWorkbook.VBProject.VBComponents
    If component.Type = 1 And component.name = "Module1" Then
      Application.VBE.activeVBProject.VBComponents.Remove component
    End If
  Next component
End Sub
 
Sub addModule1()
  Application.VBE.activeVBProject.VBComponents.Add (1)
End Sub

本当は任意のモジュール名のモジュールを作成したり削除したりしたかったけど、モジュール名を変更する手段がわからなかったので、Module1という名前のモジュールを使うことにした。このコードを使おうとしてる変わった人がいるなら、Module1というモジュールが存在しないことを確認しないとModule1が消えてしまいます。

コードの動的追加

その次は、Module1に対して動的に、コードを追加するコード。

Sub DefineTestSuiteSub(testSubNames As Collection)
  Call deleteModule1
  Call addModule1
 
  Dim code As String
  code = "'--------------------------------------generated sub" & vbNewLine & _
  "Sub TestSuite()" & vbNewLine
 
  Dim s As Variant
  For Each s In testSubNames
    code = code & "   Call " & s & vbNewLine
  Next
 
  code = code & "End Sub"
  Call ThisWorkbook.VBProject.VBComponents.Item("Module1").codeModule.AddFromString(code)
End Sub
テスト実行

最後に今までのメソッドを呼び出して、自動生成したモジュールの関数を呼び出す。

Sub ExecuteAllTest()
  Dim testSubs As Collection
  Set testSubs = GetAllTestMethodNames
  Call DefineTestSuiteSub(testSubs)
  Call ExecTestSuite
End Sub
 
Sub ExecTestSuite()
  Call TestSuite
End Sub

ExecTestSuiteは、TestSuite(自動生成した関数)を呼び出すだけだが、ExecuteAllTestの内部で参照しようとすると、まだ存在しないのでエラーになる。それを回避するために、別関数に切り出した。VBAのコンパイルは関数単位にしか行なわれないらしい。


まとめ

やってることが汚なすぎてメタプログラミングとは呼べないけど、test_から始まる名前で定義されているメソッドを動的に実行することに成功した。基本、Debug.Assertを使ってるので、Assertエラーがある場合には、Assert文でプログラムが中断する。改善点はたくさんあるけど、改善はしないと思う。VBAって結構無茶しても速度的に問題が出ることがあるものの意外と落ちたりせずに、ちゃんと動いてくれるから、VBAすごいと思った。

TestUtility

TestUtilityモジュールの全体です。

Option Explicit
 
Sub ExecuteAllTest()
  Dim testSubs As Collection
  Set testSubs = GetAllTestMethodNames
  Call DefineTestSuiteSub(testSubs)
  Call ExecTestSuite
End Sub
 
Sub ExecTestSuite()
  Call TestSuite
End Sub
 
Sub DefineTestSuiteSub(testSubNames As Collection)
  Call deleteModule1
  Call addModule1
 
  Dim code As String
  code = "'--------------------------------------generated sub" & vbNewLine & _
  "Sub TestSuite()" & vbNewLine
 
  Dim s As Variant
  For Each s In testSubNames
    code = code & "   Call " & s & vbNewLine
  Next
 
  code = code & "End Sub"
  Call ThisWorkbook.VBProject.VBComponents.Item("Module1").codeModule.AddFromString(code)
End Sub
 
Function GetAllTestMethodNames() As Collection
  Dim testSubs As Collection
  Set testSubs = New Collection
 
  Dim m As Object
  For Each m In ThisWorkbook.VBProject.VBComponents
    Dim moduleName As String
    moduleName = m.name
    Dim codeModule As Object
    Set codeModule = m.codeModule
    If codeModule.CountOfLines > 1 Then
      Dim content As String
      content = codeModule.Lines(1, codeModule.CountOfLines)
      Dim line As Variant
      For Each line In Split(content, vbNewLine)
        Dim subIndex As Integer, parenIndex As Integer
        Dim subName As String
        subIndex = InStr(line, "Sub ")
        parenIndex = InStr(line, "(")
        If subIndex > 0 And parenIndex > subIndex Then
          subName = Mid(line, subIndex + Len("Sub "), parenIndex - (subIndex + Len("Sub ")))
          If Left(subName, Len("test_")) = "test_" Then
            Debug.Print "found." & subName
            Call testSubs.Add(moduleName & "." & subName)
          End If
        End If
      Next
    End If
  Next
  Set GetAllTestMethodNames = testSubs
End Function
 
Sub deleteModule1()
  On Error Resume Next
 
  Dim component As Object
  For Each component In ThisWorkbook.VBProject.VBComponents
    If component.Type = 1 And component.name = "Module1" Then
      Application.VBE.activeVBProject.VBComponents.Remove component
    End If
  Next component
End Sub
 
Sub addModule1()
  Application.VBE.activeVBProject.VBComponents.Add (1)
End Sub
しめじ(smeghead)
  • しめじ(smeghead)
vba

コメントする

メールアドレスが公開されることはありません。 ※ が付いている欄は必須項目です


reCaptcha の認証期間が終了しました。ページを再読み込みしてください。

このサイトはスパムを低減するために Akismet を使っています。コメントデータの処理方法の詳細はこちらをご覧ください。