Aktualisierung Testfall-status-Test-Labor(qc) aus Excel über VB

Sub ConnectToQualityCenter()


'-----------------------------------------------------Connect to Quality Center --------------------------------------------------------


MsgBox "Starting Connectinon"
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 = "Server Details/qcbin"
   qcID = "UserName"
   qcPWD = "Password"
   qcDomain = ""
   qcProject = ""

'Display a message in Status bar
 Application.StatusBar = "Connecting to Quality Center.. Wait..."
'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
'connecting to the domain and project
   tdConnection.Connect qcDomain, qcProject
'On successfull login display message in Status bar
  Application.StatusBar = "........QC Connection is done Successfully"
  MsgBox "Connection Established"


'---------------------------------------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 = Trim("Your Test Set Folder Path")

Set tsFolder = tsTreeMgr.NodeByPath(nPath)
--------------------------------Check if the Path Exists or NOt ---------------------------------------------------------------------
If tsFolder Is Nothing Then  
Msgbox "Error"
End If

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

'---------------------------------------------Check if the TestSetExists or is Duplicated ----------------------------------------------

If tsList.Count > 1 Then
MsgBox "FindTestSets found more than one test set: refine search"
Exit Sub
ElseIf tsList.Count < 1 Then
MsgBox "FindTestSets: test set not found"
Exit Sub
End If

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

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
MsgBox tsTest.Name
testrunname = "Test Case name"
If tsTest.Name = "Test case Name" Then

--------------------------------------------Accesss the Run Factory --------------------------------------------------------------------
Set RunFactory = tsTest.RunFactory
Set obj_theRun = RunFactory.AddItem(CStr(testrunname))
obj_theRun.Status = "Passed" '-- Status to be updated
obj_theRun.Post
End If
Next tsTest
Next testsetfound
'

'------------------------------------------------------Disconnect Quality Center -----------------------------------------------------------------

tdConnection.Disconnect
tdConnection.Logout
tdConnection.ReleaseConnection
MsgBox ("Logged Out")

-----------------------------------------Error Function to Display the Error in teh Excel Status Bar ---------------------------------------------

err:
'Display the error message in Status bar
Application.StatusBar = err.Description
 MsgBox "Some Error Pleas see ExcelSheet"


End Sub