'VBScript Document
Option Explicit


'QC Paramters
Dim Server, UserName, Password, QCDomain, QCProject, QCTestSetPath, QCTestSetName,Env, ExecutionBrowser
Dim objWMIService1, objWMIService2, objProcess, colProcess,objNet,objFSO
Dim strComputer, strProcess1, strProcess2
Dim cnt, nDays
Dim WshShell
Dim strLogFile

Const DeleteReadOnly = True
cnt = 0
nDays = 6

'
strComputer = "."
strProcess1 = "'UFT.exe'"
strProcess2 = "'abc.exe'"
strLogFile = "C:ProjectabcExecutionLog.log"

const MAX_POLL_CTR = 45
Const SLEEP_TIME = 60000 '1 min, so a test can run for a max of 10 mins
const FORAPPENDING = 8

Server = <url>
UserName = <username>
Password = <password>
QCDomain = <domain>
QCProject = <project>
QCTestSetPath = <path>
QCTestSetName = <TestSetName>
Env = <Environment>
ExecutionBrowser = <Browser>



Call RunTestSet(Server, UserName, Password, QCDomain, QCProject, QCTestSetPath, QCTestSetName)

Public Sub RunTestSet(Server, UserName, Password, QCDomain, QCProject, QCTestSetPath, QCTestSetName)
    Dim QCTestSetExec, sErr, arrArgs, ix, arg, bExit

    sErr = "Unable to execute RunTestSet. Please provide the "
    arrArgs = Array("Server", "UserName", "Password", "QCDomain", "QCProject", "QCTestSetPath", "QCTestSetName")
    bExit = False

    For ix = LBound(arrArgs) To UBound(arrArgs)
        Execute "arg = " & arrArgs(ix)

        If arg = "" Then
            MsgBox sErr & arrArgs(ix) & ".", vbOkOnly, "Error!"

            bExit = True
        End If
    Next

    If bExit Then Exit Sub

    Set QCTestSetExec = New QCRunTestSet

    With QCTestSetExec
        .Server = Server
        .UserName = UserName
        .Password = Password
        .QCDomain = QCDomain
        .QCProject = QCProject
        .QCTestSetPath = QCTestSetPath
        .QCTestSetName = QCTestSetName

        .Run
    End With

    Set QCTestSetExec = Nothing
End Sub

Class QCRunTestSet



  'Public Variables

''' <summary>
''' QC Server URL (string)
''' </summary>
''' <remarks></remarks>
Public Server

''' <summary>
''' UserName (string)
''' </summary>
''' <remarks></remarks>
Public UserName

''' <summary>
''' Password (string)
''' </summary>
''' <remarks></remarks>
Public Password

''' <summary>
''' Quality Center Domain (string)
''' </summary>
''' <remarks></remarks>
Public QCDomain

''' <summary>
''' QC Project (string)
''' </summary>
''' <remarks></remarks>
Public QCProject

''' <summary>
''' QC TestSet Folder Path (string)
''' </summary>
''' <remarks>RootTestSetFolderTestSetSubFolder</remarks>
Public QCTestSetPath

''' <summary>
''' Target TestSet Name (string)
''' </summary>
''' <remarks></remarks>
Public QCTestSetName

''' <summary>
''' Recipient list from QC's Automation tab
''' </summary>
''' <remarks></remarks>
Public EMailTo

''' <summary>
''' TSTestFactory manages test instances (TSTest objects) in a test set
''' </summary>
''' <remarks></remarks>
Public TSTestFactory

''' <summary>
''' Number of blocked tests after completion of scheduler (integer)
''' </summary>
''' <remarks></remarks>
Public iBlocked

''' <summary>
''' Number of failed tests after completion of scheduler (integer)
''' </summary>
''' <remarks></remarks>
Public iFailed

''' <summary>
''' Number of N/A tests after completion of scheduler (integer)
''' </summary>
''' <remarks></remarks>
Public iNA

''' <summary>
''' Number of NoRun tests after completion of scheduler (integer)
''' </summary>
''' <remarks></remarks>
Public iNoRun

''' <summary>
''' Number of NotCompleted tests after completion of scheduler (integer)
''' </summary>
''' <remarks></remarks>
Public iNotCompleted

''' <summary>
''' Number of Passed tests after completion of scheduler (integer)
''' </summary>
''' <remarks></remarks>
Public iPassed

''' <summary>
''' DateTime stamp at the start of the Scheduling session (DateTime)
''' </summary>
''' <remarks></remarks>
Public dtStartTime

'Private Variables

''' <summary>
''' QuickTest.Application object
''' </summary>
''' <remarks></remarks>
Private qtApp

''' <summary>
''' TDApiOle object
''' </summary>
''' <remarks></remarks>
Private TDConnection

