Option Compare Database '(c) 2025 Real-Time Technology Solutions, Inc. All Rights Reserved. ' ' Sample QuerySurge(TM) HP ALM/QC Script File demonstrating the use of QuerySurge Test Management REST API Sub Test_Main(Debug, CurrentTestSet, CurrentTSTest, CurrentRun) On Error Resume Next ' declare configuration variables Dim hostname, port, username, password, projectId, suiteIdList, scenarioNameDef ' ******************************************************************************* ' ********************** Setup Connection Details ******************************* ' ***** Edit the following configuration variables to work with your ***** ' ***** QuerySurge environment. ***** ' ***** ***** ' ******************************************************************************* ' ********************* START OF CONFIGURATION VARIABLES ************************ username = "admin" password = "admin" hostname = "127.0.0.1" port = "80" projectId = "1" suiteIdList = "1" scenarioNameDef = "ALMQCScenario-" & Now ' ********************* END OF CONFIGURATION VARIABLES *************************** Dim http, url, response, baseUrl, reqBody, sessionId, timeout, retryCount, suiteIdListArr, formattedSuiteIdList baseUrl = "http://" & hostname & ":" & port & "/QuerySurge/api" timeout = 60 retryCount = 0 suiteIdListArr = Split(suiteIdList, ",") 'Setup http requestor object Set http = CreateObject("MSXML2.ServerXMLHTTP") ' Login to QuerySurge url = baseUrl & "/auth/login" http.Open "POST", url, False http.SetRequestHeader "accept", "application/json" http.SetRequestHeader "Content-Type", "application/json" reqBody = "{""username"": """ & username & """, ""password"": """ & password & """}" http.Send reqBody If err.Number <> 0 Then MsgBox "Login Failed." & vbNewLine & err.Description Exit Sub End If response = http.responseText sessionId = ExtractJsonValue(response, "sessionId") If sessionId = "" Then If Not IsNull(CurrentRun) Then CurrentRun.Status = "Failed" End If errorMessage = ExtractJsonValue(response, "errorMessage") If errorMessage <> "" Then MsgBox "Login Failed." & vbNewLine & errorMessage Exit Sub End If MsgBox "Login Failed" Exit Sub End If ' Setup Test Step List Dim myStepFactory, myStepList, stepId If Not IsNull(CurrentRun) Then Set myStepFactory = CurrentRun.StepFactory End If ' Verify script is running in the Test Lab If IsNull(myStepFactory) Then MsgBox "This script must be run from the Test Lab" Exit Sub End If ' Create the Scenario and run it For i = LBound(suiteIdListArr) To UBound(suiteIdListArr) formattedSuiteIdList = formattedSuiteIdList & "id=" & suiteIdListArr(i) If i <> (UBound(suiteIdListArr) - LBound(suiteIdListArr) + 1) - 1 Then formattedSuiteIdList = formattedSuiteIdList & "&" End If Next url = baseUrl & "/project/" & projectId & "/execute/suite?" & formattedSuiteIdList & "&name=" & scenarioNameDef http.Open "POST", url, False http.SetRequestHeader "accept", "application/json" http.SetRequestHeader "X-QS-AUTH", sessionId http.Send response = http.responseText scenarioId = ExtractJsonValue(response, "guid") If scenarioId = "" Then MsgBox "Failed to start scenario execution" If Not IsNull(CurrentRun) Then CurrentRun.Status = "Failed" End If Exit Sub End If ' Wait for the Scenario to finish outcome = "Not Run" Set objShell = CreateObject("WScript.Shell") Do url = baseUrl & "/project/" & projectId & "/status/scenario/" & scenarioId http.Open "GET", url, False http.SetRequestHeader "accept", "application/json" http.SetRequestHeader "Content-Type", "application/json" http.SetRequestHeader "X-QS-AUTH", sessionId http.Send response = http.responseText outcome = ExtractJsonValue(response, "message") retryCount = retryCount + 1 objShell.Run "timeout /t 1 /nobreak", 0, True Loop While (outcome = "Not Run" Or outcome = "Running") And retryCount < timeout If outcome = "Not Run" Or outcome = "Running" Or outcome = "" Then MsgBox "Error. " & vbNewLine & "Scenario execution either timed out or ran into exception" If Not IsNull(CurrentRun) Then CurrentRun.Status = "Failed" End If Exit Sub End If ' Retrieve Scenario Results url = baseUrl & "/project/" & projectId & "/results/testmanagement/summary/" & scenarioId http.Open "GET", url, False http.SetRequestHeader "accept", "application/xml" http.SetRequestHeader "X-QS-AUTH", sessionId http.Send response = http.responseText ' Load XML Results into an XML object Set xmlObj = CreateObject("Microsoft.XMLDOM") xmlObj.async = "false" If Not xmlObj.LoadXML(response) Then MsgBox "Error loading results" If Not IsNull(CurrentRun) Then CurrentRun.Status = "Failed" End If Exit Sub End If Dim errXML Set errXML = xmlObj.SelectSingleNode("//errorResponse/errorMessage") If Not errXML Is Nothing Then MsgBox "Failed to retrieve scenario result." Exit Sub End If ' Get the scenario name Dim scenarioNameNode, scenarioName scenarioName = xmlObj.SelectSingleNode("//scenario/scenarioName").Text 'MsgBox scenarioName ' Get the scenario outcome Dim scenarioOutComeNode scenarioOutcome = xmlObj.SelectSingleNode("//scenario/outcome").Text If Not IsNull(CurrentRun) Then CurrentRun.Status = scenarioOutcome End If 'MsgBox scenarioOutcome ' Process the Scenario Results Dim suiteNodes Set suiteNodes = xmlObj.SelectNodes("//scenario/suiteList") For Each suiteListNode In suiteNodes ' Traverse through each suite For Each suiteNode In suiteListNode.ChildNodes ' Get the suite info Dim suiteId, suiteName, queryPairListNode suiteId = suiteNode.SelectSingleNode("suiteId").Text suiteName = suiteNode.SelectSingleNode("suiteName").Text 'MsgBox suiteId & " : " & suiteName Set queryPairListNode = suiteNode.SelectSingleNode("querypairList") For Each queryPairNode In queryPairListNode.ChildNodes ' Traverse each QueryPair Dim queryPairId, queryPairName, queryPairOutcome, queryPairResultsUrl, stepObj queryPairId = queryPairNode.SelectSingleNode("querypairId").Text queryPairName = queryPairNode.SelectSingleNode("querypairName").Text queryPairOutcome = queryPairNode.SelectSingleNode("outcome").Text 'queryPairOutcome = outcomeMap.Item(queryPairOutcome) queryPairResultsUrl = queryPairNode.SelectSingleNode("querypairResultsUrl").Text 'MsgBox queryPairName & " : " & queryPairOutcome If Not IsNull(CurrentRun) Then Set stepObj = myStepFactory.AddItem(Null) 'Set myStepList = myStepFactory.NewList("") 'stepId = myStepList.Count ' Add QueryPair outcome details to test step stepObj.Name = queryPairName stepObj.Status = queryPairOutcome 'stepObj.Field("ST_STATUS") = queryPairOutcome stepObj.Field("ST_ACTUAL") = queryPairResultsUrl stepObj.Field("ST_DESCRIPTION") = "Suite: " & suiteName & " QueryPair: " & queryPairName stepObj.Post ' Add hyperlink to QueryPair results as an attachment Dim attFactory, attachment Set attFactory = stepObj.Attachments Set attachment = attFactory.AddItem(Null) attachment.FileName = queryPairResultsUrl attachment.Type = 2 attachment.Post End If Next Next Next 'Logout url = baseUrl & "/auth/logout" http.Open "POST", url, False http.SetRequestHeader "accept", "*/*" http.SetRequestHeader "X-QS-AUTH", sessionId http.Send 'Release object references Set xmlObj = Nothing Set http = Nothing On Error GoTo 0 End Sub Function ExtractJsonValue(json, key) Dim pattern, matches, match pattern = """" & key & """:""([^""]+)""" Set matches = CreateObject("VBScript.RegExp") matches.IgnoreCase = True matches.Global = True matches.pattern = pattern Set match = matches.Execute(json) If match.Count > 0 Then ExtractJsonValue = match(0).SubMatches(0) Else ExtractJsonValue = "" End If End Function