Thursday, February 15, 2018

VBA Code to update test sets in ALM testlab

Hi All,
You might have come across scenarios where you are required to pass/fail many test cases in a test set. As ALM does not support bulk update, the easy way is to write a macro that does the job.Below is code for the same.

Sub ConnectToQualityCenter()
    Application.StatusBar = "Initiating connection"
    Dim qcURL As String
    Dim qcID As String
    Dim qcPWD As String
    Dim qcDomain As String
    Dim qcProject As String
    Dim tdConnection As Object
    Dim TestSetFact, tsTreeMgr, tSetFolder, TestSetsList, theTestSet
    Dim TestSetIdentifier, TSTestFact, TestSetTestsList, testInstanceF, aFilter
    Dim lst, tstInstance

    On Error GoTo err
    qcURL = "http://<XXXXX>.us.<XXXXX>.com/qcbin"
    qcID = Sheet1.Cells(2, 1)
    qcPWD = Sheet1.Cells(2, 2)
    If IsEmpty(qcID) Or IsEmpty(qcPWD) Then
        Application.StatusBar = "UID/PWD fields are mandatory"
        GoTo err2
    End If
    qcDomain = "<XXXXX>"
    qcProject = "<XXXXX>"

    'Display a message in Status bar
     Application.StatusBar = "Connecting to ALM..."
    'Create a Connection object to connect to Quality Center
      Set tdConnection = CreateObject("TDApiOle80.TDConnection")
    'Initialise the Quality center connection
       tdConnection.InitConnectionEx qcURL
    'Authenticating with username and password
       tdConnection.Login qcID, qcPWD
       Application.StatusBar = "Login successfull"
    'connecting to the domain and project
       tdConnection.Connect qcDomain, qcProject
    'On successfull login display message in Status bar
      Application.StatusBar = "Connection Established to <XXXXX>/<XXXXX>"

    '---------------------------------------Connection Established --------------------------------------------------------------------------
    ' Get the test set tree manager from the test set factory
    'tdconnection is the global TDConnection object.
    Set TSetFact = tdConnection.TestSetFactory
    Set tsTreeMgr = tdConnection.testsettreemanager
    ' Get the test set folder passed as an argument to the example code
    npath = Sheet1.Cells(2, 4)
    testSetName = Split(npath, "\")(UBound(Split(npath, "\")))
    npath = Replace(npath, testSetName, "")

    Set tsFolder = tsTreeMgr.NodeByPath(npath)
    '--------------------------------Check if the Path Exists or NOt ---------------------------------------------------------------------
    If tsFolder Is Nothing Then
        Application.StatusBar = "Invalid test set path"
    End If

    ' Search for the test set passed as an argument to the example code
    Set tsList = tsFolder.FindTestSets(testSetName)
    '----------------------------------Check if the Test Set Exists --------------------------------------------------------------------
    If tsList Is Nothing Then
        Application.StatusBar = "Invalid test set name"
    End If

    '---------------------------------------------Check if the TestSetExists or is Duplicated ----------------------------------------------
    If tsList.Count > 1 Then
        Application.StatusBar = "Found more than one test set:-> refine search"
        Exit Sub
    ElseIf tsList.Count < 1 Then
        Application.StatusBar = "Test set not found"
        Exit Sub
    End If

    '-------------------------------------------Access the Test Cases inside the Test SEt -------------------------------------------------

    allScriptsNames = ""
    usedrowsCounter = Sheet1.UsedRange.Rows.Count
    For rI = 2 To usedrowsCounter
        If IsEmpty(Sheet1.Cells(rI, 5)) Or IsEmpty(Sheet1.Cells(rI, 6)) Or InStr(1, allScriptsNames, Sheet1.Cells(rI, 5)) > 1 Then
            allScriptsNames = allScriptsNames & "##" & Sheet1.Cells(rI, 5) & "##" & Sheet1.Cells(rI, 6)
        End If

    Set theTestSet = tsList.Item(1)
    For Each testsetfound In tsList
        Set tsFolder = testsetfound.TestSetFolder
        Set tsTestFactory = testsetfound.tsTestFactory
        Set tsTestList = tsTestFactory.NewList("")
        For Each tsTest In tsTestList
            Application.StatusBar = tsTest.Name & tsTest.TestId
            testrunname = Sheet1.Cells(2, 3)
            If InStr(1, allScriptsNames, tsTest.Name + "##") > 1 Then
                'MsgBox Split(Split(allScriptsNames, tsTest.Name + "##")(1), "##")(0)
                '--------------------------------------------Accesss the Run Factory --------------------------------------------------------------------
                Set RunFactory = tsTest.RunFactory
                Set obj_theRun = RunFactory.AddItem(CStr(testrunname))
                obj_theRun.Status = Split(Split(allScriptsNames, tsTest.Name + "##")(1), "##")(0)
            End If
        Next tsTest
    Next testsetfound


    Application.StatusBar = "Logged Out"
    If (err.Number <> 0) Then
        'Display the error message in Status bar
        Application.StatusBar = err.Description
    End If
End Sub

Function TimeStamp()
  Dim CurrTime
  CurrTime = Now()

  TimeStamp = CStr(Year(CurrTime)) & "-" _
    & LZ(Month(CurrTime)) & "-" _
    & LZ(Day(CurrTime)) & " " _
    & LZ(Hour(CurrTime)) & ":" _
    & LZ(Minute(CurrTime)) & ":" _
    & LZ(Second(CurrTime))
End Function

No comments:

Post a Comment