''' <summary>
''' TSScheduler object returned by the StartExecution method
''' </summary>
''' <remarks></remarks>
Private TSScheduler

''' <summary>
''' TestSet Folder object
''' </summary>
''' <remarks></remarks>
Private TSFolder

''' <summary>
''' Executes the scheduler
''' </summary>
''' <remarks></remarks>




Public Default Sub Run()
    Dim bStatus, dtStartTime

    '@see isQCConnected()
    bStatus = isQCConnected

    '@see isQTPInstalled()
    If bStatus Then bStatus = isQTPInstalled

    If Not bStatus Then Exit Sub

    Dim TSTreeManager, QCTestSetPath, TSList, QCTestSetName, TestSet, qtTest, sEnvironment, TSReport, EMailTo, ExecutionStatus


    Dim TestList, TestID, TestRunStatus, ctr, TName, TestName

    'TestSetTreeManager manages the test set tree and its related test set folders
    Set TSTreeManager = TDConnection.TestSetTreeManager

    QCTestSetPath = Me.QCTestSetPath
    'Return the test set tree node from the specified tree path
    Set TSFolder = TSTreeManager.NodeByPath(QCTestSetPath)

    QCTestSetName = Me.QCTestSetName
    'Returns the list of test sets contained in the folder that match the specified pattern.
    Set TSList = TSFolder.FindTestSets(QCTestSetName)

    If TSList.Count = 0 Then
        MsgBox "The TestSet '" & QCTestSetName & "' was not found.", vbOkOnly, "TSFolder.FindTestSets Exception!"
        Exit Sub
    End If

    For Each TestSet in TSList
        If LCase(TestSet.Name) = LCase(QCTestSetName) Then
            Exit For
        End If
    Next

    'This enables database to update immediately when the field value changes
    TestSet.AutoPost = True

    'TSTestFactory manages test instances (TSTest objects) in a test set
    Set TSTestFactory = TestSet.TSTestFactory
    Set Me.TSTestFactory = TSTestFactory
    Set TestList = TSTestFactory.NewList("")

    'TSTestFactory.NewList("") creates a list of objects according to the specified filter
    For Each qtTest in TestList

        qtTest.Field("TC_STATUS") = "No Run"
        qtTest.Post
    Next


    TestSet.Refresh : TSFolder.Refresh


    Set TSReport = TestSet.ExecutionReportSettings
    TSReport.Enabled = True


    EMailTo = TSReport.EMailTo : Me.EMailTo = EMailTo

    On Error Resume Next


    dtStartTime = Now : Me.dtStartTime = dtStartTime

    TestID = ""
    TName = ""
    ctr = 0
    For each qtTest in TestList
        TestID = CStr(qtTest.ID)

        TName = qtTest.Name
        TestName = qtTest.TestName
        'Print "Executing Test ID using Field value" & qtTest.Field("TC_TESTCYCL_ID")

        'TestSet.StartExecution returns the TSScheduler object and starts the Execution controller
        Set TSScheduler = TestSet.StartExecution("")

        If Err.Number <> 0 Then
            MsgBox Err.Description & vbNewLine & vbNewLine & "Unable to create the TSScheduler" & _
                "object. Please ensure the ALM Client Registration is complete before " & _
                "executing RunTestSet.", vbOkOnly, "RunTestSet.Run->TSScheduler Exception!"

            On Error Goto 0
            Exit Sub
        End If
        On Error Goto 0

        'Run all tests on localhost
        TSScheduler.RunAllLocally = True


        'Logging enabled
        TSScheduler.LogEnabled = True

        'Start testSet run
        TSScheduler.Run(TestID)

        'ExecutionStatus represents the execution status of the scheduler
        Set ExecutionStatus = TSScheduler.ExecutionStatus

        'Wait until all tests are complete running
        TestRunStatus = WaitWhileTestRunning(ExecutionStatus,TestID,MAX_POLL_CTR)

        If not TestRunStatus Then
'



