运行测试集时出现错误“ ActiveX组件无法创建对象”

这是我前一段时间写的一个小vbscript。它将执行ALM的特定测试。我提出了一些评论，以便于理解。

On Error Resume Next

Dim objExplorer
'' Getting ALM username
strUserName = InputBox("Please enter your ALM login name:", _
    "ALM login name")
'' Getting ALM password 
strPassword = InputBox("Please enter your ALM Password:", _
    "ALM Password")

'' QTP/UFT script path
Dim Test_path
Test_path = "[QualityCenter] Subject\folder1\sub-folder\script(test) name"

Dim qtApp ''As QuickTest.Application ''Declare the Application object variable
Dim qtTest ''As QuickTest.Test ''Declare a Test object variable
Set qtApp = CreateObject("QuickTest.Application") ''Create the Application object

''Check if the application is not already Launched
If Not qtApp.Launched then
    qtApp.Launch
Else
    Wscript.Echo "UFT is already open." & vbCrLf & "Please close the UFT and run the script again."
    WScript.Quit
End If

qtApp.Visible = False ''Make the QTP/UFT visible

'' Connecting to ALM
If Not qtApp.TDConnection.IsConnected Then
    qtApp.TDConnection.Connect "ALM URL","Domain","Project", strUserName, strPassword,False
End If
If Err.Number <> 0 Then HandleError

'' Set QTP/UFT run options
qtApp.Options.Run.RunMode = "Fast"
qtApp.Options.Run.ViewResults = False
qtApp.Open Test_path, True ''Open the test in read-only mode
If Err.Number <> 0 Then HandleError

'' set run settings for the test
Set qtTest = qtApp.Test
qtTest.Run ''Run the test
qtTest.Close ''Close the test
qtApp.quit  ''Close the QTP/UFT

Wscript.Echo "Test is completed." ''Comment this line if you don't want the messagebox

Set qtTest = Nothing ''Release the Test object
Set qtApp = Nothing ''Release the Application object

'*****************************************************************************************************************
' Error handler
'*****************************************************************************************************************
Sub HandleError()
    If qtApp.Launched then
        qtApp.Quit
    End If

    numerr = Err.number 
    abouterr = Err.description 
    If numerr <> 0 Then 
        Wscript.Echo "An Error has occurred! Error number " & numerr & " of the type '" & abouterr & "'. Please check the error and run the script again."
    End If
    WScript.Quit
End Sub  

您可以使用任务计划程序来计划此脚本。

更新（基于评论）

要使测试集定期运行，您可以将Vbscript与ALM的OTA API结合使用，并使用Windows Scheduler在计划的时间运行。

set tdc = createobject("TDApiOle80.TDConnection")
tdc.InitConnectionEx "http://qcURL/qcbin/"
tdc.login "yourUserName","yourPassword"
tdc.Connect "yourDomain","yourProject"

Set objShell = CreateObject("WScript.Shell")
Set TSetFact = tdc.TestSetFactory
Set tsTreeMgr = tdc.TestSetTreeManager
Set tsFolder = tsTreeMgr.NodeByPath("Root\Formal Tests\YourTestDirectory")
Set tsList = tsFolder.FindTestSets("Your TestSet name. This is case sensitive!")

Set theTestSet = tsList.Item(1)
Set Scheduler = theTestSet.StartExecution("")
Scheduler.RunAllLocally = True
Scheduler.run

Set execStatus = Scheduler.ExecutionStatus

Do While RunFinished = False
    execStatus.RefreshExecStatusInfo "all", True
    RunFinished = execStatus.Finished
    Set EventsList = execStatus.EventsList

    For Each ExecEventInfoObj in EventsList
        strNowEvent = ExecEventInfoObj.EventType
    Next

    For i= 1 to execstatus.count
        Set TestExecStatusobj =execstatus.Item(i)
        intTestid = TestExecStatusobj.TestInstance
    Next
Loop