VBA的Automagic测试框架

在@RubberDuck的建议的基础上，我现在发现了一些漂亮的东西。我确定还有两件事需要完善-这个网站是要用任何好的代码制作出出色的代码，对吗？

此代码需要对Visual Basic Project的可信编程访问。

1。客户端代码

我希望我的测试类看起来像这样：

TestClass1类模块（客户端代码）

Option Explicit

Public Sub ThisIsNoTest()
    Err.Raise 5
End Sub

'@TestMethod
Public Sub MagicCommentWorks()
End Sub


Public Sub TestAreEqual()
    assert.AreEqual 12, 12, "Values should be equal."
End Sub

Public Sub TestAreNotEqual()
    assert.AreNotEqual 12, 34, "Values should not be equal."
End Sub

Public Sub TestAreSame()
    assert.AreSame New Collection, New Collection, "Objects should be same reference."
End Sub

Public Sub TestAreNotSame()
    assert.AreNotSame New Collection, New Collection, "Objects should not be the same reference."
End Sub

Public Sub TestFail()
    assert.Fail "This wasn't meant to be."
End Sub

Public Sub TestInconclusive()
    assert.Inconclusive "No idea."
End Sub

Public Sub TestIsFalse()
    assert.IsFalse False, "True should be False."
End Sub

Public Sub TestIsNothing()
    Dim foo As Object
    assert.IsNothing foo, "Foo should be nothing."
End Sub

Public Sub TestIsNotNothing()
    Dim foo As New Collection
    assert.IsNotNothing foo, "Foo shouldn't be nothing."
End Sub

Public Sub TestIsTrue()
    assert.IsTrue True, "False should be True."
End Sub

Public Sub TestBlowUp()
    assert.IsTrue True
    assert.AreEqual False, True
    Debug.Print 1 / 0
    assert.Fail "Test should have failed by now."
End Sub

Public Sub TestNoAssert()
End Sub

输出

我希望能够通过直接窗格中的简单“命令行”调用运行测试：

 TestEngine.RunAllTests "VBAProject", New TestClass1
Registered test: TestClass1.MagicCommentWorks
Registered test: TestClass1.TestAreEqual
Registered test: TestClass1.TestAreNotEqual
Registered test: TestClass1.TestAreSame
Registered test: TestClass1.TestAreNotSame
Registered test: TestClass1.TestFail
Registered test: TestClass1.TestInconclusive
Registered test: TestClass1.TestIsFalse
Registered test: TestClass1.TestIsNothing
Registered test: TestClass1.TestIsNotNothing
Registered test: TestClass1.TestIsTrue
Registered test: TestClass1.TestBlowUp
Registered test: TestClass1.TestNoAssert
2014-09-16 00:24:20 MagicCommentWorks: [INCONCLUSIVE] - No assertions made.
2014-09-16 00:24:20 TestAreEqual: [PASS]
2014-09-16 00:24:20 TestAreNotEqual: [PASS]
2014-09-16 00:24:20 TestAreSame: [FAIL] - AreSame failed: Objects should be same reference.
2014-09-16 00:24:20 TestAreNotSame: [PASS]
2014-09-16 00:24:20 TestFail: [FAIL] - Fail failed: This wasn't meant to be.
2014-09-16 00:24:20 TestInconclusive: [PASS]
2014-09-16 00:24:20 TestIsFalse: [PASS]
2014-09-16 00:24:20 TestIsNothing: [PASS]
2014-09-16 00:24:20 TestIsNotNothing: [PASS]
2014-09-16 00:24:20 TestIsTrue: [PASS]
2014-09-16 00:24:20 TestBlowUp: [INCONCLUSIVE] - Test raised an error: Division by zero
2014-09-16 00:24:20 TestNoAssert: [INCONCLUSIVE] - No assertions made.

客户端代码必须引用Excel加载项：

UnitTesting包含测试引擎。

就这些。 UnitTesting引用了这些.xlam Excel加载项：

系统包含Framework“命名空间”，其中公开了诸如List和Tuple之类的自定义类型，以及Strings中的各种字符串帮助器方法。名称空间”。
反射由UnitTesting加载项使用，并引用Microsoft Visual Basic for Applications Extensibility 5.3库以及系统加载项。

我主要是对UnitTesting项目的反馈感兴趣，但Reflection项目也向批评家开放！