'Test execution failed or timed out
                'Terminate UFT process
                On Error Resume Next
                TSScheduler.Stop(TestID)
                Set ExecutionStatus = TSScheduler.ExecutionStatus
                'Wait until all tests are complete running
                TestRunStatus = WaitWhileTestRunning(ExecutionStatus,TestID,5)

            If not TestRunStatus Then
                If qtTest.IsLocked Then
                    qtTest.UnLockObject()
                    WScript.Sleep 100
                    qtTest.Refresh()
                    WScript.Sleep 3000 'Atleast 3s are elapse before Refresh completes
                End If


                Set objWMIService1 = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\" & strComputer & "rootcimv2")

                Set colProcess = objWMIService1.ExecQuery _
                ("Select * from Win32_Process Where Name = " & strProcess1)

                For Each objProcess in colProcess
                    objProcess.Terminate()
                    WScript.Sleep 100
                    'cnt = cnt + 1
                Next

                WScript.Sleep 1000

                Set objWMIService2 = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\" & strComputer & "rootcimv2")

                Set colProcess = objWMIService2.ExecQuery _
                ("Select * from Win32_Process Where Name = " & strProcess2)

                For Each objProcess in colProcess
                    objProcess.Terminate()
                    WScript.Sleep 100
                    'cnt = cnt + 1
                Next
                WScript.Sleep 10000
            End If


            'To clear temporary Internet files
            Set WshShell = CreateObject("WScript.Shell")
            WshShell.run "RunDll32.exe InetCpl.cpl,ClearMyTracksByProcess 8"

            'To clear browsing cookies
            WshShell.run "RunDll32.exe InetCpl.cpl,ClearMyTracksByProcess 2"

            'To Clear Browsing History
            WshShell.run "RunDll32.exe InetCpl.cpl,ClearMyTracksByProcess 1"
            writeLog(TName&" - "&TestName)
            'Exit For 'Test Execution unsuccessful
        End If

        Set ExecutionStatus = Nothing
        Set TSScheduler = Nothing

    Next 'End TestList iteration


End Sub

'Private Methods

Private Function WaitWhileTestRunning(ByVal ExecutionStatus, ByVal TestID, ByVal pollCounter)
    Dim RunFinished: RunFinished = False
    Dim bTimeout

    bTimeout = false

    Do while (RunFinished = False)
        ExecutionStatus.RefreshExecStatusInfo TestID, True
        RunFinished = ExecutionStatus.Finished

        WScript.Sleep(SLEEP_TIME)
        pollCounter = pollCounter - 1

        If pollCounter = 0 Then
            bTimeout = true
            Exit Do
        End If
    Loop

    If bTimeout Then
        WaitWhileTestRunning = false
    Else
        WaitWhileTestRunning = RunFinished
    End If

End Function

Private Function writeLog(ByVal strTestName)
        Dim obFSO
        Dim obFile
        Dim strMessage
        Set obFSO = CreateObject("Scripting.FileSystemObject")
        ' Validate the file exits before attempting to write, create if it does not
        If obFSO.FileExists(strLogFile) Then
            Set obFile = obFSO.OpenTextFile(strLogFile,FORAPPENDING)
        Else
            Set obFile = obFSO.CreateTextFile(strLogFile,True)
        End If

        strMessage = "Test Name: " & strTestName & " Executed on " & Now

        ' write the message

        obFile.WriteLine strMessage

        ' Close the log
        obFile.Close
End Function

Private Function isQCConnected()
    isQCConnected = False

    Dim UserName, Password

    UserName = Me.UserName
    Password = Me.Password

    On Error Resume Next
        Set TDConnection = CreateObject("TDApiOle80.TDConnection")

        If Err.Number <> 0 Then
            MsgBox "Unable to create an instance of the TestDirector API " & _
                    "OLE (TestDirector Connection) Object.", vbOkOnly, "TDConnection Exception!"
            Err.Clear : Exit Function
        End If

        With TDConnection
            'Create a connection with the QC Server
            .InitConnectionEx Server

            If Err.Number <> 0 Then
                MsgBox Err.Description, vbOkOnly, "TDConnection.InitConnectionEx Exception!"
                Exit Function
            End If

            'Login to QC
            .Login UserName, Password

            If Err.Number <> 0 Then
                MsgBox Err.Description, vbOkOnly, "TDConnection.Login Exception!"
                Exit Function
            ElseIf Not .LoggedIn Then
                MsgBox "Unable to login to Quality Center. Please verify your login " & _
                        "credentials.", vbOkOnly, "TDConnection.Login Exception!"
                Exit Function
            End If

            'Connect to QC Project
            .Connect QCDomain, QCProject

            If Err.Number <> 0 Then
                MsgBox Err.Description, vbOkOnly, "TDConnection.Connect Exception!"
                Exit Function
            ElseIf Not .ProjectConnected Then
                MsgBox "Unable to connect to '" & QCDomain & "/" & QCProject & "'.", vbOkOnly, _
                        "TDConnection.Connect Exception!"
                Exit Function
            End If

            isQCConnected = True
        End With

    On Error Goto 0
End Function

Private Function isQTPInstalled()
    isQTPInstalled = False

    On Error Resume Next
        Set qtApp = GetObject("", "QuickTest.Application")

        If Err.Number <> 0 Then
            MsgBox Err.Description, vbOkOnly, "QuickTest.Application Exception!"
            Exit Function
        Else
            qtApp.Launch()
            qtApp.Visible = True

            isQTPInstalled = True
        End If
    On Error Goto 0
End Function

