gambas-source-code/.src/Runner/source\COMUnitRunner\ctlTrace.ctl
2015-01-30 07:46:43 +01:00

162 lines
5.5 KiB
Text

VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.UserControl ctlTrace
ClientHeight = 3660
ClientLeft = 0
ClientTop = 0
ClientWidth = 6270
ScaleHeight = 3660
ScaleWidth = 6270
Begin MSComctlLib.ImageList imlIcons
Left = 4680
Top = 1080
_ExtentX = 1005
_ExtentY = 1005
BackColor = -2147483643
ImageWidth = 16
ImageHeight = 16
MaskColor = 12632256
_Version = 393216
BeginProperty Images {2C247F25-8591-11D1-B16A-00C0F0283628}
NumListImages = 4
BeginProperty ListImage1 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "ctlTrace.ctx":0000
Key = ""
EndProperty
BeginProperty ListImage2 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "ctlTrace.ctx":0352
Key = ""
EndProperty
BeginProperty ListImage3 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "ctlTrace.ctx":06A4
Key = ""
EndProperty
BeginProperty ListImage4 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "ctlTrace.ctx":09F6
Key = ""
EndProperty
EndProperty
End
Begin MSComctlLib.TreeView tvTrace
Height = 3375
Left = 0
TabIndex = 0
Top = 0
Width = 4455
_ExtentX = 7858
_ExtentY = 5953
_Version = 393217
LabelEdit = 1
Style = 7
ImageList = "imlIcons"
Appearance = 1
End
End
Attribute VB_Name = "ctlTrace"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
' The UnitTrace control is used to trace the progress and status of the executing test cases.
' The control displays all trace messages associated with each executing test case and groups
' them in a tree. Test cases that execute successfully are identified with a green ball.
' Test cases that contain failures receive a yellow ball, and test cases with errors receive
' a red ball. The UnitTrace control is useful if detailed information on the running tests is
' required.
' Constants
Const g_lOKImage = 1
Const g_lFailureImage = 2
Const g_lErrorImage = 3
' Member variables
Private WithEvents m_oTestResult As TestResult
Attribute m_oTestResult.VB_VarHelpID = -1
Private m_oTestCase As ITestCase
Private m_objRoot As Node
' Class destructor
Private Sub Class_Terminate()
Set m_oTestResult = Nothing
Set m_oTestCase = Nothing
End Sub
' Set the TestResult to be used for capturing the results of running the tests.
Public Property Set TestResult(oTestResult As TestResult)
Set m_oTestResult = oTestResult
End Property
Private Sub UserControl_Resize()
tvTrace.Width = ScaleWidth
tvTrace.Height = ScaleHeight
End Sub
' Resets the UnitTrace control clearing the results of the last test run.
Public Sub Reset()
tvTrace.Nodes.Clear
Set m_objRoot = tvTrace.Nodes.Add(Text:="Tests", Image:=4)
m_objRoot.Expanded = True
End Sub
Private Sub m_oTestResult_AfterStartTest(oTestCase As ITestCase)
Dim oNode As Node
Set oNode = tvTrace.Nodes.Add(m_objRoot.Index, tvwChild, TestName(oTestCase), TestName(oTestCase), g_lOKImage)
tvTrace.Nodes.Add oNode.Index, tvwChild, , "Start Test Case", g_lOKImage
Set m_oTestCase = oTestCase
DoEvents
End Sub
Private Sub m_oTestResult_AfterEndTest()
Dim oNode As Node
Set oNode = tvTrace.Nodes(TestName(m_oTestCase))
tvTrace.Nodes.Add oNode.Index, tvwChild, , "End Test Case", g_lOKImage
' change top node icon depending on trace events
Dim oChildNode As Node, lImage As Long
Set oChildNode = oNode.Child
While Not (oChildNode Is Nothing)
If (CLng(oChildNode.Image) > lImage) Then
lImage = CLng(oChildNode.Image)
End If
Set oChildNode = oChildNode.Next
Wend
oNode.Image = lImage
DoEvents
End Sub
Private Sub m_oTestResult_AfterAddError(oError As TestError)
Dim oNode As Node
Set oNode = tvTrace.Nodes(TestName(oError.TestCase))
tvTrace.Nodes.Add oNode.Index, tvwChild, , "Error: " & GetErrorMsg(oError), g_lErrorImage
DoEvents
End Sub
Private Sub m_oTestResult_AfterAddFailure(oError As TestError)
Dim oNode As Node
Set oNode = tvTrace.Nodes(TestName(oError.TestCase))
tvTrace.Nodes.Add oNode.Index, tvwChild, , "Failure: " & oError.Description, g_lFailureImage
DoEvents
End Sub
Private Sub m_oTestResult_AfterAddTrace(sMessage As String)
Dim oNode As Node
Set oNode = tvTrace.Nodes(TestName(m_oTestCase))
tvTrace.Nodes.Add oNode.Index, tvwChild, , "Trace: " & sMessage, g_lOKImage
DoEvents
End Sub
Private Function GetErrorMsg(oError As TestError)
GetErrorMsg = oError.Source & " (" & Trim(oError.ErrNumber) & "): " & oError.Description
End Function
Private Function TestName(oTestCase As TestCase) As String
If (oTestCase Is Nothing) Then
TestName = ""
Else
TestName = TypeName(oTestCase.TestContainer) & "." & oTestCase.Name
End If
End Function