2。 UnitTesting

假定已安装外接程序的依赖项，此模块是客户端代码必须引用的唯一外接程序（尽管也不能禁止也引用系统）。

客户端代码唯一需要了解的是TestEngine的默认实例。

TestEngine类模块

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "TestEngine"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Option Explicit

Private Type TTestEngine
    Output As ITestOutput
    RegisteredTests As Dictionary
    CurrentTest As String
    CurrentTestResults As List
End Type

Private WithEvents assertion As Assert
Attribute assertion.VB_VarHelpID = -1
Private this As TTestEngine

Public Sub RunAllTests(ByVal projectName As String, ByRef classInstance As Object)

    Set this.RegisteredTests = ReflectTestMethods(projectName, classInstance)

    Dim test As Variant
    For Each test In this.RegisteredTests
        RunTest test
    Next

End Sub

Private Function ReflectTestMethods(ByVal projectName As String, ByRef classInstance As Object) As Dictionary

    Dim classMethods As List
    Set classMethods = ClassModule.GetMethods(projectName, TypeName(classInstance))

    Dim result As New Dictionary

    Dim prospect As Method
    For Each prospect In classMethods

        If CanAddTestMethod(prospect, result) Then

            result.Add prospect.name, Tuple.Create(classInstance, prospect.name)
            Debug.Print "Registered test: " & TypeName(classInstance) & "." & prospect.name

        End If

    Next

    Set ReflectTestMethods = result

End Function

Private Function CanAddTestMethod(ByVal prospect As Method, ByRef testMethods As Dictionary) As Boolean

    Dim result As Boolean

    If Not IsTestMethodName(prospect) Then Exit Function
    If testMethods.Exists(prospect.name) Then Exit Function

    CanAddTestMethod = True

End Function

Private Function IsTestMethodName(ByVal testMethod As Method) As Boolean

    IsTestMethodName = _
        Framework.Strings.StartsWith("Test", testMethod.name, False) Or _
        Framework.Strings.StartsWith("'@TestMethod", Split(testMethod.Body, vbNewLine)(1), False)

End Function

Private Sub RunTest(ByVal name As String)

    this.CurrentTest = name
    Set this.CurrentTestResults = List.Create

    Dim result As TestResult
    On Error GoTo CleanFail

    Dim testOutput As New DebugTestOutput
    Set this.Output = testOutput

    Dim test As Tuple
    Set test = this.RegisteredTests(name)

    CallByName test.Item1, test.Item2, VbMethod

    If this.CurrentTestResults.Count = 0 Then
        Set result = TestResult.Create(Inconclusive, "No assertions made.")

    ElseIf CurrentTestFailedResults.Count = 0 Then
        Set result = TestResult.Create(Succeeded)

    ElseIf CurrentTestFailedResults.Count > 0 Then
        Set result = CurrentTestFailedResults.First

    End If

CleanExit:
    this.Output.WriteResult this.CurrentTest, result
    this.CurrentTest = vbNullString

    Exit Sub

CleanFail:
    Set result = TestResult.Create(Inconclusive, "Test raised an error: " & Err.Description)
    Resume CleanExit

End Sub

Private Function CurrentTestFailedResults() As List
    Dim resultList As List
    Set resultList = List.Create

    Dim result As TestResult
    For Each result In this.CurrentTestResults
        If result.TestOutcome = Failed Then resultList.Add result
    Next
    Set CurrentTestFailedResults = resultList
End Function

Private Sub assertion_Completed(ByVal result As TestResult)
    this.CurrentTestResults.Add result
    If result.TestOutcome = Failed And CurrentTestFailedResults.Count = 0 Then
        this.Output.WriteResult this.CurrentTest, result
    End If
End Sub

Private Sub Class_Initialize()
    Set assertion = Assert.DefaultInstance
End Sub

声明类模块

Assert类经过了彻底的简化：

Public Event Completed(ByVal result As TestResult)
Option Explicit

Private Sub OnAssertSucceeded()
    RaiseEvent Completed(TestResult.Create(Succeeded))
End Sub

Private Sub OnAssertFailed(ByVal name As String, ByVal message As String)
    RaiseEvent Completed(TestResult.Create(Failed, name & " failed: " & message))
End Sub

Private Sub OnAssertInconclusive(ByVal message As String)
    RaiseEvent Completed(TestResult.Create(0, message))