Private Function get_TSExecutionLog()
    Dim color, style, TSTestFactory, TSList, ix, html, sTest, sStatus, sTester, sActualTester, dtDate, dtExecTime

    'color = green;red
    color = "46D44B;D41743"

    'default html style
    style = "font-size: 11px; padding-right: 5px; padding-left: 5px; height: 20px; border-bottom: 1px solid #eee;"

    Set TSTestFactory = Me.TSTestFactory
    Set TSList = TSTestFactory.NewList("")

    'Loop through all tests in the TestSet list and retrieve their status
    For ix = 1 To TSList.Count
        html = html & "<tr>"

        'Test Name
        html = html & "<td style='" & style & "'>" & TSList.item(ix).field("TSC_NAME") & "</td>"

        'Status
        sStatus = TSList.item(ix).LastRun.Status
        Select Case sStatus
            Case "Passed"   : html = html & "<td style='color: #" & Trim(Split(color, ";")(0)) & ";" & style & "'>" & sStatus & "</td>"
            Case "Failed"   : html = html & "<td style='color: #" & Trim(Split(color, ";")(1)) & ";" & style & "'>" & sStatus & "</td>"
            Case Else       : html = html & "<td style='" & style & "'>" & sStatus & "</td>"
        End Select

        'Tester
        html = html & "<td style='" & style & "'>" & TSList.item(ix).field("TC_TESTER_NAME") & "</td>"

        'Actual Tester
        html = html & "<td style='" & style & "'>" & TSList.item(ix).field("TC_ACTUAL_TESTER") & "</td>"

        'DateTime stamp
        html = html & "<td style='" & style & "'>" & Date & "</td>"

        'Execution Time
        html = html & "<td style='" & style & "'>" & TSList.item(ix).field("TC_EXEC_TIME") & "</td>"
        html = html & "</tr>"
    Next

    get_TSExecutionLog = html
End Function

''' <summary>
''' Returns the number of tests passed, failed and not completed
''' </summary>
''' <remarks></remarks>

Private Sub load_ExecutionRunStatus()
    Dim TSTestFactory, TSList, ix, iBlocked, iFailed, iNA, iNoRun, iNotCompleted, iPassed

    Set TSTestFactory = Me.TSTestFactory
    On Error Resume Next
    Set TSList = TSTestFactory.NewList("")

    'Loop through all tests in the testSet list and retrieve status
    For ix = 1 To TSList.Count
        Select Case LCase(TSList.item(ix).LastRun.Status)
            Case "blocked" : iBlocked = iBlocked + 1
            Case "failed" : iFailed = iFailed + 1
            Case "n/a" : iNA = iNA + 1
            Case "no run" : iNoRun = iNoRun + 1
            Case "not completed" : iNotCompleted = iNotCompleted + 1
            Case "passed" : iPassed = iPassed + 1
        End Select
    Next

    If iBlocked = "" Then iBlocked = 0
    If iFailed = "" Then iFailed = 0
    If iNA = "" Then iNA = 0
    If iNoRun = "" Then iNoRun = 0
    If iNotCompleted = "" Then iNotCompleted = 0
    If iPassed = "" Then iPassed = 0

    Me.iBlocked = iBlocked
    Me.iFailed = iFailed
    Me.iNA = iNA
    Me.iNoRun = iNoRun
    Me.iNotCompleted = iNotCompleted
    Me.iPassed = iPassed
End Sub

''' <summary>
''' Sends an email to the distribution list
''' </summary>
''' <remarks></remarks>

Private Sub TDSendMail()

    Dim EMailTo : EMailTo = Me.EMailTo
    Dim QCTestSetName : QCTestSetName = Me.QCTestSetName

    If EMailTo = "" Then Exit Sub

    load_ExecutionRunStatus()

    TDConnection.SendMail EMailTo, "", "Automation Regression Execution: " & QCTestSetName&"; Environment : " &Env&"; Browser : "&ExecutionBrowser, sHTML
End Sub

'Class Initialize & Terminate

''' <summary>
''' Releases connections and sends mail after TSScheduler execution
''' </summary>
''' <remarks></remarks>

Private Sub Class_Terminate()
    Dim bStatus
    '@see isQCConnected()
    bStatus = isQCConnected

    If bStatus Then
        If IsObject(TSFolder) Then
            If Not TSFolder Is Nothing Then
                TSFolder.Refresh : WScript.Sleep(5000)

                'Send an email to the distribution list
                TDSendMail()

                Set TSFolder = Nothing
            End If
        End If
    End If

    On Error Resume Next
        'Disconnect TD session
        TDConnection.Disconnect

        'Disconect and quit QTP
        If IsObject(qtApp) Then
            If qtApp.TDConnection.IsConnected Then qtApp.TDConnection.Disconnect
            qtApp.Quit
        End If
    On Error Goto 0

    Set qtApp = Nothing
    Set TDConnection = Nothing
End Sub

End Class ''RunTestSet