├── .gitignore ├── vba-block.lock ├── vba-block.toml ├── tests ├── Tests.bas ├── Test_Fixture.cls ├── Tests_TestSuite.bas └── Tests_TestCase.bas ├── .gitattributes ├── LICENSE ├── src ├── ImmediateReporter.cls ├── FileReporter.cls ├── TestSuite.cls └── TestCase.cls └── README.md /.gitignore: -------------------------------------------------------------------------------- 1 | build 2 | 3 | # Ignore temporary Office files and OS files 4 | */~$* 5 | .DS_Store 6 | -------------------------------------------------------------------------------- /vba-block.lock: -------------------------------------------------------------------------------- 1 | # Auto-generated by vba-blocks v0.4.2 2 | [metadata] 3 | version = "1" 4 | 5 | [root] 6 | name = "test" 7 | version = "2.0.0-beta.3" 8 | dependencies = [ 9 | "dictionary 1.4.1 registry+vba-blocks#sha256-b241062bcd7ffd68c9063e3980a5df4c6781df29d96763a020d291e52454f6a5", 10 | ] 11 | 12 | [[packages]] 13 | name = "dictionary" 14 | version = "1.4.1" 15 | source = "registry+vba-blocks#sha256-b241062bcd7ffd68c9063e3980a5df4c6781df29d96763a020d291e52454f6a5" 16 | dependencies = [ 17 | ] 18 | 19 | -------------------------------------------------------------------------------- /vba-block.toml: -------------------------------------------------------------------------------- 1 | [package] 2 | name = "test" 3 | version = "2.0.0-beta.3" 4 | authors = ["Tim Hall (https://github.com/timhall)"] 5 | 6 | [src] 7 | TestSuite = "src/TestSuite.cls" 8 | TestCase = "src/TestCase.cls" 9 | ImmediateReporter = "src/ImmediateReporter.cls" 10 | FileReporter = "src/FileReporter.cls" 11 | 12 | [dependencies] 13 | dictionary = "^1" 14 | 15 | [dev-src] 16 | Tests = "tests/Tests.bas" 17 | Tests_TestCase = "tests/Tests_TestCase.bas" 18 | Tests_TestSuite = "tests/Tests_TestSuite.bas" 19 | Test_Fixture = "tests/Test_Fixture.cls" 20 | -------------------------------------------------------------------------------- /tests/Tests.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "Tests" 2 | Public Sub Run(Optional OutputPath As Variant) 3 | Dim Suite As New TestSuite 4 | Suite.Description = "vba-test" 5 | 6 | Dim Immediate As New ImmediateReporter 7 | Immediate.ListenTo Suite 8 | 9 | If Not IsMissing(OutputPath) And CStr(OutputPath) <> "" Then 10 | Dim Reporter As New FileReporter 11 | Reporter.WriteTo OutputPath 12 | Reporter.ListenTo Suite 13 | End If 14 | 15 | Tests_TestSuite.RunTests Suite.Group("TestSuite") 16 | Tests_TestCase.RunTests Suite.Group("TestCase") 17 | End Sub 18 | -------------------------------------------------------------------------------- /.gitattributes: -------------------------------------------------------------------------------- 1 | # CRLF -> LF by default, but not for modules or classes (especially classes) 2 | * text=auto 3 | *.bas text eol=crlf 4 | *.cls text eol=crlf 5 | 6 | # Standard to msysgit 7 | *.doc diff=astextplain 8 | *.DOC diff=astextplain 9 | *.docx diff=astextplain 10 | *.DOCX diff=astextplain 11 | *.dot diff=astextplain 12 | *.DOT diff=astextplain 13 | *.pdf diff=astextplain 14 | *.PDF diff=astextplain 15 | *.rtf diff=astextplain 16 | *.RTF diff=astextplain 17 | 18 | # Clarify that the source language is VBA (Auto-detection not always accurate) 19 | *.bas linguist-language=VBA 20 | *.cls linguist-language=VBA -------------------------------------------------------------------------------- /tests/Test_Fixture.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "Test_Fixture" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = True 10 | Private WithEvents pSuite As TestSuite 11 | Attribute pSuite.VB_VarHelpID = -1 12 | 13 | Public BeforeEachCallCount As Long 14 | Public ResultCalls As Collection 15 | Public AfterEachCallCount As Long 16 | 17 | Public Sub ListenTo(Suite As TestSuite) 18 | Set pSuite = Suite 19 | End Sub 20 | 21 | Private Sub pSuite_BeforeEach(Test As TestCase) 22 | BeforeEachCallCount = BeforeEachCallCount + 1 23 | End Sub 24 | 25 | Private Sub pSuite_Result(Test As TestCase) 26 | Me.ResultCalls.Add Test 27 | End Sub 28 | 29 | Private Sub pSuite_AfterEach(Test As TestCase) 30 | AfterEachCallCount = AfterEachCallCount + 1 31 | End Sub 32 | 33 | Private Sub Class_Initialize() 34 | Set Me.ResultCalls = New Collection 35 | End Sub 36 | 37 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2018 Tim Hall 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /tests/Tests_TestSuite.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "Tests_TestSuite" 2 | Public Sub RunTests(Suite As TestSuite) 3 | Dim Tests As TestSuite 4 | Dim Fixture As New Test_Fixture 5 | Fixture.ListenTo Suite 6 | 7 | With Suite.Test("should fire BeforeEach event") 8 | .IsEqual Fixture.BeforeEachCallCount, 1 9 | End With 10 | 11 | With Suite.Test("should fire Result event") 12 | .IsEqual Fixture.ResultCalls(1).Description, "should fire BeforeEach event" 13 | .IsEqual Fixture.ResultCalls(1).Result, TestResultType.Pass 14 | End With 15 | 16 | With Suite.Test("should fire AfterEach event") 17 | .IsEqual Fixture.AfterEachCallCount, 2 18 | End With 19 | 20 | With Suite.Test("should store specs") 21 | Set Tests = New TestSuite 22 | With Tests.Test("(pass)") 23 | .IsEqual 4, 4 24 | End With 25 | With Tests.Test("(fail)") 26 | .IsEqual 4, 3 27 | End With 28 | With Tests.Test("(pending)") 29 | End With 30 | With Tests.Test("(skipped)") 31 | .Skip 32 | End With 33 | 34 | .IsEqual Tests.Tests.Count, 4 35 | .IsEqual Tests.PassedTests.Count, 1 36 | .IsEqual Tests.FailedTests.Count, 1 37 | .IsEqual Tests.PendingTests.Count, 1 38 | .IsEqual Tests.SkippedTests.Count, 1 39 | 40 | .IsEqual Tests.PassedTests(1).Description, "(pass)" 41 | .IsEqual Tests.FailedTests(1).Description, "(fail)" 42 | .IsEqual Tests.PendingTests(1).Description, "(pending)" 43 | .IsEqual Tests.SkippedTests(1).Description, "(skipped)" 44 | End With 45 | 46 | With Suite.Test("should have overall result") 47 | Set Tests = New TestSuite 48 | 49 | .IsEqual Tests.Result, TestResultType.Pending 50 | 51 | With Tests.Test("(pending)") 52 | End With 53 | 54 | .IsEqual Tests.Result, TestResultType.Pending 55 | 56 | With Tests.Test("(pass)") 57 | .IsEqual 4, 4 58 | End With 59 | 60 | .IsEqual Tests.Result, TestResultType.Pass 61 | 62 | With Tests.Test("(fail)") 63 | .IsEqual 4, 3 64 | End With 65 | 66 | .IsEqual Tests.Result, TestResultType.Fail 67 | 68 | With Tests.Test("(pass)") 69 | .IsEqual 2, 2 70 | End With 71 | 72 | .IsEqual Tests.Result, TestResultType.Fail 73 | End With 74 | 75 | End Sub 76 | -------------------------------------------------------------------------------- /src/ImmediateReporter.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "ImmediateReporter" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = True 10 | '' 11 | ' # ImmediateReporter 12 | ' 13 | ' Report results to Immediate Window 14 | ' 15 | ' ```vba 16 | ' Dim Suite As New TestSuite 17 | ' ... 18 | ' 19 | ' Dim Reporter As New ImmediateReporter 20 | ' Reporter.ListenTo Suite 21 | ' ``` 22 | ' 23 | ' @class ImmediateReporter 24 | ' @author tim.hall.engr@gmail.com 25 | ' @repository https://github.com/vba-tools/vba-test 26 | ' @license MIT 27 | '' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' 28 | Option Explicit 29 | 30 | Private WithEvents pSuite As TestSuite 31 | Attribute pSuite.VB_VarHelpID = -1 32 | Private Finished As Boolean 33 | 34 | '' 35 | ' Listen to given TestSuite 36 | '' 37 | Public Sub ListenTo(Suite As TestSuite) 38 | If Not pSuite Is Nothing Then 39 | ' If already listening to suite, 40 | ' report summary before moving on to next suite 41 | PrintSummary 42 | End If 43 | 44 | Finished = False 45 | Set pSuite = Suite 46 | PrintHeader Suite 47 | 48 | ' Report any tests added prior to listening 49 | Dim Test As TestCase 50 | For Each Test In Suite.Tests 51 | PrintResult Test 52 | Next Test 53 | End Sub 54 | 55 | ' ============================================= ' 56 | 57 | Private Sub PrintHeader(Suite As TestSuite) 58 | Debug.Print "===" & IIf(Suite.Description <> "", " " & Suite.Description & " ===", "") 59 | End Sub 60 | 61 | Private Sub PrintResult(Test As TestCase) 62 | If Test.Result = TestResultType.Skipped Then 63 | Exit Sub 64 | End If 65 | 66 | Debug.Print ResultTypeToString(Test.Result) & " " & Test.Description 67 | 68 | If Test.Result = TestResultType.Fail Then 69 | Dim Failure As Variant 70 | For Each Failure In Test.Failures 71 | Debug.Print " " & Failure 72 | Next Failure 73 | End If 74 | End Sub 75 | 76 | Private Sub PrintSummary() 77 | Dim Total As Long 78 | Dim Passed As Long 79 | Dim Failed As Long 80 | Dim Pending As Long 81 | Dim Skipped As Long 82 | 83 | Total = pSuite.Tests.Count 84 | Passed = pSuite.PassedTests.Count 85 | Failed = pSuite.FailedTests.Count 86 | Pending = pSuite.PendingTests.Count 87 | Skipped = pSuite.SkippedTests.Count 88 | 89 | Dim Summary As String 90 | If Failed > 0 Then 91 | Summary = "FAIL (" & Failed & " of " & Total & " failed" 92 | Else 93 | Summary = "PASS (" & Passed & " of " & Total & " passed" 94 | End If 95 | If Pending > 0 Then 96 | Summary = Summary & ", " & Pending & " pending" 97 | End If 98 | If Skipped > 0 Then 99 | Summary = Summary & ", " & Skipped & " skipped)" 100 | Else 101 | Summary = Summary & ")" 102 | End If 103 | 104 | Debug.Print "= " & Summary & " = " & Now & " =" & vbNewLine 105 | End Sub 106 | 107 | Private Function ResultTypeToString(ResultType As TestResultType) As String 108 | Select Case ResultType 109 | Case TestResultType.Pass 110 | ResultTypeToString = "+" 111 | Case TestResultType.Fail 112 | ResultTypeToString = "X" 113 | Case TestResultType.Pending 114 | ResultTypeToString = "." 115 | End Select 116 | End Function 117 | 118 | Private Sub pSuite_Group(Suite As TestSuite) 119 | PrintHeader Suite 120 | End Sub 121 | 122 | Private Sub pSuite_Result(Test As TestCase) 123 | PrintResult Test 124 | End Sub 125 | 126 | Private Sub Class_Terminate() 127 | If Not Finished Then 128 | PrintSummary 129 | End If 130 | End Sub 131 | -------------------------------------------------------------------------------- /src/FileReporter.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "FileReporter" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = True 10 | '' 11 | ' # FileReporter 12 | ' 13 | ' Append test results to the given file 14 | ' 15 | ' ```vba 16 | ' Dim Suite As New TestSuite 17 | ' ... 18 | ' 19 | ' Dim Reporter As New FileReporter 20 | ' Reporter.WriteTo "path/to/file" 21 | ' Reporter.ListenTo Suite 22 | ' ``` 23 | ' 24 | ' @class FileReporter 25 | ' @author Tim Hall 26 | ' @repository https://github.com/vba-tools/vba-test 27 | ' @license MIT 28 | '' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' 29 | Option Explicit 30 | 31 | Private WithEvents pSuite As TestSuite 32 | Attribute pSuite.VB_VarHelpID = -1 33 | Private FilePath As String 34 | Private Finished As Boolean 35 | 36 | '' 37 | ' Report test results to the given file path 38 | '' 39 | Public Sub WriteTo(Path As Variant) 40 | FilePath = Path 41 | End Sub 42 | 43 | '' 44 | ' Report test results from the given TestSuite 45 | '' 46 | Public Sub ListenTo(Suite As TestSuite) 47 | If Not pSuite Is Nothing Then 48 | PrintSummary 49 | End If 50 | 51 | Finished = False 52 | Set pSuite = Suite 53 | PrintHeader Suite 54 | End Sub 55 | 56 | ' ============================================= ' 57 | 58 | Private Sub PrintHeader(Suite As TestSuite) 59 | AppendToFile "===" & VBA.IIf(Suite.Description <> "", " " & Suite.Description & " ===", "") 60 | End Sub 61 | 62 | Private Sub PrintResult(Test As TestCase) 63 | If Test.Result = TestResultType.Skipped Then 64 | Exit Sub 65 | End If 66 | 67 | AppendToFile ResultTypeToString(Test.Result) & " " & Test.Description 68 | 69 | If Test.Result = TestResultType.Fail Then 70 | Dim Failure As Variant 71 | For Each Failure In Test.Failures 72 | AppendToFile " " & Failure 73 | Next Failure 74 | End If 75 | End Sub 76 | 77 | Private Sub PrintSummary() 78 | Dim Total As Long 79 | Dim Passed As Long 80 | Dim Failed As Long 81 | Dim Pending As Long 82 | Dim Skipped As Long 83 | 84 | Total = pSuite.Tests.Count 85 | Passed = pSuite.PassedTests.Count 86 | Failed = pSuite.FailedTests.Count 87 | Pending = pSuite.PendingTests.Count 88 | Skipped = pSuite.SkippedTests.Count 89 | 90 | Dim Summary As String 91 | If Failed > 0 Then 92 | Summary = "FAIL (" & Failed & " of " & Total & " failed" 93 | Else 94 | Summary = "PASS (" & Passed & " of " & Total & " passed" 95 | End If 96 | If Pending > 0 Then 97 | Summary = Summary & ", " & Pending & " pending" 98 | End If 99 | If Skipped > 0 Then 100 | Summary = Summary & ", " & Skipped & " skipped)" 101 | Else 102 | Summary = Summary & ")" 103 | End If 104 | 105 | AppendToFile "= " & Summary & " = " & Now & " =" & vbNewLine 106 | End Sub 107 | 108 | Private Function ResultTypeToString(ResultType As TestResultType) As String 109 | Select Case ResultType 110 | Case TestResultType.Pass 111 | ResultTypeToString = "+" 112 | Case TestResultType.Fail 113 | ResultTypeToString = "X" 114 | Case TestResultType.Pending 115 | ResultTypeToString = "." 116 | End Select 117 | End Function 118 | 119 | Private Sub AppendToFile(Message As String) 120 | If FilePath = "" Then Exit Sub 121 | 122 | Dim File As Integer 123 | File = FreeFile 124 | 125 | On Error GoTo Cleanup 126 | 127 | Open FilePath For Append As #File 128 | Print #File, Message 129 | 130 | Cleanup: 131 | Close #File 132 | End Sub 133 | 134 | Private Sub pSuite_Result(Test As TestCase) 135 | PrintResult Test 136 | End Sub 137 | 138 | Private Sub pSuite_Group(Suite As TestSuite) 139 | PrintHeader Suite 140 | End Sub 141 | 142 | Private Sub Class_Terminate() 143 | If Not Finished Then 144 | PrintSummary 145 | End If 146 | End Sub 147 | 148 | -------------------------------------------------------------------------------- /src/TestSuite.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "TestSuite" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = True 10 | '' 11 | ' # TestSuite 12 | ' 13 | ' A collection of tests, with events and results 14 | ' 15 | ' ```vba 16 | ' Dim Suite As New TestSuite 17 | ' Suite.Description = "Name" 18 | ' 19 | ' With Suite.Test("A") 20 | ' .IsEqual 2 + 2, 4 21 | ' End With 22 | ' ``` 23 | ' 24 | ' @class TestSuite 25 | ' @author tim.hall.engr@gmail.com 26 | ' @repository https://github.com/vba-tools/vba-test 27 | ' @license MIT 28 | '' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' 29 | Option Explicit 30 | 31 | Public Enum TestResultType 32 | Pass 33 | Fail 34 | Pending 35 | Skipped 36 | End Enum 37 | 38 | Public Event BeforeEach(Test As TestCase) 39 | Public Event Result(Test As TestCase) 40 | Public Event AfterEach(Test As TestCase) 41 | Public Event Group(Suite As TestSuite) 42 | 43 | '' 44 | ' (Optional) description of suite for display in runners 45 | '' 46 | Public Description As String 47 | 48 | '' 49 | ' @type Collection 50 | '' 51 | Public Tests As VBA.Collection 52 | 53 | '' 54 | ' @internal 55 | '' 56 | Public Parent As TestSuite 57 | 58 | '' 59 | ' Compute suite result from tests 60 | '' 61 | Public Property Get Result() As TestResultType 62 | Result = TestResultType.Pending 63 | 64 | Dim Test As TestCase 65 | For Each Test In Me.Tests 66 | If Test.Result = TestResultType.Pass Then 67 | Result = TestResultType.Pass 68 | ElseIf Test.Result = TestResultType.Fail Then 69 | Result = TestResultType.Fail 70 | Exit For 71 | End If 72 | Next Test 73 | End Property 74 | 75 | '' 76 | ' @type Collection 77 | '' 78 | Public Property Get PassedTests() As VBA.Collection 79 | Set PassedTests = GetTestsByType(TestResultType.Pass) 80 | End Property 81 | 82 | '' 83 | ' @type Collection 84 | '' 85 | Public Property Get FailedTests() As VBA.Collection 86 | Set FailedTests = GetTestsByType(TestResultType.Fail) 87 | End Property 88 | 89 | '' 90 | ' @type Collection 91 | '' 92 | Public Property Get PendingTests() As VBA.Collection 93 | Set PendingTests = GetTestsByType(TestResultType.Pending) 94 | End Property 95 | 96 | '' 97 | ' @type Collection 98 | '' 99 | Public Property Get SkippedTests() As VBA.Collection 100 | Set SkippedTests = GetTestsByType(TestResultType.Skipped) 101 | End Property 102 | 103 | Public Property Get Self() As TestSuite 104 | Set Self = Me 105 | End Property 106 | 107 | '' 108 | ' Create a new test case with description 109 | '' 110 | Public Function Test(Description As String) As TestCase 111 | Dim Instance As New TestCase 112 | 113 | Instance.Description = Description 114 | Set Instance.Suite = Me 115 | 116 | OnTestBefore Instance 117 | 118 | Set Test = Instance 119 | End Function 120 | 121 | '' 122 | ' Create a new group of tests with description 123 | '' 124 | Public Function Group(Description As String) As TestSuite 125 | Dim Instance As New TestSuite 126 | 127 | Instance.Description = Description 128 | Set Instance.Parent = Me 129 | 130 | RaiseEvent Group(Instance) 131 | 132 | Set Group = Instance 133 | End Function 134 | 135 | '' 136 | ' @internal 137 | '' 138 | Public Sub TestComplete(Test As TestCase) 139 | OnTestResult Test 140 | OnTestAfter Test 141 | End Sub 142 | 143 | '' 144 | ' @internal 145 | '' 146 | Public Sub OnTestBefore(Test As TestCase) 147 | If Not Me.Parent Is Nothing Then 148 | Me.Parent.OnTestBefore Test 149 | End If 150 | 151 | RaiseEvent BeforeEach(Test) 152 | End Sub 153 | 154 | '' 155 | ' @internal 156 | '' 157 | Public Sub OnTestResult(Test As TestCase) 158 | Tests.Add Test 159 | RaiseEvent Result(Test) 160 | 161 | If Not Me.Parent Is Nothing Then 162 | Me.Parent.OnTestResult Test 163 | End If 164 | End Sub 165 | 166 | '' 167 | ' @internal 168 | '' 169 | Public Sub OnTestAfter(Test As TestCase) 170 | RaiseEvent AfterEach(Test) 171 | 172 | If Not Me.Parent Is Nothing Then 173 | Me.Parent.OnTestAfter Test 174 | End If 175 | End Sub 176 | 177 | ' ============================================= ' 178 | 179 | Private Function GetTestsByType(ResultType As TestResultType) As VBA.Collection 180 | Dim Test As TestCase 181 | Dim Filtered As New VBA.Collection 182 | For Each Test In Me.Tests 183 | If Test.Result = ResultType Then 184 | Filtered.Add Test 185 | End If 186 | Next Test 187 | 188 | Set GetTestsByType = Filtered 189 | End Function 190 | 191 | 192 | Private Sub Class_Initialize() 193 | Set Tests = New VBA.Collection 194 | End Sub 195 | -------------------------------------------------------------------------------- /tests/Tests_TestCase.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "Tests_TestCase" 2 | Public Sub RunTests(Suite As TestSuite) 3 | Dim Tests As New TestSuite 4 | Dim Test As TestCase 5 | Dim A As Variant 6 | Dim B As Variant 7 | 8 | With Suite.Test("should pass if all assertions pass") 9 | Set Test = Tests.Test("should pass") 10 | With Test 11 | .IsEqual "A", "A" 12 | .IsEqual 2, 2 13 | End With 14 | 15 | .IsEqual Test.Result, TestResultType.Pass 16 | End With 17 | 18 | With Suite.Test("should fail if any assertion fails") 19 | Set Test = Tests.Test("should fail") 20 | With Test 21 | .IsEqual "A", "A" 22 | .IsEqual 2, 1 23 | End With 24 | 25 | .IsEqual Test.Result, TestResultType.Fail 26 | End With 27 | 28 | With Suite.Test("should contain collection of failures") 29 | Set Test = Tests.Test("should have failures") 30 | With Test 31 | .IsEqual "A", "A" 32 | .IsEqual 2, 1 33 | .IsEqual True, False 34 | End With 35 | 36 | .IsEqual Test.Failures(1), "Expected 2 to equal 1" 37 | .IsEqual Test.Failures(2), "Expected True to equal False" 38 | End With 39 | 40 | With Suite.Test("should be pending if there are no assertions") 41 | Set Test = Tests.Test("pending") 42 | .IsEqual Test.Result, TestResultType.Pending 43 | End With 44 | 45 | With Suite.Test("should skip even with failed assertions") 46 | Set Test = Tests.Test("skipped") 47 | With Test 48 | .IsEqual 2, 1 49 | .Skip 50 | End With 51 | 52 | .IsEqual Test.Result, TestResultType.Skipped 53 | End With 54 | 55 | With Suite.Test("should explicitly pass test") 56 | Set Test = Tests.Test("pass") 57 | With Test 58 | .IsEqual 2, 1 59 | .Pass 60 | End With 61 | 62 | .IsEqual Test.Result, TestResultType.Pass 63 | End With 64 | 65 | With Suite.Test("should explicitly fail test") 66 | Set Test = Tests.Test("fail") 67 | With Test 68 | .IsEqual 2, 2 69 | .Fail 70 | End With 71 | 72 | .IsEqual Test.Result, TestResultType.Fail 73 | End With 74 | 75 | With Suite.Test("should fail if plan doesn't match") 76 | Set Test = Tests.Test("plan") 77 | With Test 78 | .Plan 2 79 | .IsEqual 2, 2 80 | End With 81 | 82 | .IsEqual Test.Result, TestResultType.Fail 83 | End With 84 | 85 | PassingAssertions Suite 86 | FailingAssertions Suite 87 | End Sub 88 | 89 | Sub PassingAssertions(Suite As TestSuite) 90 | With Suite.Test("IsEqual") 91 | .IsEqual 1, 1 92 | .IsEqual 1.2, 1.2 93 | .IsEqual True, True 94 | .IsEqual Array(1, 2, 3), Array(1, 2, 3) 95 | 96 | Set A = New Collection 97 | A.Add 1 98 | A.Add 2 99 | 100 | Set B = New Collection 101 | B.Add 1 102 | B.Add 2 103 | 104 | .IsEqual A, B 105 | 106 | Set A = New Dictionary 107 | A("a") = 1 108 | A("b") = 2 109 | 110 | Set B = New Dictionary 111 | B("a") = 1 112 | B("b") = 2 113 | 114 | .IsEqual A, B 115 | End With 116 | 117 | With Suite.Test("NotEqual") 118 | .NotEqual 1, 2 119 | .NotEqual 1.2, 1.1 120 | .NotEqual True, False 121 | .NotEqual Array(1, 2, 3), Array(3, 2, 1) 122 | 123 | Set A = New Collection 124 | A.Add 1 125 | A.Add 2 126 | 127 | Set B = New Collection 128 | B.Add 2 129 | B.Add 1 130 | 131 | .NotEqual A, B 132 | 133 | Set A = New Dictionary 134 | A("a") = 1 135 | A("b") = 2 136 | 137 | Set B = New Dictionary 138 | B("a") = 2 139 | B("b") = 1 140 | 141 | .NotEqual A, B 142 | End With 143 | 144 | With Suite.Test("IsOk") 145 | .IsOk True 146 | .IsOk 4 147 | End With 148 | 149 | With Suite.Test("NotOk") 150 | .NotOk False 151 | .NotOk 0 152 | End With 153 | 154 | With Suite.Test("IsUndefined") 155 | .IsUndefined 156 | .IsUndefined Nothing 157 | .IsUndefined Null 158 | .IsUndefined Empty 159 | End With 160 | 161 | With Suite.Test("NotUndefined") 162 | .NotUndefined 4 163 | .NotUndefined True 164 | End With 165 | 166 | With Suite.Test("IsError") 167 | On Error Resume Next 168 | 169 | Err.Raise vbObjectError + 10, Description:="Error Description" 170 | .IsError Number:=vbObjectError + 10, Description:="Error Description" 171 | 172 | Err.Clear 173 | On Error GoTo 0 174 | End With 175 | 176 | With Suite.Test("NotError") 177 | .NotError 178 | End With 179 | 180 | With Suite.Test("Includes") 181 | .Includes Array(1, 2, 3), 2 182 | .Includes Array(Array(1, 2, 3), 4, 5), 2 183 | 184 | Set A = New Collection 185 | A.Add New Collection 186 | A(1).Add Array(1, 2, 3) 187 | 188 | .Includes A, 2 189 | End With 190 | 191 | With Suite.Test("NotIncludes") 192 | .NotIncludes Array(1, 2, 3), 4 193 | 194 | Set A = New Collection 195 | A.Add New Collection 196 | A(1).Add Array(1, 2, 3) 197 | 198 | .NotIncludes A, 4 199 | End With 200 | 201 | With Suite.Test("IsApproximate") 202 | .IsApproximate 1.001, 1.002, 3 203 | .IsApproximate 1.00001, 1.00004, 5 204 | End With 205 | 206 | With Suite.Test("NotApproximate") 207 | .NotApproximate 1.001, 1.009, 3 208 | End With 209 | End Sub 210 | 211 | Sub FailingAssertions(Suite As TestSuite) 212 | Dim FailingSuite As New TestSuite 213 | Dim FailingTest As TestCase 214 | Set FailingTest = FailingSuite.Test("FailingAssertions") 215 | 216 | With Suite.Test("IsEqual (fail)") 217 | ' Reset FailingTest by calling Pass 218 | FailingTest.Pass 219 | FailingTest.IsEqual 1, 2 220 | FailingTest.IsEqual Array(1, 2, 3), Array(3, 2, 1) 221 | 222 | .IsEqual FailingTest.Failures(1), "Expected 1 to equal 2" 223 | 224 | ' TODO Indentation here should be two spaces 225 | .IsEqual FailingTest.Failures(2), "Expected [" & vbNewLine & " 1," & vbNewLine & " 2," & vbNewLine & " 3" & vbNewLine & "] to equal [" & vbNewLine & " 3," & vbNewLine & " 2," & vbNewLine & " 1" & vbNewLine & "]" 226 | End With 227 | End Sub 228 | 229 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # vba-test 2 | 3 | vba-test (formerly Excel-TDD and VBA-TDD) adds testing to VBA on Windows and Mac. 4 | 5 | 6 | Donate 7 | 8 | 9 | ## Example 10 | 11 | ```vb 12 | Function AddTests() As TestSuite 13 | Set AddTests = New TestSuite 14 | AddTests.Description = "Add" 15 | 16 | ' Report results to the Immediate Window 17 | ' (ctrl + g or View > Immediate Window) 18 | Dim Reporter As New ImmediateReporter 19 | Reporter.ListenTo AddTests 20 | 21 | With AddTests.Test("should add two numbers") 22 | .IsEqual Add(2, 2), 4 23 | .IsEqual Add(3, -1), 2 24 | .IsEqual Add(-1, -2), -3 25 | End With 26 | 27 | With AddTests.Test("should add any number of numbers") 28 | .IsEqual Add(1, 2, 3), 6 29 | .IsEqual Add(1, 2, 3, 4), 10 30 | End With 31 | End Function 32 | 33 | Public Function Add(ParamArray Values() As Variant) As Double 34 | Dim i As Integer 35 | Add = 0 36 | 37 | For i = LBound(Values) To UBound(Values) 38 | Add = Add + Values(i) 39 | Next i 40 | End Function 41 | 42 | ' Immediate Window: 43 | ' 44 | ' === Add === 45 | ' + should add two numbers 46 | ' + should add any number of numbers 47 | ' = PASS (2 of 2 passed) = 48 | ``` 49 | 50 | For details of the process of reaching this example, see the [TDD Example](https://github.com/VBA-tools/VBA-TDD/wiki/TDD-Example) 51 | 52 | ## Advanced Example 53 | 54 | For an advanced example of what is possible with vba-test, check out the [tests for VBA-Web](https://github.com/VBA-tools/VBA-Web/tree/master/specs) 55 | 56 | ## Getting Started 57 | 58 | 1. Download the [latest release (v2.0.0-beta.3)](https://github.com/vba-tools/vba-test/releases) 59 | 2. Add `src/TestSuite.cls`, `src/TestCase.cls`, add `src/ImmediateReporter.cls` to your project 60 | 3. If you're starting from scratch with Excel, you can use `vba-test-blank.xlsm` 61 | 62 | If you're updating from Excel-TDD v1, follow these [upgrade details](https://github.com/VBA-tools/vba-test/pull/23#issuecomment-416606307). 63 | 64 | ## TestSuite 65 | 66 | A test suite groups tests together, runs test hooks for actions that should be run before and after tests, and is responsible for passing test results to reporters. 67 | 68 | ```vb 69 | ' Create a new test suite 70 | Dim Suite As New TestSuite 71 | Suite.Description = "Module Name" 72 | 73 | ' Create a new test 74 | Dim Test As TestCase 75 | Set Test = Suite.Test("Test Name") 76 | Test.IsEqual ' ... 77 | 78 | ' or create and use test using With 79 | With Suite.Test("Test Name") 80 | .IsEqual '... 81 | End With 82 | ``` 83 | 84 | __TestSuite API__ 85 | 86 | - `Description` 87 | - `Test(Name) As TestCase` 88 | - _Event_ `BeforeEach(Test)` 89 | - _Event_ `Result(Test)` 90 | - _Event_ `AfterEach(Test)` 91 | 92 | ## TestCase 93 | 94 | A test case uses assertions to test a specific part of your application. 95 | 96 | ```vb 97 | With Suite.Test("specific part of your application") 98 | .IsEqual A, B, "(optional message, e.g. result should be 12)" 99 | .NotEqual B, C 100 | 101 | .IsOk C > B 102 | .NotOk B > C 103 | 104 | .IsUndefined ' Checks Nothing, Empty, Missing, or Null 105 | .NotUndefined 106 | 107 | .Includes Array(1, 2, 3), 2 108 | .NotIncludes Array(1, 2, 3), 4 109 | .IsApproximate 1.001, 1.002, 2 110 | .NotApproximate 1.001, 1.009, 3 111 | 112 | On Error Resume Next 113 | 114 | Err.Raise vbObjectError + 1, Description:="Uh oh." 115 | .IsError Description:="Uh oh." 116 | 117 | Err.Clear 118 | .NotError 119 | 120 | .Pass 121 | .Fail "e.g. should not have gotten here" 122 | .Plan 4 ' Should only be 4 assertions, more or less fails 123 | .Skip ' skip this test 124 | End With 125 | 126 | With Suite.Test("complex things") 127 | .IsEqual _ 128 | ThisWorkbook.Sheets("Hidden").Visible, _ 129 | XlSheetVisibility.xlSheetVisible 130 | .IsEqual _ 131 | ThisWorkbook.Sheets("Main").Cells(1, 1).Interior.Color, _ 132 | RGB(255, 0, 0) 133 | End With 134 | ``` 135 | 136 | In addition to these basic assertions, custom assertions can be made by passing the `TestCase` to an assertion function 137 | 138 | ```vb 139 | Sub ToBeWithin(Test As TestCase, Value As Variant, Min As Variant, Max As Variant) 140 | Dim Message As String 141 | Message = "Expected " & Value & " to be within " & Min & " and " & Max 142 | 143 | Test.IsOk Value >= Min, Message 144 | Test.IsOk Value <= Max, Message 145 | End Sub 146 | 147 | With Suite.Test("...") 148 | ToBeWithin(.Self, Value, 0, 100) 149 | End With 150 | ``` 151 | 152 | __TestCase API__ 153 | 154 | - `Test.Name` 155 | - `Test.Self` - Reference to test case (useful inside of `With`) 156 | - `Test.Context` - `Dictionary` holding test context (useful for `BeforeEach`/`AfterEach`) 157 | - `Test.IsEqual(A, B, [Message])` 158 | - `Test.NotEqual(A, B, [Message])` 159 | - `Test.IsOk(Value, [Message])` 160 | - `Test.NotOk(Value, [Message])` 161 | - `Test.IsUndefined(Value, [Message])` 162 | - `Test.NotUndefined(Value, [Message])` 163 | - `Test.Includes(Values, Value, [Message])` - Check if value is included in array or `Collection` 164 | - `Test.NotIncludes(Values, Value, [Message])` 165 | - `Test.IsApproximate(A, B, SignificantFigures, [Message])` - Check if two values are close to each other (useful for `Double` values) 166 | - `Test.NotApproximate(A, B, SignificantFigures, [Message])` 167 | - `Test.IsError([Number], [Source], [Description], [Message])` - Check if `Err` contains an error 168 | - `Test.NotError([Message])` 169 | - `Test.Pass()` - Explicitly pass the test 170 | - `Test.Fail([Message])` - Explicitly fail the test 171 | - `Test.Plan(Count)` - For tests with loops and branches, it is important to catch if any assertions are skipped or extra 172 | - `Test.Skip()` - Notify suite to skip this test 173 | 174 | ## ImmediateReporter 175 | 176 | With your tests defined, the easiest way to display the test results is with `ImmediateReporter`. This outputs results to the Immediate Window (`ctrl+g` or View > Immediate Window) and is useful for running your tests without leaving the VBA editor. 177 | 178 | ```vb 179 | Public Function Suite As TestSuite 180 | Set Suite = New TestSuite 181 | Suite.Description = "..." 182 | 183 | ' Create reporter and attach it to these specs 184 | Dim Reporter As New ImmediateReporter 185 | Reporter.ListenTo Suite 186 | 187 | ' -> Reporter will now output results as they are generated 188 | End Function 189 | ``` 190 | 191 | ## Context / Lifecycle Hooks 192 | 193 | `TestSuite` includes events for setup and teardown before tests and a `Context` object for passing values into tests that are properly torn down between tests. 194 | 195 | ```vb 196 | ' Class TestFixture 197 | Private WithEvents pSuite As TestSuite 198 | 199 | Public Sub ListenTo(Suite As TestSuite) 200 | Set pSuite = Suite 201 | End Sub 202 | 203 | Private Sub pSuite_BeforeEach(Test As TestCase) 204 | Test.Context.Add "fixture", New Collection 205 | End Sub 206 | 207 | Private Sub pSuite_AfterEach(Test As TestCase) 208 | ' Context is cleared automatically, 209 | ' but can manually cleanup here 210 | End Sub 211 | 212 | ' Elsewhere 213 | 214 | Dim Suite As New TestSuite 215 | 216 | Dim Fixture As New TestFixture 217 | Fixture.ListenTo Suite 218 | 219 | With Suite.Test("...") 220 | .Context("fixture").Add "..." 221 | End With 222 | ``` 223 | -------------------------------------------------------------------------------- /src/TestCase.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "TestCase" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = True 10 | '' 11 | ' # TestCase 12 | ' 13 | ' Verify a single test case with assertions 14 | ' 15 | ' ```vba 16 | ' Dim Test As New TestCase 17 | ' 18 | ' Test.Description = "should add many numbers 19 | ' With Test 20 | ' .IsEqual Add(2, 2), 4 21 | ' .IsEqual Add(1, 2, 3), 6 22 | ' End With 23 | ' ``` 24 | ' 25 | ' @class TestCase 26 | ' @author tim.hall.engr@gmail.com 27 | ' @repository https://github.com/vba-tools/vba-test 28 | ' @license MIT 29 | '' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' 30 | Option Explicit 31 | 32 | Private pFailures As VBA.Collection 33 | 34 | '' 35 | ' Set test description as displayed in reporter 36 | '' 37 | Public Description As String 38 | 39 | '' 40 | ' Get/set values for test context 41 | ' (useful for passing values to BeforeEach/AfterEach) 42 | '' 43 | Public Context As Dictionary 44 | 45 | '' 46 | ' @internal 47 | '' 48 | Public Planned As Long 49 | 50 | '' 51 | ' @internal 52 | '' 53 | Public Successes As Long 54 | 55 | '' 56 | ' @internal 57 | '' 58 | Public Skipped As Boolean 59 | 60 | '' 61 | ' @internal 62 | '' 63 | Public Suite As TestSuite 64 | 65 | Public Property Get Result() As TestResultType 66 | If Me.Skipped Then 67 | Result = TestResultType.Skipped 68 | ElseIf Me.Successes = 0 And Me.Failures.Count = 0 Then 69 | Result = TestResultType.Pending 70 | ElseIf Me.Failures.Count > 0 Then 71 | Result = TestResultType.Fail 72 | Else 73 | Result = TestResultType.Pass 74 | End If 75 | End Property 76 | 77 | Public Property Get Failures() As VBA.Collection 78 | Dim Total As Long 79 | Total = Me.Successes + pFailures.Count 80 | 81 | If Me.Planned > 0 And Me.Planned <> Total Then 82 | Dim Message As String 83 | Dim Failure As Variant 84 | 85 | Set Failures = New VBA.Collection 86 | For Each Failure In pFailures 87 | Failures.Add Failure 88 | Next Failure 89 | 90 | Message = "Total assertions, {0}, does not equal planned, {1}" 91 | Failures.Add FormatMessage(Message, Total, Me.Planned) 92 | Else 93 | Set Failures = pFailures 94 | End If 95 | End Property 96 | 97 | '' 98 | ' Access test instance (e.g. for passing to custom matchers) 99 | '' 100 | Public Property Get Self() As TestCase 101 | Self = Me 102 | End Property 103 | 104 | '' 105 | ' Check if two values are deep equal (including Array, Collection, and Dictionary) 106 | '' 107 | Public Sub IsEqual(A As Variant, B As Variant, Optional Message As String = _ 108 | "Expected {0} to equal {1}") 109 | 110 | Check IsDeepEqual(A, B), Message, A, B 111 | End Sub 112 | 113 | '' 114 | ' Check if two values are not deep equal (including Array, Collection, and Dictionary) 115 | '' 116 | Public Sub NotEqual(A As Variant, B As Variant, Optional Message As String = _ 117 | "Expected {0} to not equal {1}") 118 | 119 | Check Not IsDeepEqual(A, B), Message, A, B 120 | End Sub 121 | 122 | '' 123 | ' Check if a value is "truthy" 124 | ' 125 | ' From https://docs.microsoft.com/en-us/dotnet/visual-basic/language-reference/statements/if-then-else-statement 126 | ' 127 | ' Must evaluate to True or False, or to a data type that is implicitly convertible to Boolean. 128 | ' If the expression is a Nullable Boolean variable that evaluates to Nothing, the condition is treated as if the expression is False. 129 | '' 130 | Public Sub IsOk(Value As Variant, Optional Message As String = _ 131 | "Expected {0} to be ok") 132 | 133 | Check Value, Message, Value 134 | End Sub 135 | 136 | '' 137 | ' Check if a value is not "truthy" (See .IsOk) 138 | '' 139 | Public Sub NotOk(Value As Variant, Optional Message As String = _ 140 | "Expected {0} to not be ok") 141 | 142 | Check Not CBool(Value), Message, Value 143 | End Sub 144 | 145 | '' 146 | ' Check if a value is "undefined": Nothing, Empty, Null, or Missing 147 | '' 148 | Public Sub IsUndefined(Optional Value As Variant, Optional Message As String = _ 149 | "Expected {0} to be undefined") 150 | 151 | Check IsNothing(Value) Or VBA.IsEmpty(Value) Or VBA.IsNull(Value) Or VBA.IsMissing(Value), Message, Value 152 | End Sub 153 | 154 | '' 155 | ' Check if a value is not "undefined": Nothing, Empty, Null, or Missing 156 | '' 157 | Public Sub NotUndefined(Value As Variant, Optional Message As String = _ 158 | "Expected {0} to not be undefined") 159 | 160 | Check Not IsNothing(Value) And Not VBA.IsEmpty(Value) And Not VBA.IsNull(Value) And Not VBA.IsMissing(Value), Message, Value 161 | End Sub 162 | 163 | '' 164 | ' Check if the current Err value contains an error with values (if given) 165 | '' 166 | Public Sub IsError(Optional Number As Long, Optional Source As String, Optional Description As String, Optional Message As String = _ 167 | "Expected {0} to be an error (with Number = {1}, Source = {2}, Description = {3}") 168 | 169 | If Err.Number = 0 Then 170 | pFailures.Add FormatMessage(Message, "[Error Number=0]", Number, Source, Description) 171 | Exit Sub 172 | End If 173 | 174 | Check (Number = 0 Or Err.Number = Number) _ 175 | And (Source = "" Or Err.Source = Source) _ 176 | And (Description = "" Or Err.Description = Description), Message, FormattedErr, Number, Source, Description 177 | End Sub 178 | 179 | '' 180 | ' Check if the current Err value does not contain an error 181 | '' 182 | Public Sub NotError(Optional Message As String = "Expected {0} to not be an error") 183 | Check Err.Number = 0, Message, FormattedErr 184 | End Sub 185 | 186 | '' 187 | ' Check if a value is included in an arbitrarily nested Array or Collection 188 | '' 189 | Public Sub Includes(Values As Variant, Value As Variant, Optional Message As String = _ 190 | "Expected {1} to be included in {0}") 191 | 192 | If IsCollection(Values) Then 193 | Check CollectionIncludes(Values, Value), Message, Values, Value 194 | ElseIf IsArray(Values) Then 195 | Check ArrayIncludes(Values, Value), Message, Values, Value 196 | Else 197 | pFailures.Add FormatMessage(Message, Values, Value) & " (Incompatible type for Values)" 198 | End If 199 | End Sub 200 | 201 | '' 202 | ' Check if a value is not included in an arbitrarily nested Array or Collection 203 | '' 204 | Public Sub NotIncludes(Values As Variant, Value As Variant, Optional Message As String = _ 205 | "Expected {1} not to be included in {0}") 206 | 207 | If IsCollection(Values) Then 208 | Check Not CollectionIncludes(Values, Value), Message, Values, Value 209 | ElseIf IsArray(Values) Then 210 | Check Not ArrayIncludes(Values, Value), Message, Values, Value 211 | Else 212 | pFailures.Add FormatMessage(Message, Values, Value) & " (Incompatible type for Values)" 213 | End If 214 | End Sub 215 | 216 | '' 217 | ' Check if two values are approximately equal, up to the given amount of significant figures 218 | ' 219 | ' ```vba 220 | ' .IsApproximate 1.001, 1.002, 3 221 | ' 222 | ' ' Equivalent to .IsEqual 1.00e+0, 1.00e+0 223 | ' ``` 224 | '' 225 | Public Sub IsApproximate(A As Variant, B As Variant, SignificantFigures As Integer, Optional Message As String = _ 226 | "Expected {0} to be approximately equal to {1} (with {2} significant figures of precision)") 227 | 228 | If SignificantFigures < 1 Or SignificantFigures > 15 Then 229 | pFailures.Add "IsApproximate can only compare from 1 to 15 significant figures" 230 | Else 231 | Check IsApproximatelyEqual(A, B, SignificantFigures), Message, A, B, SignificantFigures 232 | End If 233 | End Sub 234 | 235 | '' 236 | ' Check if two values are approximately equal, up to the given amount of significant figures 237 | ' 238 | ' ```vba 239 | ' .NotApproximate 1.001, 1.009, 3 240 | ' 241 | ' ' Equivalent to .IsEqual 1.00e+0, 1.01e+0 242 | ' ``` 243 | '' 244 | Public Sub NotApproximate(A As Variant, B As Variant, SignificantFigures As Integer, Optional Message As String = _ 245 | "Expected {0} to not be approximately equal to {1} (with {2} significant figures of precision)") 246 | 247 | If SignificantFigures < 1 Or SignificantFigures > 15 Then 248 | pFailures.Add "NotApproximate can only compare from 1 to 15 significant figures" 249 | Else 250 | Check Not IsApproximatelyEqual(A, B, SignificantFigures), Message, A, B, SignificantFigures 251 | End If 252 | End Sub 253 | 254 | '' 255 | ' Mark the test as passing 256 | '' 257 | Public Sub Pass() 258 | Me.Successes = 1 259 | Set pFailures = New VBA.Collection 260 | End Sub 261 | 262 | '' 263 | ' Mark the test as failing 264 | '' 265 | Public Sub Fail(Optional Message As String = _ 266 | "Test failed unexpectedly") 267 | 268 | pFailures.Add Message 269 | End Sub 270 | 271 | '' 272 | ' Set the planned number of assertions for the test 273 | '' 274 | Public Sub Plan(Count As Long) 275 | Planned = Count 276 | End Sub 277 | 278 | '' 279 | ' Mark the test as skipped 280 | '' 281 | Public Sub Skip() 282 | Me.Skipped = True 283 | End Sub 284 | 285 | ' ============================================= ' 286 | 287 | Private Sub Check(Assertion As Variant, Message As String, ParamArray Values() As Variant) 288 | If Assertion Then 289 | Me.Successes = Me.Successes + 1 290 | Else 291 | pFailures.Add FormatMessage(Message, Values) 292 | End If 293 | End Sub 294 | 295 | Private Function IsDeepEqual(A As Variant, B As Variant) As Boolean 296 | Dim AType As VbVarType 297 | Dim BType As VbVarType 298 | 299 | AType = VBA.VarType(A) 300 | BType = VBA.VarType(B) 301 | 302 | If VBA.IsError(A) Or VBA.IsError(B) Then 303 | IsDeepEqual = False 304 | 305 | ElseIf VBA.IsArray(A) And VBA.IsArray(B) Then 306 | IsDeepEqual = IsArrayEqual(A, B) 307 | 308 | ElseIf AType = VBA.vbObject Or BType = VBA.vbObject Then 309 | If AType <> BType Or VBA.TypeName(A) <> VBA.TypeName(B) Then 310 | IsDeepEqual = False 311 | ElseIf VBA.TypeName(A) = "Collection" Then 312 | IsDeepEqual = IsCollectionEqual(A, B) 313 | ElseIf VBA.TypeName(A) = "Dictionary" Then 314 | IsDeepEqual = IsDictionaryEqual(A, B) 315 | Else 316 | IsDeepEqual = A Is B 317 | End If 318 | 319 | ElseIf VBA.VarType(A) = VBA.vbDouble Or VBA.VarType(B) = VBA.vbDouble Then 320 | ' It is inherently difficult/almost impossible to check equality of Double 321 | ' http://support.microsoft.com/kb/78113 322 | ' 323 | ' -> Compare up to 15 significant figures 324 | IsDeepEqual = IsApproximatelyEqual(A, B, 15) 325 | 326 | Else 327 | IsDeepEqual = A = B 328 | End If 329 | End Function 330 | 331 | Private Function IsArrayEqual(A As Variant, B As Variant) As Boolean 332 | If UBound(A) <> UBound(B) Then 333 | IsArrayEqual = False 334 | Exit Function 335 | End If 336 | 337 | Dim i As Long 338 | For i = LBound(A) To UBound(A) 339 | If Not IsDeepEqual(A(i), B(i)) Then 340 | IsArrayEqual = False 341 | Exit Function 342 | End If 343 | Next i 344 | 345 | IsArrayEqual = True 346 | End Function 347 | 348 | Private Function IsCollectionEqual(A As Variant, B As Variant) As Boolean 349 | If A.Count <> B.Count Then 350 | IsCollectionEqual = False 351 | Exit Function 352 | End If 353 | 354 | Dim i As Long 355 | For i = 1 To A.Count 356 | If Not IsDeepEqual(A(i), B(i)) Then 357 | IsCollectionEqual = False 358 | Exit Function 359 | End If 360 | Next i 361 | 362 | IsCollectionEqual = True 363 | End Function 364 | 365 | Private Function IsDictionaryEqual(A As Variant, B As Variant) As Boolean 366 | If UBound(A.Keys) <> UBound(B.Keys) Then 367 | IsDictionaryEqual = False 368 | Exit Function 369 | End If 370 | 371 | Dim AKeys As Variant 372 | Dim BKeys As Variant 373 | Dim i As Long 374 | 375 | AKeys = A.Keys 376 | BKeys = B.Keys 377 | 378 | For i = LBound(AKeys) To UBound(AKeys) 379 | If AKeys(i) <> BKeys(i) Or A.Item(AKeys(i)) <> B.Item(BKeys(i)) Then 380 | IsDictionaryEqual = False 381 | Exit Function 382 | End If 383 | Next i 384 | 385 | IsDictionaryEqual = True 386 | End Function 387 | 388 | Private Function IsCollection(Value As Variant) As Boolean 389 | IsCollection = VBA.VarType(Value) = VBA.vbObject And VBA.TypeName(Value) = "Collection" 390 | End Function 391 | 392 | Private Function IsNothing(Value As Variant) As Boolean 393 | If VBA.IsObject(Value) Then 394 | IsNothing = Value Is Nothing 395 | Else 396 | IsNothing = False 397 | End If 398 | End Function 399 | 400 | Private Function ArrayIncludes(Values As Variant, Value As Variant) As Boolean 401 | Dim i As Long 402 | For i = LBound(Values) To UBound(Values) 403 | If VBA.IsArray(Values(i)) Then 404 | If ArrayIncludes(Values(i), Value) Then 405 | ArrayIncludes = True 406 | Exit Function 407 | End If 408 | ElseIf IsCollection(Values(i)) Then 409 | If CollectionIncludes(Values(i), Value) Then 410 | ArrayIncludes = True 411 | Exit Function 412 | End If 413 | ElseIf IsDeepEqual(Values(i), Value) Then 414 | ArrayIncludes = True 415 | Exit Function 416 | End If 417 | Next i 418 | 419 | ArrayIncludes = False 420 | End Function 421 | 422 | Private Function CollectionIncludes(Values As Variant, Value As Variant) As Boolean 423 | Dim Item As Variant 424 | For Each Item In Values 425 | If VBA.IsArray(Item) Then 426 | If ArrayIncludes(Item, Value) Then 427 | CollectionIncludes = True 428 | Exit Function 429 | End If 430 | ElseIf IsCollection(Item) Then 431 | If CollectionIncludes(Item, Value) Then 432 | CollectionIncludes = True 433 | Exit Function 434 | End If 435 | ElseIf IsDeepEqual(Item, Value) Then 436 | CollectionIncludes = True 437 | Exit Function 438 | End If 439 | Next Item 440 | 441 | CollectionIncludes = False 442 | End Function 443 | 444 | Private Function IsApproximatelyEqual(A As Variant, B As Variant, SignificantFigures As Integer) As Boolean 445 | If SignificantFigures < 1 Or SignificantFigures > 15 Or VBA.IsError(A) Or VBA.IsError(B) Then 446 | IsApproximatelyEqual = False 447 | Exit Function 448 | End If 449 | 450 | Dim AValue As String 451 | Dim BValue As String 452 | 453 | AValue = VBA.Format$(A, VBA.Left$("0.00000000000000", SignificantFigures + 1) & IIf(A > 1, "e+0", "e-0")) 454 | BValue = VBA.Format$(B, VBA.Left$("0.00000000000000", SignificantFigures + 1) & IIf(B > 1, "e+0", "e-0")) 455 | 456 | IsApproximatelyEqual = AValue = BValue 457 | End Function 458 | 459 | Private Function FormatMessage(Message As String, ParamArray Values() As Variant) As String 460 | Dim Value As Variant 461 | Dim Index As Long 462 | 463 | FormatMessage = Message 464 | For Each Value In IIf(VBA.IsArray(Values(0)), Values(0), Values) 465 | FormatMessage = VBA.Replace(FormatMessage, "{" & Index & "}", PrettyPrint(Value)) 466 | Index = Index + 1 467 | Next Value 468 | End Function 469 | 470 | Private Function PrettyPrint(Value As Variant, Optional Indentation As Long = 0) As String 471 | If VBA.IsMissing(Value) Then 472 | PrettyPrint = "[Missing]" 473 | Exit Function 474 | End If 475 | 476 | Dim i As Long 477 | Dim Indented As String 478 | Indented = VBA.String$(Indentation + 1, " ") 479 | 480 | Select Case VBA.VarType(Value) 481 | Case VBA.vbObject 482 | ' Nothing 483 | If Value Is Nothing Then 484 | PrettyPrint = "[Nothing]" 485 | 486 | ' Collection 487 | ElseIf VBA.TypeName(Value) = "Collection" Then 488 | PrettyPrint = "[Collection [" & vbNewLine 489 | 490 | For i = 1 To Value.Count 491 | PrettyPrint = PrettyPrint & Indent(Indentation + 1) & _ 492 | PrettyPrint(Value(i), Indentation + 1) & _ 493 | IIf(i <> Value.Count, ",", "") & vbNewLine 494 | Next i 495 | 496 | PrettyPrint = PrettyPrint & Indent(Indentation) & "]" 497 | 498 | ' Dictionary 499 | ElseIf VBA.TypeName(Value) = "Dictionary" Then 500 | PrettyPrint = "[Dictionary {" & vbNewLine 501 | 502 | For i = LBound(Value.Keys) To UBound(Value.Keys) 503 | PrettyPrint = PrettyPrint & Indent(Indentation + 1) & _ 504 | Value.Keys(i) & ": " & _ 505 | PrettyPrint(Value.Item(Value.Keys(i)), Indentation + 1) & _ 506 | IIf(i <> Value.Count, ",", "") & vbNewLine 507 | Next i 508 | 509 | PrettyPrint = PrettyPrint & Indent(Indentation) & "}]" 510 | 511 | ' Object 512 | Else 513 | PrettyPrint = "[" & VBA.TypeName(Value) & "]" 514 | End If 515 | 516 | ' Array 517 | Case VBA.vbArray To VBA.vbArray + VBA.vbByte 518 | PrettyPrint = "[" & vbNewLine 519 | 520 | For i = LBound(Value) To UBound(Value) 521 | PrettyPrint = PrettyPrint & Indent(Indentation + 1) & _ 522 | PrettyPrint(Value(i), Indentation + 1) & _ 523 | IIf(i <> UBound(Value), ",", "") & vbNewLine 524 | Next i 525 | 526 | PrettyPrint = PrettyPrint & Indent(Indentation) & "]" 527 | 528 | ' Empty 529 | Case VBA.vbEmpty 530 | PrettyPrint = "[Empty]" 531 | 532 | ' Null 533 | Case VBA.vbNull 534 | PrettyPrint = "[Null]" 535 | 536 | ' String 537 | Case VBA.vbString 538 | PrettyPrint = """" & Value & """" 539 | 540 | ' Everything else 541 | Case Else 542 | PrettyPrint = CStr(Value) 543 | End Select 544 | End Function 545 | 546 | Private Function FormattedErr() As String 547 | Dim ErrNumberDetails As String 548 | 549 | ErrNumberDetails = IIf(Err.Number < 0, " (" & (Err.Number - vbObjectError) & " / " & VBA.LCase$(VBA.Hex$(Err.Number)) & ")", "") 550 | FormattedErr = "[Error Number=" & Err.Number & ErrNumberDetails & ", Source=" & Err.Source & ", Description=" & Err.Description & "]" 551 | End Function 552 | 553 | Private Function Indent(Optional Indentation As Long) 554 | Indent = VBA.String$(Indentation, " ") 555 | End Function 556 | 557 | Private Sub Class_Initialize() 558 | Set Me.Context = New Dictionary 559 | Set pFailures = New VBA.Collection 560 | End Sub 561 | 562 | Private Sub Class_Terminate() 563 | Me.Suite.TestComplete Me 564 | Set Me.Context = Nothing 565 | End Sub 566 | --------------------------------------------------------------------------------