End Sub

Public Property Get DefaultInstance() As Assert
    Set DefaultInstance = Me
End Property

Public Sub IsTrue(ByVal condition As Boolean, Optional ByVal message As String)
    If condition Then
        OnAssertSucceeded
    Else
        OnAssertFailed "IsTrue", message
    End If
End Sub

Public Sub IsFalse(ByVal condition As Boolean, Optional ByVal message As String)
    If Not condition Then
        OnAssertSucceeded
    Else
        OnAssertFailed "IsFalse", message
    End If
End Sub

Public Sub Inconclusive(Optional ByVal message As String)
    OnAssertInconclusive message
End Sub

Public Sub Fail(Optional ByVal message As String)
    OnAssertFailed "Fail", message
End Sub

Public Sub IsNothing(ByVal value As Object, Optional ByVal message As String)
    If value Is Nothing Then
        OnAssertSucceeded
    Else
        OnAssertFailed "IsNothing", message
    End If
End Sub

Public Sub IsNotNothing(ByVal value As Object, Optional ByVal message As String)
    If Not value Is Nothing Then
        OnAssertSucceeded
    Else
        OnAssertFailed "IsNotNothing", message
    End If
End Sub

Public Sub AreEqual(ByVal value1 As Variant, ByVal value2 As Variant, Optional ByVal message As String)

    Dim result As Boolean
    result = (value1 = value2)

    If IsObject(value1) And IsObject(value2) Then

        If TypeOf value1 Is IEquatable And TypeOf value2 Is IEquatable Then

            Dim equatable1 As IEquatable
            Set equatable1 = value1

            Dim equatable2 As IEquatable
            Set equatable2 = value2

            result = equatable1.Equals(equatable2)

        End If

    End If

    If result Then
        OnAssertSucceeded
    Else
        OnAssertFailed "AreEqual", message
    End If

End Sub

Public Sub AreNotEqual(ByVal value1 As Variant, ByVal value2 As Variant, Optional ByVal message As String)

    Dim result As Boolean
    result = (value1 = value2)

    If IsObject(value1) And IsObject(value2) Then

        If TypeOf value1 Is IEquatable And TypeOf value2 Is IEquatable Then

            Dim equatable1 As IEquatable
            Set equatable1 = value1

            Dim equatable2 As IEquatable
            Set equatable2 = value2

            result = equatable1.Equals(equatable2)

        End If

    End If

    If Not result Then
        OnAssertSucceeded
    Else
        OnAssertFailed "AreNotEqual", message
    End If

End Sub

Public Sub AreSame(ByVal value1 As Object, ByVal value2 As Object, Optional ByVal message As String)
    If (ObjPtr(value1) = ObjPtr(value2)) Then
        OnAssertSucceeded
    Else
        OnAssertFailed "AreSame", message
    End If
End Sub

Public Sub AreNotSame(ByVal value1 As Object, ByVal value2 As Object, Optional ByVal message As String)
    If Not (ObjPtr(value1) = ObjPtr(value2)) Then
        OnAssertSucceeded
    Else
        OnAssertFailed "AreNotSame", message
    End If
End Sub

3。反射

我不是故意这么做的。我要怪@RubberDuck的这个好主意。我不想要求客户端代码降低其安全性设置，但是在这种情况下，好处显然超过了“风险”。

这里有点元编程，并且这是我第一次认真使用VBE。当然可以在这里有所改善。

ClassModule类模块

此类几乎是一个帮助程序，它获取CodeModule的方法成员列表。实例。现在。

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "ClassModule"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Option Explicit

Public Function GetMethods(ByVal projectName As String, ByVal className As String) As List

    Dim result As List
    Set result = List.Create

    Dim procedureName As String, lastFound As String
    Dim procedureBody As String

    Dim proj As VBProject
    Set proj = GetProject(projectName)

    If proj Is Nothing Then Exit Function
    Dim module As CodeModule
    Set module = GetClass(proj, className)

    Dim i As Long
    For i = module.CountOfDeclarationLines + 1 To module.CountOfLines
        procedureName = module.ProcOfLine(i, vbext_pk_Proc)
        If procedureName <> lastFound Then
            procedureBody = module.Lines(module.ProcStartLine(procedureName, vbext_pk_Proc), module.ProcCountLines(procedureName, vbext_pk_Proc))
            result.Add Method.Create(procedureName, procedureBody)
            lastFound = procedureName
        End If
    Next

    Set GetMethods = result

