使用VB从Excel中更新测试实验室（qc）中的测试用例状态

Question

我想从Excel工作表中更新测试实验室中Qc的测试用例状态。 我经历了很多帖子，但找不到一个好的解决方案。 我终于明白了，我现在发布的答案供您查看，以便对其他人也有所帮助。

请找到下面的答案：
我已经硬编码它，你可以将它作为参数传递，如果你想。

谢谢

Answer 1

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