Sub ExportTestCasesFromALM()
Dim wd, QCConnection, sProject, sTestPlanPath, TestFolderPath, strNodeByPath
qcURL = InputBox("Please enter ALM URL", "", "http://alm.optum.com:8080/qcbin")
If qcURL = "" Then
MsgBox ("ALMURL cannot be blank")
Exit Sub
End If
sDomain = InputBox("Please enter your Domain" & vbNewLine & "Eg:CORE_SYSTEMS", "", "CORE_SYSTEMS")
If sDomain = "" Then
MsgBox ("DomainName cannot be blank")
Exit Sub
End If
sProject = InputBox("Please enter your ProjectName" & vbNewLine & "Eg:RADC;GCM(As per ALM Project)", "", "GCM")
If sProject = "" Then
MsgBox ("ProjectName cannot be blank")
Exit Sub
End If
sUser = InputBox("Please enter your Username" & vbNewLine & "Eg:MSID", "", "")
If sUser = "" Then
MsgBox ("UserName cannot be blank")
Exit Sub
End If
sPass = InputBox("Please enter your Password", "", "")
sFolderpath = InputBox("Please enter your ALM Folderpath" & vbNewLine & "<Subject\FolderStructure>", "", "Subject\RADC Project\2015\Q2_2015\May")
If sFolderpath = "" Then
MsgBox ("FolderPath cannot be blank")
Exit Sub
End If
Set QCConnection = CreateObject("TDApiOle80.TDConnection")
QCConnection.InitConnectionEx qcURL
QCConnection.ConnectProjectEx sDomain, sProject, sUser, sPass
'If (QCConnection.Connected <> True) Then
' MsgBox "QC Project Failed to Connect to " & sProject
' WScript.Quit
'End If
sTestPlanPath = "Enter QC Test PlanFolder Path"
sTestPlanPath = sTestPlanPath & (Chr(13) & Chr(10))
sTestPlanPath = sTestPlanPath & sFolderpath
'TestFolderPath = InputBox(sTestPlanPath, "Folder Path")
'Displays the Test Plan Folder Path
'MsgBox TestFolderPath
TestFolderPath = sFolderpath
'Call ExporttestCases Funtion and Pass Folder Path parameter
'Call ExportTestCases(TestFolderPath)
strNodeByPath = TestFolderPath
Dim Excel, Sheet
Set Excel = CreateObject("Excel.Application") 'Open Excel
'Excel.
'Excel.WorkBooks.Add() 'Add a new workbook
'Get the first worksheet.
Set Sheet = ActiveSheet
'sheet name as Tests
'Sheet.Name = "Tests"
'Specify the Excel Sheet Properties
With Sheet.Range("A1:H1")
.Font.Name = "Cambria"
.Font.FontStyle = "Bold"
.Font.Size = 12
.Font.Bold = True
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Interior.ColorIndex = 15 'Light Grey'
End With
'Excel Sheet Column Header Values
Sheet.Cells(1, 1) = "Subject"
Sheet.Cells(1, 3) = "Description"
Sheet.Cells(1, 2) = "Test Name"
Sheet.Cells(1, 4) = "Step Name"
Sheet.Cells(1, 5) = "Step Description"
Sheet.Cells(1, 6) = "Expected Result"
Sheet.Cells(1, 7) = "Level"
Sheet.Cells(1, 8) = "Designer"
Sheet.Cells(1, 9) = "Type"
Sheet.Cells(1, 10) = "TestType"
Sheet.Cells(1, 11) = "Status"
Sheet.Cells(1, 12) = "Automation Status"
Sheet.Cells(1, 13) = "Active Status"
' Sheet.Cells(1, 9) = "Application ID"
' Sheet.Cells(1, 10) = " Project Identifier"
' Sheet.Cells(1, 11) = "Count"
'Sheet.Cells(1, 3) = "Description"
' Sheet.Cells(1, 4) = "Designer "
'Sheet.Cells(1, 5) = "Status"
'Designer
'Call PrintFields(TestFactory)
Dim TreeMgr, TestTree, TestFactory, TestList
'Connection to TreeManager which Represents the System tree and containing a subject tree and all hierarchial field trees
Set TreeMgr = QCConnection.TreeManager
'Specify the folder path in TestPlan, all the tests under that folder will be exported.
'Gets the node at specified TreePath and strNodeByPath is a a Subject\.... folder path
Set TestTree = TreeMgr.NodeByPath(strNodeByPath)
'To Get the a list from all from Node, NewList will bring all the testcases from the perticular node
Set TestFactory = TestTree.TestFactory
Set TestList = TestFactory.NewList("")
'Specify Array to contain all nodes of subject tree.
Dim NodesList()
'To Protect all the Nodes specify as Preserve
ReDim Preserve NodesList(0)
'Assign root node of subject tree as NodeByPath node.
NodesList(0) = TestTree.Path
' Call sub Getnodes list which will gets subnodes and return list in array NodesList
Call GetNodesList(TestTree, NodesList)
Dim Row, Node, TestCase, Counter
'Starts saving Testcases from the 2nd Row
Row = 2
Counter = 1
For Each Node In NodesList
Set TestTree = TreeMgr.NodeByPath(Node)
Set TestFactory = TestTree.TestFactory
Set TestList = TestFactory.NewList("") 'Get a list of all from node.
'Iterate through all the tests.
For Each TestCase In TestList
Dim DesignStepFactory, DesignStep, DesignStepList
Set DesignStepFactory = TestCase.DesignStepFactory
Set DesignStepList = DesignStepFactory.NewList("")
Sheet.Cells(Row, 1).Value = TestCase.Field("TS_SUBJECT").Path
Sheet.Cells(Row, 3).Value = stripHTML(TestCase.Field("TS_DESCRIPTION"))
Sheet.Cells(Row, 2).Value = TestCase.Field("TS_NAME")
Sheet.Cells(Row, 7).Value = TestCase.Field("TS_USER_01")
Sheet.Cells(Row, 9).Value = TestCase.Field("TS_TYPE")
Sheet.Cells(Row, 10).Value = TestCase.Field("TS_USER_02")
Sheet.Cells(Row, 11).Value = TestCase.Field("TS_STATUS")
Sheet.Cells(Row, 12).Value = TestCase.Field("TS_User_04")
Sheet.Cells(Row, 13).Value = TestCase.Field("TS_User_03")
' Sheet.Cells(Row, 3).Value = stripHTML(TestCase.Field("TS_DESCRIPTION"))
' Sheet.Cells(Row, 9).Value = TestCase.Field("TS_User_02")
' Sheet.Cells(Row, 10).Value = TestCase.Field("TS_User_05")
' Sheet.Cells(Row, 11).Value = Counter
Counter = Counter + 1
If DesignStepList.Count = 0 Then
'Save a specified set of fields.
Sheet.Cells(Row, 1).Value = TestCase.Field("TS_SUBJECT").Path
Sheet.Cells(Row, 3).Value = Trim(TestCase.Field("TS_DESCRIPTION"))
Sheet.Cells(Row, 2).Value = TestCase.Field("TS_NAME")
'Sheet.Cells(Row, 4).Value = Trim(TestCase.Field("TS_DESCRIPTION"))
Sheet.Cells(Row, 7).Value = TestCase.Field("TS_USER_01")
Sheet.Cells(Row, 8).Value = TestCase.Field("TS_RESPONSIBLE")
' Sheet.Cells(Row, 5).Value = TestCase.Field("TS_STATUS")
'Sheet.Cells(Row, 9).Value = TestCase.Field("TS_User_02")
'Sheet.Cells(Row, 10).Value = TestCase.Field("TS_User_05")
Row = Row + 1
Else
Dim replaceString
replaceString = vbNewLine & vbNewLine
For Each DesignStep In DesignStepList
'Save a specified set of fields.
Sheet.Cells(Row, 1).Value = TestCase.Field("TS_SUBJECT").Path
'Sheet.Cells(Row, 2).Value = TestCase.Field("TS_DESCRIPTION")
Sheet.Cells(Row, 4).Value = stripHTML(DesignStep.StepName)
'Sheet.Cells(Row, 4).Value = Trim(stripHTML(DesignStep.StepDescription))
Sheet.Cells(Row, 5).Value = Replace(Trim(stripHTML(DesignStep.StepDescription)), replaceString, "")
'Sheet.Cells(Row, 4).Value = Trim(Sheet.Cells(Row, 4).Value)
'Save the specified design steps.
'Sheet.Cells(Row, 5).Value = stripHTML(DesignStep.StepExpectedResult)
Sheet.Cells(Row, 6).Value = Replace(Trim(stripHTML(DesignStep.StepExpectedResult)), replaceString, "")
'Sheet.Cells(Row, 7).Value = TestCase.Field("TS_USER_01")
Sheet.Cells(Row, 8).Value = TestCase.Field("TS_RESPONSIBLE")
Row = Row + 1
Next
End If
Next
Next
'Call PrintFields(DesignStepFactory)
'Excel.Columns.AutoFit
'Set the Column width for the following columns.
'Excel.Columns("C").ColumnWidth = 80 'Description
'Excel.Columns("G").ColumnWidth = 80 'Step Description(Action)
'Excel.Columns("H").ColumnWidth = 80 'Expected Result
'Set Auto Filter mode.
If Not Sheet.AutoFilterMode Then
Sheet.Range("A1").AutoFilter
End If
'Freeze first row.
Sheet.Range("A2").Select
'Excel.ActiveWindow.FreezePanes = True
'Save the newly created workbook and close Excel.
' Excel.ActiveWorkbook.SaveAs ("C:\" & sProject & "_TESTCASES.xls")
' Excel.Quit
' Set Excel = Nothing
Set DesignStepList = Nothing
Set DesignStepFactory = Nothing
Set TestList = Nothing
Set TestFactory = Nothing
Set TestTree = Nothing
Set TreeMgr = Nothing
QCConnection.Disconnect
'If the Export is successful you will get the message Completed.
MsgBox "TestCase Export Completed successfully"
'Logout the QC Session
QCConnection.Logout
QCConnection.ReleaseConnection
End Sub
Sub GetNodesList(ByVal Node, ByRef NodesList)
Dim i
'Run on all children nodes
For i = 1 To Node.Count
Dim NewUpper
'Add more space to dynamic array
NewUpper = UBound(NodesList) + 1
ReDim Preserve NodesList(NewUpper)
'Add node path to array
NodesList(NewUpper) = Node.Child(i).Path
'If current node has a child then get path on child nodes too.
If Node.Child(i).Count >= 1 Then
Call GetNodesList(Node.Child(i), NodesList)
End If
Next
End Sub
'Option Explicit
''
'Strips all the HTML tags from a string.
'
'@param: strHTML A string with HTML tagges embedded.
'
'@return: A string with all HTML tags stripped.
Function stripHTML(strHTML)
'Strips the HTML tags from strHTML
Dim strOutput
Set objRegExp = New RegExp
objRegExp.IgnoreCase = True
objRegExp.Global = True
objRegExp.Pattern = "<(.|\n)+?>"
'Replace all line breaks with VB line breaks
strOutput = Replace(strHTML, "<br>", vbLf)
'Replace all HTML tag matches with the empty string
If Left(strOutput, 6) = "<html>" Then
strOutput = objRegExp.Replace(strOutput, "")
End If
'Replace all <, >, and " with <, >, and "
strOutput = Replace(strOutput, "<", "<")
strOutput = Replace(strOutput, ">", ">")
strOutput = Replace(strOutput, """, Chr(34))
Set objRegExp = Nothing
stripHTML = strOutput 'Return the value of strOutput
End Function
''
'Truncates a string to 32,767 characters for excel.
'
'@param: strText String to be truncated.
'
'@return: Truncated string.
Function Truncate(strText)
'Excel Max Cell Length = 32,767
Dim sNotice
sNotice = vbLf & "Contents Truncated..."
If Len(strText) > 32767 Then
strText = Left(strText, 32767 - Len(sNotice))
strText = strText & sNotice
End If
Truncate = strText
End Function