End Function

Private Function GetProject(ByVal projectName As String) As VBProject

    Dim proj As VBProject
    For Each proj In Application.VBE.VBProjects
        If proj.Name = projectName Then
            Set GetProject = proj
            Exit Function
        End If
    Next

End Function

Private Function GetClass(ByVal project As VBProject, ByVal className As String) As CodeModule

    Dim component As VBComponent
    For Each component In project.VBComponents
        If component.Name = className Then
            Set GetClass = component.CodeModule
            Exit Function
        End If
    Next

End Function

方法类模块

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "Method"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Private Type TMethod
    Name As String
    Body As String
End Type
Private this As TMethod
Option Explicit

Public Property Get Name() As String
    Name = this.Name
End Property

Friend Property Let Name(ByVal value As String)
    this.Name = value
End Property

Public Property Get Body() As String
    Body = this.Body
End Property

Friend Property Let Body(ByVal value As String)
    this.Body = value
End Property

Public Function Create(ByVal methodName As String, ByVal methodBody As String) As Method
    Dim result As New Method
    result.Name = methodName
    result.Body = methodBody
    Set Create = result
End Function

/>
这肯定可以改善。怎么样？

#1 楼

看看我发现了什么

Dim procedureName As String, lastFound As String
Dim procedureBody As String

我个人不喜欢这样声明变量，几乎每种语言都允许您以某种方式执行此操作。

我认为这是那些神圣的战争问题之一，有些程序员喜欢这样做，有些程序员则说这是不好的做法。

警惕要维护的人这段代码以及当您离开时他们会怎么说。

我发现了其他内容，可能是更改代码或逻辑的遗物

Private Function CanAddTestMethod(ByVal prospect As Method, ByRef testMethods As Dictionary) As Boolean
    Dim result As Boolean

    If Not IsTestMethodName(prospect) Then Exit Function
    If testMethods.Exists(prospect.name) Then Exit Function

    CanAddTestMethod = True
End Function

我猜想您不再需要

Dim result As Boolean

，它就剩了，尽管我认为您可能想要这样的东西

Private Function CanAddTestMethod(ByVal prospect As Method, ByRef testMethods As Dictionary) As Boolean
    CanAddTestMethod = false

    If Not IsTestMethodName(prospect) Then Exit Function
    If testMethods.Exists(prospect.name) Then Exit Function

    CanAddTestMethod = True
End Function

因此，如果您在其中一个if语句中退出该函数，则它说“嘿，我是假的，您不能添加测试方法”。

，但是我记得我们在这里谈论的是VBA，我认为如果您不设置方法就退出，它将自动为假，因此它只是

Private Function CanAddTestMethod(ByVal prospect As Method, ByRef testMethods As Dictionary) As Boolean
    If Not IsTestMethodName(prospect) Then Exit Function
    If testMethods.Exists(prospect.name) Then Exit Function
    CanAddTestMethod = True
End Function

在RunTest子目录中，您等待直到第三行代码声明错误handlin g，
我不确定这是否是故意的，如果GoTo较早并且在第三行之前出现错误，则错误说明可能无法正常工作。

想一想。

我们可以将Exit Function函数中的GetMethods代码移动到该函数的开头，这样就不必使变量变暗了吗？
调试代码时会更容易看到

而不是This

Public Function GetMethods(ByVal projectName As String, ByVal className As String) As List

    Dim result As List
    Set result = List.Create

    Dim procedureName As String, lastFound As String
    Dim procedureBody As String

    Dim proj As VBProject
    Set proj = GetProject(projectName)

    If proj Is Nothing Then Exit Function
    Dim module As CodeModule
    Set module = GetClass(proj, className)

    Dim i As Long
    For i = module.CountOfDeclarationLines + 1 To module.CountOfLines
        procedureName = module.ProcOfLine(i, vbext_pk_Proc)
        If procedureName <> lastFound Then
            procedureBody = module.Lines(module.ProcStartLine(procedureName, vbext_pk_Proc), module.ProcCountLines(procedureName, vbext_pk_Proc))
            result.Add Method.Create(procedureName, procedureBody)
            lastFound = procedureName
        End If
    Next

    Set GetMethods = result

End Function

编写它像这样

Public Function GetMethods(ByVal projectName As String, ByVal className As String) As List
    Dim proj As VBProject
    Set proj = GetProject(projectName)

    If proj Is Nothing Then Exit Function

    Dim result As List
    Set result = List.Create

    Dim procedureName As String, lastFound As String
    Dim procedureBody As String

    Dim module As CodeModule
    Set module = GetClass(proj, className)

    Dim i As Long
    For i = module.CountOfDeclarationLines + 1 To module.CountOfLines
        procedureName = module.ProcOfLine(i, vbext_pk_Proc)
        If procedureName <> lastFound Then
            procedureBody = module.Lines(module.ProcStartLine(procedureName, vbext_pk_Proc), module.ProcCountLines(procedureName, vbext_pk_Proc))
            result.Add Method.Create(procedureName, procedureBody)
            lastFound = procedureName
        End If
    Next

    Set GetMethods = result

End Function

所有的括号和分号在哪里？

\ $ \ begingroup \ $
这里有两个不错的地方。但是，VBA不在乎Dim语句在哪里-如果在函数中声明了Dim语句，则它在该函数中的任何作用域内；您不能在Dim语句上打断:)
\ $ \ endgroup \ $
– Mathieu Guindon♦
2014-09-16 19:41

\ $ \ begingroup \ $
@ Mat'sMug再看一遍。如果在变暗之后退出函数，它已经使用了处理能力来变暗那些变量，如果您在那些变暗的语句之前退出了函数，它们是从未创建的，对吧？
\ $ \ endgroup \ $
–马拉奇♦
2014-09-16 19:46

\ $ \ begingroup \ $
是的。列表永远不会被创建，但是马克杯是正确的，因为一个作用域的Dims都同时发生。
\ $ \ endgroup \ $
–RubberDuck
2014年9月16日19:54

\ $ \ begingroup \ $
“括号和分号都在哪里？”使我的饮料从我的鼻子里冒出来。无论如何还是要进行+1观察。
\ $ \ endgroup \ $
–共产国际
2014年9月17日下午2:05

\ $ \ begingroup \ $
@RubberDuck，我现在明白了，在它们变暗之前退出并不重要，因为编译器/解释器/（无论VBA使用什么）都检查范围并从头开始设置内存，然后一直运行范围。我明白了！
\ $ \ endgroup \ $
–马拉奇♦
2014年9月17日下午13:33

#2 楼

我还没有真正深入研究这里的内容，也许其他人会为您提供有关单元测试代码的全新视角。我想解决ClassModule.GetMethods中的算法问题。我对这种效率低下负有部分责任，因为在先前的回答中，我向您指出了我之前编写的一些代码。

您当前使用的算法是\ $ O（n）\ $，其中\ $ N \ $是模块中的行数。通过切换到while循环并直接查找下一个方法的行号，可以在\ $ O（log n）\ $时间内完成此操作。

所以，而不是这样：

Dim i As Long
For i = module.CountOfDeclarationLines + 1 To module.CountOfLines
    procedureName = module.ProcOfLine(i, vbext_pk_Proc)
    If procedureName <> lastFound Then
        procedureBody = module.Lines(module.ProcStartLine(procedureName, vbext_pk_Proc), module.ProcCountLines(procedureName, vbext_pk_Proc))
        result.Add Method.Create(procedureName, procedureBody)
        lastFound = procedureName
    End If
Next

使用此：

Dim lineNumber as Long
lineNumber = module.CountOfDeclarationLines + 1
While (lineNumber < module.CountOfLines)
    procedureName = module.ProcOfLine(lineNumber, vbext_pk_Proc)

    procedureBody = module.Lines(module.ProcStartLine(procedureName, vbext_pk_Proc), module.ProcCountLines(procedureName, vbext_pk_Proc))

    result.Add Method.Create(procedureName, procedureBody)

    ' add current start line to the number of lines in current procedure to get the start line of the next procedure.
    lineNumber = lineNumber + module.ProcCountLines(procedureName, vbext_pk_Proc) + 1
Wend

考虑到这一点，我不是这行代码的忠实拥护者，在上面的改进算法版本中，我并没有更改。

procedureBody = module.Lines(module.ProcStartLine(procedureName, vbext_pk_Proc), module.ProcCountLines(procedureName, vbext_pk_Proc))

这不是你的错。可扩展性库非常笨拙。这就是我扩展它的原因。我不太了解的是为什么您创建了Method类，但是没有实现使这些类型的调用更容易的任何事情。特别是StartLine，CountOfLines，EndLine和Body。（实际上，您是在我的库中编写了许多属性的人。）请考虑vbeProcedure（方法）具有这些属性的等效代码。

Dim lineNumber As Long
lineNumber = codeMod.CountOfDeclarationLines + 1
While (lineNumber < codeMod.CountOfLines)
    procName = codeMod.ProcOfLine(lineNumber, vbext_pk_Proc)
    Set proc = New vbeProcedure
    proc.Initialize procName, codeMod

    procs.Add proc

    lineNumber = proc.EndLine + 1

Wend
Set GetProcedures = procs

当然，这样做意味着每个Method都必须知道它属于哪个父模块，因此，如果采用这种方法，请小心使用循环引用，并确保正确处置Method。 >

GetProject过于复杂。这就是您真正需要的。

Private Function GetProject(ByVal projectName As String) As VBProject
    GetProject = Application.VBE.VBProjects(projectName)
End Function

当然，如果您传递一个空字符串或一个不存在的名称，它将炸毁，但这是一件好事。您的代码也将崩溃，它将在堆栈跟踪的更深处执行，您将不知道为什么Project Is Nothing。让它尽早失败，尤其是当您在使用元编程进行混乱时。

从头开始。我看到您在其中添加了一些代码。

If proj Is Nothing Then Exit Function

但是我还是不喜欢它。在一周的任何一天，我都希望有一条错误消息而不是无声的失败。

\ $ \ begingroup \ $
好的帖子，但是我想问，调用Application.VBE.VBProjects（projectName）是否比通过Application.VBE.VBProjects进行迭代更安全。根据我在VBE方面的经验，通常不会收到错误消息或无提示的故障。它们中的任何一种都有不可预测的趋势来删除VBA主机。我不知道在最新版本的Office中这种情况是否有所改善，但我对此表示怀疑。我想说这是一个好习惯，当您在代码运行时所处的上下文中进行错误处理时，请尽可能避免发生错误。
\ $ \ endgroup \ $
–共产国际
2014年9月17日下午2:12

\ $ \ begingroup \ $
我从来没有暗示过@Comintern会更安全。我只是认为对于维护者而言，这将减少混乱。
\ $ \ endgroup \ $
–RubberDuck
2014年9月17日下午13:12

#3 楼

IsTestMethodName很糟糕。该函数应该是IsTestMethod，并且可以使用一些常量：

Private Const TestMethodNamePrefix As String = "Test"
Private Const TestMethodAttribute As String = "TestMethod"

在Reflection.Method类中提供更多属性和帮助函数：

Friend Property Let Body(ByVal value As String)
    this.Body = value
    FindSignature
End Property

Public Property Get Signature() As String
    Signature = this.Signature
End Property

'Private Const MethodAttributeMarker As String = "'@"    
Public Function HasAttribute(ByVal value As String) As Boolean
    HasAttribute = this.AttributeComment = MethodAttributeMarker & Trim(value)
End Function


Private Sub FindSignature()

    Dim lines() As String
    lines = Split(this.Body, vbNewLine)

    Dim i As Integer
    For i = LBound(lines) To UBound(lines)

        If framework.Strings.StartsWithAny(lines(i), False, "public sub", _
                                                            "private sub", _
                                                            "friend sub", _
                                                            "sub", _
                                                            "public function", _
                                                            "private function", _
                                                            "friend function", _
                                                            "function") _
        Then

            this.Signature = lines(i)

            If i > 0 Then

                If framework.Strings.StartsWith(AttributeMarker, lines(i - 1)) Then
                    this.AttributeComment = lines(i - 1)
                End If

            End If

            Exit Sub

        End If

    Next

End Sub

...您可以一时兴起将IsTestMethodName转换为IsTestMethod。当前实现的一个问题是对Body行索引的硬编码-代码假定它会在第二行（索引1）找到一个'@TestMethod“属性”。.但是过程的主体并不以其签名开头：它开始于VBA编辑器使用水平规则标记的那一行：客户端代码很可能在方法之间有5条空行，这会破坏您的代码。

因此，鉴于上述属性， IsTestMethod看起来像这样：

Private Function IsTestMethod(ByVal testMethod As Method) As Boolean

    Dim result As Boolean
    result = _
        Framework.Strings.StartsWith(TestMethodNamePrefix, testMethod.name, False) Or _
        testMethod.HasAttribute(TestMethodAttribute)

    If Not result Then Exit Function

    result = result And Framework.Strings.StartsWith("public sub", testMethod.Signature, False)
    IsTestMethod = result

End Function

现在，如果testMethod.Name，testMethod.AttributeComment或testMethod.Signature的值存在问题，则该代码中没有该错误-它可以仅在Reflection代码中。

#4 楼

BUG！
，我简直不敢相信这一点：

2014-09-16 00:24:20 TestInconclusive: [PASS]

TestInconclusive测试方法应输出以下内容：

2014-09-16 00:24:20 TestInconclusive: [INCONCLUSIVE] - No idea.

TestEngine.CurrentTestFailedResults()函数可以重命名为CurrentTestNotPassedResults()，并考虑到Inconclusive的结果：

For Each result In this.CurrentTestResults
    If result.TestOutcome = Failed Or result.TestOutcome = Inconclusive Then resultList.Add result
Next

，然后可以将assertion_Completed处理程序修改为：

Private Sub assertion_Completed(ByVal result As TestResult)
    this.CurrentTestResults.Add result
    If (result.TestOutcome = Inconclusive Or result.TestOutcome = Failed) _
        And CurrentTestNotPassedResults.Count = 0 _
    Then
        this.Output.WriteResult this.CurrentTest, result
    End If
End Sub

修复了错误并进行了测试：

Public Sub TestInconclusive()
    assert.IsTrue True
    assert.Inconclusive "No idea."
    assert.Fail "shouldn't output this result."
End Sub

输出此单个结果，因为它应该：

2014-09-21 12:29:01 TestInconclusive: [INCONCLUSIVE] - No idea.

元组
它修复了该错误，但是仍然有一些气味：RegisteredTests私有成员是Dictionary<string,Tuple>：

For Each prospect In classMethods

    If CanAddTestMethod(prospect, result) Then
        
        result.Add prospect.name, Tuple.Create(classInstance, prospect.name)
        Debug.Print "Registered test: " & TypeName(classInstance) & "." & prospect.name
    
    End If

Next

这导致这行代码-事实证明，这是所有代码中最重要的一行，其内容如下：

CallByName test.Item1, test.Item2, VbMethod

Item1和Item2都是Variant，绝对没有任何意义。与.NET代码一样，使用Tuple表示缺少抽象-这里是一个简单的TestMethod类：

    If CanAddTestMethod(prospect, result) Then
        
        result.Add prospect.name, TestMethod.Create(classInstance, prospect.name)
        Debug.Print "Registered test: " & TypeName(classInstance) & "." & prospect.name
    
    End If

这还不很清楚吗？

Dim test As TestMethod
Set test = this.RegisteredTests(name)

CallByName test.OwnerInstance, test.MethodName, VbMethod

CurrentTestNotPassedResults（）
此函数看起来像是拼凑而成的。它可以工作，但是闻起来很糟糕。而且它根本没有效率：每次执行测试时都会重新构建测试结果的“失败/不确定”列表（哎呀，每次在测试中进行断言），这意味着客户端测试类必须进行更多的测试运行，将花费更长的时间来处理以后的测试。不好。
TestEngine确实会从拥有私有FailedOrInconclusiveResults列表中受益，而不是使用以下功能：

Private Type TTestEngine
    Output As ITestOutput
    RegisteredTests As Dictionary
    CurrentTest As String
    CurrentTestAllResults As List
    CurrentTestFailedOrInconclusiveResults As List
End Type

然后可以简化assert_Completed处理程序：

Private Sub assertion_Completed(ByVal result As TestResult)
    this.CurrentTestAllResults.Add result
    If result.TestOutcome = Inconclusive Or result.TestOutcome = Failed Then
        this.CurrentTestFailedOrInconclusiveResults.Add result
    End If
End Sub

在执行测试后，该命令将删除除一个test.Output.WriteResult之外的所有调用-剩下的仅一个在RunTest方法中。更清洁。

#5 楼

错误

这是一个微妙的问题。

procedureBody = module.Lines(module.ProcStartLine(procedureName, vbext_pk_Proc), module.ProcCountLines(procedureName, vbext_pk_Proc))

具体来说，这是：

module.ProcStartLine(procedureName, vbext_pk_Proc)

只要您从不传递属性名称，它就可以100％罚款。公平地说，您是测试类，永远不要拥有属性，但是如果有的话……。天哪！当心！运行时错误＃35正等待达到其丑陋的顶峰。

问题是ProcStartLine需要知道它正在按名称查找哪种方法。这是一个问题，因为以这种方式使用可扩展性库时，我们极不可能知道我们是在预先处理属性还是方法。

因此，在我关于\ $ O（log n）\ $解决方案的其他答案中，所有这些东西都忘了。为了安全地执行此操作，您必须逐行解析代码模块。这是我想出的解决方案。它不是很漂亮，但是可以使代码安全。

Private Function GetProcedureType(signatureLine As String) As vbext_ProcKind
    If InStr(1, signatureLine, "Property Get") > 0 Then
        GetProcedureType = vbext_pk_Get
    ElseIf InStr(1, signatureLine, "Property Let") > 0 Then
        GetProcedureType = vbext_pk_Let
    ElseIf InStr(1, signatureLine, "Property Set") > 0 Then
        GetProcedureType = vbext_pk_Set
    ElseIf InStr(1, signatureLine, "Sub") > 0 Or InStr(1, signatureLine, "Function") > 0 Then
        GetProcedureType = vbext_pk_Proc
    Else
        Const InvalidProcedureCallOrArgument As Long = 5
        Err.Raise InvalidProcedureCallOrArgument
    End If
End Function

Private Function IsSignature(line As String) As Boolean
    If line = vbNullString Then Exit Function

    Dim propertyPosition As Long
    Dim functionPosition As Long
    Dim subPosition As Long
    Dim commentPosition As Long

    propertyPosition = InStr(1, line, "Property")
    functionPosition = InStr(1, line, "Function")
    subPosition = InStr(1, line, "Sub")
    commentPosition = InStr(1, line, "'")

    If propertyPosition > 0 Or functionPosition > 0 Or subPosition > 0 Then
        If InStr(1, line, "End") = 0 Then
            If commentPosition > propertyPosition Then
                Exit Function
            ElseIf commentPosition > functionPosition Then
                Exit Function
            ElseIf commentPosition > subPosition Then
                Exit Function
            Else
                IsSignature = True
            End If
        End If
    End If

End Function

将其应用于代码看起来像这样。请注意，我将procKind添加为Method的成员，并且无需再次检查此proc名称的最后一个proc名称，因为我们仅在签名行上才添加方法。 />
当然，您可能还需要先检查ProcKind，然后再将其注册为TestMethod。我怀疑CallByName确实会在真正获得财产时不被告知要获得vbMethod。

旁注：您可能会发现有趣的是，知道ProcOfLine不会遭受此损害。据我所知，您可以传递任何一个vbext_ProcKind，它将愉快地运行。

我们已经在聊天中讨论了这一点，但是为了将来的读者起见，我在这里添加。毕竟，\ $ O（n）\ $解决方案是可能的。 ProcOfLine会占用您抛出的所有vbext_ProcKind的原因是它是一个OUT参数。

请注意，pprockind参数指示该行是否属于
子或函数过程，属性获取过程，属性Let
过程或属性集过程。若要确定某行所在的
过程类型，请将Long类型的变量传递给ProcOfLine
属性，然后检查该变量的值。

摘自2013 MS Access文档。这很容易被遗漏，因为Visual Basic加载项对象引用的2013 Office版本和VB6版本根本没有提及它。解决方案是简单地声明一个procKind变量，然后让它为您捕获procKind。

Dim procKind As vbext_ProcKind
Dim i As Long
For i = Module.CountOfDeclarationLines + 1 To Module.CountOfLines
    line = Module.Lines(i, 1)
    If IsSignature(line) Then
        procKind = GetProcedureType(line)
        procedureName = Module.ProcOfLine(i, procKind)
        procedureBody = Module.Lines(Module.ProcStartLine(procedureName, procKind), Module.ProcCountLines(procedureName, procKind))

        result.Add Method.Create(procedureName, procedureBody, procKind)
    End If
Next

编程黑洞网