are you tired with QC for storing and downloading QTP scripts?
QC slowness is very common issue and HP should take this on priority. But till that time lets see how to overcome this QC slowness issue. One way to write an Excel Macro which will take care of uploading and downloading of QTP scripts. Please see how:
1. this is Excel where you need to provide appropriate details:
2. When you click on download scripts button the macro will download all qtp test scripts from given node to given shared folder path. the same way when you click on Upload scripts the macro will upload all scripts from shared folder path to QC.
------------------------------------------------------------------------------------------------------------------------------
See what happen when user click on download scripts or upload scripts buttons
Sub cmdDownloadScripts_Click()
'Confirm Download
Dim Response As VbMsgBoxResult
Response = Msgbox("Confirmation: Download Scripts from QC?", vbQuestion + vbYesNo)
If Response = vbNo Then
Msgbox "Download Canceled."
Exit Sub
End If
'Confirm Attachment Download
Dim ResponseA As VbMsgBoxResult
ResponseA = Msgbox("Confirmation: Download Scripts with Attachments?", vbQuestion + vbYesNo)
If ResponseA = vbYes Then
iReplyA = "Yes"
Else
iReplyA = "No"
Msgbox "Download Attachments Cancelled."
'Exit Sub
End If
'Clear Results and Values
RowCount = ThisWorkbook.Worksheets("Scripts").UsedRange.Rows.Count
If RowCount > 13 Then
ThisWorkbook.Worksheets("Scripts").Range("A14", "A" & RowCount).Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.EntireRow.Delete
ThisWorkbook.Save
End If
strQualityCenterURL = Trim(Sheets("Scripts").Range("B2").Value)
strDomain = Trim(Sheets("Scripts").Range("B5").Value)
strProject = Trim(Sheets("Scripts").Range("B6").Value)
strUserName = Trim(Sheets("Scripts").Range("B3").Value)
strPassword = Trim(Sheets("Scripts").Range("B4").Value)
strTestPlanProjectPath = Trim(Sheets("Scripts").Range("B8").Value)
strSharedFolderPath = Trim(Sheets("Scripts").Range("B9").Value)
Dim qtApp 'As QuickTest.Application ' Declare the Application object variable
Dim tdc
Dim ModuleName
Set qtApp = CreateObject("QuickTest.Application") ' Create the Application object
qtApp.Launch ' Start QuickTest
qtApp.Visible = True ' Make the QuickTest application visible
' Connect to the Quality Center
If Not qtApp.TDConnection.IsConnected Then
qtApp.TDConnection.Connect strQualityCenterURL, strDomain, strProject, strUserName, strPassword, False
End If
If qtApp.TDConnection.IsConnected Then ' If connection is successful
Set tdc = qtApp.TDConnection.TDOTA
Set TreeMgr = tdc.TreeManager
' Use TreeManager.RootList to get the Subject root.
Set Trees = TreeMgr.RootList(TDOLE_SUBJECT)
Set MyTrees = TreeMgr.NodeByPath(strTestPlanProjectPath)
If MyTrees.Count = 0 Then
ModuleName = ""
testPath = MyTrees.Path
strFSPath = strSharedFolderPath
Call CreateFolder(strFSPath)
If iReplyA = "Yes" Then
strFSAPath = strFSPath & "\" & Trim(ModuleName) & " Attachments\"
Call CreateFolder(strFSAPath)
End If
Call DownloadScripts(qtApp, tdc, testPath, strFSPath, ModuleName)
If iReplyA = "Yes" Then
Call DownloadAttachements(qtApp, tdc, testPath, strFSAPath)
End If
End If
Call CreateFolder(strSharedFolderPath)
For iChild = 1 To MyTrees.Count
ModuleName = Trim(MyTrees.Child(iChild).Name)
strFSPath = strSharedFolderPath & "\" & ModuleName
Call CreateFolder(strFSPath)
If iReplyA = "Yes" Then
strFSAPath = strFSPath & "\" & ModuleName & " Attachments\"
Call CreateFolder(strFSAPath)
End If
Set Locate = MyTrees.FindChildNode(ModuleName)
testPath = Locate.Path
Call DownloadScripts(qtApp, tdc, testPath, strFSPath, ModuleName)
If iReplyA = "Yes" Then
Call DownloadAttachements(qtApp, tdc, testPath, strFSAPath)
End If
Next
qtApp.TDConnection.Disconnect ' Disconnect from Quality Center
Else
Msgbox "Cannot connect to Quality Center" ' If connection is not successful, display an error message.
End If
' Exit QuickTest
qtApp.Quit
' Release the Application object
Set qtApp = Nothing
Set Locate = Nothing
Set MyTrees = Nothing
Set Trees = Nothing
Set TreeMgr = Nothing
Set tdc = Nothing
Msgbox "Download Process is completed"
End Sub
Function WriteScriptNames(strFSPath, strScriptName, ModuleName, resFlag)
iRow = Sheets("Scripts").UsedRange.Rows.Count + 1
Sheets("Scripts").Range("A" & iRow).Value = strFSPath
Sheets("Scripts").Range("B" & iRow).Value = strScriptName
Sheets("Scripts").Range("D" & iRow).Value = ModuleName
Sheets("Scripts").Range("E" & iRow).Value = resFlag
End Function
Function CreateFolder(strFolderPath)
Dim fso, f
Set fso = CreateObject("Scripting.FileSystemObject")
If Not (fso.FolderExists(strFolderPath)) Then
Set f = fso.CreateFolder(strFolderPath)
Set f = Nothing
End If
Set fso = Nothing
End Function
Function DownloadScripts(qtApp, tdc, testPath, strFSPath, ModuleName)
For Each oTestSet In tdc.TreeManager.NodeByPath(testPath).TestFactory.NewList("")
ScriptName = oTestSet.Name
Script = "[QualityCenter] " & testPath & "\" & ScriptName
ScriptFSScript = strFSPath & "\" & ScriptName
resFlag = ""
Flag = False
On Error Resume Next
qtApp.Open Script, False ' Open the test
If Err.Number <> 0 Then
Flag = True
End If
qtApp.Test.SaveAs ScriptFSScript
If Err.Number <> 0 Then
Flag = True
Else
qtApp.Test.Close
End If
If Flag = True Then
resFlag = "Error: " & Err.Description
Flag = False
Err.Clear
Else
resFlag = "Pass"
End If
Call WriteScriptNames(strFSPath, ScriptName, ModuleName, resFlag)
resFlag = ""
Next
End Function
Function DownloadAttachements(qtApp, tdc, testPath, strFSAPath)
For Each oTestSet In tdc.TreeManager.NodeByPath(testPath).TestFactory.NewList("")
ScriptName = oTestSet.Name
Script = "[QualityCenter] " & testPath & "\" & ScriptName
Dim otaAttachmentFactory
Dim otaAttachment 'As TDAPIOLELib.Attachment
Dim otaAttachmentList 'As List,
Dim TAttach 'As Attachment 'As TDAPIOLELib.List
Dim otaTreeManager 'As TDAPIOLELib.TreeManager
Dim otaSysTreeNode 'As TDAPIOLELib.SysTreeNode
Dim otaExtendedStorage, AttachDow
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
Set otaAttachmentFactory = oTestSet.Attachments
Set otaAttachmentList = otaAttachmentFactory.NewList("")
'MsgBox "Attachment Count:" & otaAttachmentList.Count
If otaAttachmentList.Count > 0 Then
Set otaAttachment = otaAttachmentList.Item(1)
otaAttachment.Load True, ""
strPath = otaAttachment.Filename
DownloadAttachements = strPath
SysPathF = strFSAPath & "Attachments_" & oTestSet.Name
Call CreateFolder(SysPathF)
SysPath = SysPathF & "\"
Call CreateFolder(SysPath)
fso.CopyFile strPath, SysPath
Else
'MsgBox "Fail"
DowloadAttachment = "Empty"
End If
Set otaAttachmentFactory = Nothing
Set otaAttachment = Nothing
Set otaAttachmentList = Nothing
Set otaTreeManager = Nothing
Set otaSysTreeNode = Nothing
Set fso = Nothing
Next
End Function
Sub cmdUploadScripts_Click()
'Confirm Upload
Dim Response As VbMsgBoxResult
Response = Msgbox("Confirmation: Upload Scripts to QC?", vbQuestion + vbYesNo)
If Response = vbNo Then
Msgbox "Upload to QC Canceled."
Exit Sub
End If
'Confirm Attachemnt Upload
Dim ResponseA As VbMsgBoxResult
ResponseA = Msgbox("Confirmation: Upload Scripts with Attachments?", vbQuestion + vbYesNo)
If ResponseA = vbYes Then
iReplyA = "Yes"
Else
iReplyA = "No"
Msgbox "Upload Attachments Cancelled."
'Exit Sub
End If
Call GenQCUploadPath
strQualityCenterURL = Trim(Sheets("Scripts").Range("C2").Value)
strDomain = Trim(Sheets("Scripts").Range("C5").Value)
strProject = Trim(Sheets("Scripts").Range("C6").Value)
strUserName = Trim(Sheets("Scripts").Range("C3").Value)
strPassword = Trim(Sheets("Scripts").Range("C4").Value)
strTestPlanProjectPath = Trim(Sheets("Scripts").Range("C8").Value)
RowCount = ThisWorkbook.Worksheets("Scripts").UsedRange.Rows.Count
If RowCount > 13 Then
ThisWorkbook.Worksheets("Scripts").Range("F14", "F" & RowCount).Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Delete Shift:=xlUp
ThisWorkbook.Save
End If
'Get the Paths from Worksheet
strQualityCenterURL = Trim(Sheets("Scripts").Range("C2").Value)
strDomain = Trim(Sheets("Scripts").Range("C5").Value)
strProject = Trim(Sheets("Scripts").Range("C6").Value)
strUserName = Trim(Sheets("Scripts").Range("C3").Value)
strPassword = Trim(Sheets("Scripts").Range("C4").Value)
strTestPlanProjectPath = Trim(Sheets("Scripts").Range("C8").Value)
strSharedFolderPath = Trim(Sheets("Scripts").Range("C9").Value)
Dim qtApp 'As QuickTest.Application ' Declare the Application object variable
Dim tdc
Dim ModuleName
Set qtApp = CreateObject("QuickTest.Application") ' Create the Application object
Set tdc = qtApp.TDConnection.TDOTA
qtApp.Launch ' Start QuickTest
qtApp.Visible = True ' Make the QuickTest application visible
' Connect to the Quality Center
If Not qtApp.TDConnection.IsConnected Then
qtApp.TDConnection.Connect strQualityCenterURL, strDomain, strProject, strUserName, strPassword, False
End If
If qtApp.TDConnection.IsConnected Then ' If connection is successful
iMaxRow = Sheets("Scripts").UsedRange.Rows.Count
Set tdc = qtApp.TDConnection.TDOTA
For iRow = 14 To iMaxRow
strQCPath = Trim(Sheets("Scripts").Range("C" & iRow).Value)
strScriptName = Trim(Sheets("Scripts").Range("B" & iRow).Value)
strFSFolder = Trim(Sheets("Scripts").Range("A" & iRow).Value)
Call UploadScripts(qtApp, strScriptName, strQCPath, strFSFolder, iRow)
If iReplyA = "Yes" Then
strFSAPath = Trim(Sheets("Scripts").Range("A" & iRow).Value) & "\" & Trim(Sheets("Scripts").Range("D" & iRow).Value) & " Attachments\"
Call UploadAttachments(tdc, strScriptName, strQCPath, strFSAPath)
End If
Next
qtApp.TDConnection.Disconnect ' Disconnect from Quality Center
Else
Msgbox "Cannot connect to Quality Center" ' If connection is not successful, display an error message.
End If
qtApp.Quit ' Exit QuickTest
Set qtApp = Nothing ' Release the Application object
Set Locate = Nothing
Set MyTrees = Nothing
Set Trees = Nothing
Set TreeMgr = Nothing
Set tdc = Nothing
Msgbox "Process is completed"
End Sub
Function UploadScripts(qtApp, ScriptName, strQCPath, strFSPath, iRow)
QCScript = "[QualityCenter] " & strQCPath & "\" & ScriptName
ScriptFSScript = strFSPath & "\" & ScriptName
Flag = False
On Error Resume Next
qtApp.Open ScriptFSScript, False ' Open the test
If Err.Number <> 0 Then
Flag = True
Else
qtApp.Test.SaveAs QCScript ' Save it to Quality
End If
If Err.Number <> 0 Then
Flag = True
Else
qtApp.Test.Close ' Disconnect from Quality Cente
End If
If Flag = True Then
Sheets("Scripts").Range("F" & iRow).Value = "Error: " & Err.Description
Flag = False
Err.Clear
Else
Sheets("Scripts").Range("F" & iRow).Value = "Pass"
End If
End Function
'Sub Call1()
'Call GenQCUploadPath
'End Sub
Function GenQCUploadPath()
iMaxRow = Sheets("Scripts").UsedRange.Rows.Count
For nrow = 14 To iMaxRow
If Trim(Sheets("Scripts").Range("D" & nrow).Value) <> "" Then
Sheets("Scripts").Range("C" & nrow).Value = Sheets("Scripts").Range("C8").Value & "\" & Sheets("Scripts").Range("D" & nrow).Value
Else
Sheets("Scripts").Range("C" & nrow).Value = Sheets("Scripts").Range("C8").Value
End If
Next
End Function
Function UploadAttachments(tdc, ScriptName, testPath, strFSAPath)
Flag = 0
On Error Resume Next
For Each oTestSet In tdc.TreeManager.NodeByPath(testPath).TestFactory.NewList("")
ScriptName = oTestSet.Name
If ScriptName = oTestSet.Name And Flag = 0 Then
Flag = 1
Script = "[QualityCenter] " & testPath & "\" & ScriptName
strFSAPath = strFSAPath & "Attachments_" & ScriptName
Dim otaAttachmentFactory
Dim otaAttachment
Dim otaAttachmentList
Dim fso, oFolder, oFile, ExStrg
Set fso = CreateObject("Scripting.FileSystemObject")
Set oFolder = fso.GetFolder(strFSAPath)
If Err.Description = "Path not found" Then
'Msgbox "Test Not found on filesystem. Note the Error. Err.Description:" & Err.Description
nrow = Worksheets("Sheet2").UsedRange.Rows.Count
Sheet2.Cells(nrow + 1, 1) = Err.Description & " for " & ScriptName
End If
'Pending: Check If the folder Exists; If not exit the loop iteration
Set oFile = fso.GetFolder(strFSAPath).Files
On Error Resume Next
For Each oFile In oFolder.Files
Filename = oFile.Name
Set otaAttachmentFactory = oTestSet.Attachments
Set otaAttachment = otaAttachmentFactory.AddItem(Filename)
Filename = strFSAPath & Filename
otaAttachment.Filename = Filename
otaAttachment.Post
Set ExStrg = otaAttachment.AttachmentStorage
ExStrg.ClientPath = Script
ExStrg.Save Filename, True
Next
'Clear
Set otaAttachmentFactory = Nothing
Set otaAttachment = Nothing
Set otaAttachmentList = Nothing
Set fso = Nothing
Set ExStrg = Nothing
End If
Next
End Function
QC slowness is very common issue and HP should take this on priority. But till that time lets see how to overcome this QC slowness issue. One way to write an Excel Macro which will take care of uploading and downloading of QTP scripts. Please see how:
1. this is Excel where you need to provide appropriate details:
------------------------------------------------------------------------------------------------------------------------------
See what happen when user click on download scripts or upload scripts buttons
Sub cmdDownloadScripts_Click()
'Confirm Download
Dim Response As VbMsgBoxResult
Response = Msgbox("Confirmation: Download Scripts from QC?", vbQuestion + vbYesNo)
If Response = vbNo Then
Msgbox "Download Canceled."
Exit Sub
End If
'Confirm Attachment Download
Dim ResponseA As VbMsgBoxResult
ResponseA = Msgbox("Confirmation: Download Scripts with Attachments?", vbQuestion + vbYesNo)
If ResponseA = vbYes Then
iReplyA = "Yes"
Else
iReplyA = "No"
Msgbox "Download Attachments Cancelled."
'Exit Sub
End If
'Clear Results and Values
RowCount = ThisWorkbook.Worksheets("Scripts").UsedRange.Rows.Count
If RowCount > 13 Then
ThisWorkbook.Worksheets("Scripts").Range("A14", "A" & RowCount).Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.EntireRow.Delete
ThisWorkbook.Save
End If
strQualityCenterURL = Trim(Sheets("Scripts").Range("B2").Value)
strDomain = Trim(Sheets("Scripts").Range("B5").Value)
strProject = Trim(Sheets("Scripts").Range("B6").Value)
strUserName = Trim(Sheets("Scripts").Range("B3").Value)
strPassword = Trim(Sheets("Scripts").Range("B4").Value)
strTestPlanProjectPath = Trim(Sheets("Scripts").Range("B8").Value)
strSharedFolderPath = Trim(Sheets("Scripts").Range("B9").Value)
Dim qtApp 'As QuickTest.Application ' Declare the Application object variable
Dim tdc
Dim ModuleName
Set qtApp = CreateObject("QuickTest.Application") ' Create the Application object
qtApp.Launch ' Start QuickTest
qtApp.Visible = True ' Make the QuickTest application visible
' Connect to the Quality Center
If Not qtApp.TDConnection.IsConnected Then
qtApp.TDConnection.Connect strQualityCenterURL, strDomain, strProject, strUserName, strPassword, False
End If
If qtApp.TDConnection.IsConnected Then ' If connection is successful
Set tdc = qtApp.TDConnection.TDOTA
Set TreeMgr = tdc.TreeManager
' Use TreeManager.RootList to get the Subject root.
Set Trees = TreeMgr.RootList(TDOLE_SUBJECT)
Set MyTrees = TreeMgr.NodeByPath(strTestPlanProjectPath)
If MyTrees.Count = 0 Then
ModuleName = ""
testPath = MyTrees.Path
strFSPath = strSharedFolderPath
Call CreateFolder(strFSPath)
If iReplyA = "Yes" Then
strFSAPath = strFSPath & "\" & Trim(ModuleName) & " Attachments\"
Call CreateFolder(strFSAPath)
End If
Call DownloadScripts(qtApp, tdc, testPath, strFSPath, ModuleName)
If iReplyA = "Yes" Then
Call DownloadAttachements(qtApp, tdc, testPath, strFSAPath)
End If
End If
Call CreateFolder(strSharedFolderPath)
For iChild = 1 To MyTrees.Count
ModuleName = Trim(MyTrees.Child(iChild).Name)
strFSPath = strSharedFolderPath & "\" & ModuleName
Call CreateFolder(strFSPath)
If iReplyA = "Yes" Then
strFSAPath = strFSPath & "\" & ModuleName & " Attachments\"
Call CreateFolder(strFSAPath)
End If
Set Locate = MyTrees.FindChildNode(ModuleName)
testPath = Locate.Path
Call DownloadScripts(qtApp, tdc, testPath, strFSPath, ModuleName)
If iReplyA = "Yes" Then
Call DownloadAttachements(qtApp, tdc, testPath, strFSAPath)
End If
Next
qtApp.TDConnection.Disconnect ' Disconnect from Quality Center
Else
Msgbox "Cannot connect to Quality Center" ' If connection is not successful, display an error message.
End If
' Exit QuickTest
qtApp.Quit
' Release the Application object
Set qtApp = Nothing
Set Locate = Nothing
Set MyTrees = Nothing
Set Trees = Nothing
Set TreeMgr = Nothing
Set tdc = Nothing
Msgbox "Download Process is completed"
End Sub
Function WriteScriptNames(strFSPath, strScriptName, ModuleName, resFlag)
iRow = Sheets("Scripts").UsedRange.Rows.Count + 1
Sheets("Scripts").Range("A" & iRow).Value = strFSPath
Sheets("Scripts").Range("B" & iRow).Value = strScriptName
Sheets("Scripts").Range("D" & iRow).Value = ModuleName
Sheets("Scripts").Range("E" & iRow).Value = resFlag
End Function
Function CreateFolder(strFolderPath)
Dim fso, f
Set fso = CreateObject("Scripting.FileSystemObject")
If Not (fso.FolderExists(strFolderPath)) Then
Set f = fso.CreateFolder(strFolderPath)
Set f = Nothing
End If
Set fso = Nothing
End Function
Function DownloadScripts(qtApp, tdc, testPath, strFSPath, ModuleName)
For Each oTestSet In tdc.TreeManager.NodeByPath(testPath).TestFactory.NewList("")
ScriptName = oTestSet.Name
Script = "[QualityCenter] " & testPath & "\" & ScriptName
ScriptFSScript = strFSPath & "\" & ScriptName
resFlag = ""
Flag = False
On Error Resume Next
qtApp.Open Script, False ' Open the test
If Err.Number <> 0 Then
Flag = True
End If
qtApp.Test.SaveAs ScriptFSScript
If Err.Number <> 0 Then
Flag = True
Else
qtApp.Test.Close
End If
If Flag = True Then
resFlag = "Error: " & Err.Description
Flag = False
Err.Clear
Else
resFlag = "Pass"
End If
Call WriteScriptNames(strFSPath, ScriptName, ModuleName, resFlag)
resFlag = ""
Next
End Function
Function DownloadAttachements(qtApp, tdc, testPath, strFSAPath)
For Each oTestSet In tdc.TreeManager.NodeByPath(testPath).TestFactory.NewList("")
ScriptName = oTestSet.Name
Script = "[QualityCenter] " & testPath & "\" & ScriptName
Dim otaAttachmentFactory
Dim otaAttachment 'As TDAPIOLELib.Attachment
Dim otaAttachmentList 'As List,
Dim TAttach 'As Attachment 'As TDAPIOLELib.List
Dim otaTreeManager 'As TDAPIOLELib.TreeManager
Dim otaSysTreeNode 'As TDAPIOLELib.SysTreeNode
Dim otaExtendedStorage, AttachDow
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
Set otaAttachmentFactory = oTestSet.Attachments
Set otaAttachmentList = otaAttachmentFactory.NewList("")
'MsgBox "Attachment Count:" & otaAttachmentList.Count
If otaAttachmentList.Count > 0 Then
Set otaAttachment = otaAttachmentList.Item(1)
otaAttachment.Load True, ""
strPath = otaAttachment.Filename
DownloadAttachements = strPath
SysPathF = strFSAPath & "Attachments_" & oTestSet.Name
Call CreateFolder(SysPathF)
SysPath = SysPathF & "\"
Call CreateFolder(SysPath)
fso.CopyFile strPath, SysPath
Else
'MsgBox "Fail"
DowloadAttachment = "Empty"
End If
Set otaAttachmentFactory = Nothing
Set otaAttachment = Nothing
Set otaAttachmentList = Nothing
Set otaTreeManager = Nothing
Set otaSysTreeNode = Nothing
Set fso = Nothing
Next
End Function
Sub cmdUploadScripts_Click()
'Confirm Upload
Dim Response As VbMsgBoxResult
Response = Msgbox("Confirmation: Upload Scripts to QC?", vbQuestion + vbYesNo)
If Response = vbNo Then
Msgbox "Upload to QC Canceled."
Exit Sub
End If
'Confirm Attachemnt Upload
Dim ResponseA As VbMsgBoxResult
ResponseA = Msgbox("Confirmation: Upload Scripts with Attachments?", vbQuestion + vbYesNo)
If ResponseA = vbYes Then
iReplyA = "Yes"
Else
iReplyA = "No"
Msgbox "Upload Attachments Cancelled."
'Exit Sub
End If
Call GenQCUploadPath
strQualityCenterURL = Trim(Sheets("Scripts").Range("C2").Value)
strDomain = Trim(Sheets("Scripts").Range("C5").Value)
strProject = Trim(Sheets("Scripts").Range("C6").Value)
strUserName = Trim(Sheets("Scripts").Range("C3").Value)
strPassword = Trim(Sheets("Scripts").Range("C4").Value)
strTestPlanProjectPath = Trim(Sheets("Scripts").Range("C8").Value)
RowCount = ThisWorkbook.Worksheets("Scripts").UsedRange.Rows.Count
If RowCount > 13 Then
ThisWorkbook.Worksheets("Scripts").Range("F14", "F" & RowCount).Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Delete Shift:=xlUp
ThisWorkbook.Save
End If
'Get the Paths from Worksheet
strQualityCenterURL = Trim(Sheets("Scripts").Range("C2").Value)
strDomain = Trim(Sheets("Scripts").Range("C5").Value)
strProject = Trim(Sheets("Scripts").Range("C6").Value)
strUserName = Trim(Sheets("Scripts").Range("C3").Value)
strPassword = Trim(Sheets("Scripts").Range("C4").Value)
strTestPlanProjectPath = Trim(Sheets("Scripts").Range("C8").Value)
strSharedFolderPath = Trim(Sheets("Scripts").Range("C9").Value)
Dim qtApp 'As QuickTest.Application ' Declare the Application object variable
Dim tdc
Dim ModuleName
Set qtApp = CreateObject("QuickTest.Application") ' Create the Application object
Set tdc = qtApp.TDConnection.TDOTA
qtApp.Launch ' Start QuickTest
qtApp.Visible = True ' Make the QuickTest application visible
' Connect to the Quality Center
If Not qtApp.TDConnection.IsConnected Then
qtApp.TDConnection.Connect strQualityCenterURL, strDomain, strProject, strUserName, strPassword, False
End If
If qtApp.TDConnection.IsConnected Then ' If connection is successful
iMaxRow = Sheets("Scripts").UsedRange.Rows.Count
Set tdc = qtApp.TDConnection.TDOTA
For iRow = 14 To iMaxRow
strQCPath = Trim(Sheets("Scripts").Range("C" & iRow).Value)
strScriptName = Trim(Sheets("Scripts").Range("B" & iRow).Value)
strFSFolder = Trim(Sheets("Scripts").Range("A" & iRow).Value)
Call UploadScripts(qtApp, strScriptName, strQCPath, strFSFolder, iRow)
If iReplyA = "Yes" Then
strFSAPath = Trim(Sheets("Scripts").Range("A" & iRow).Value) & "\" & Trim(Sheets("Scripts").Range("D" & iRow).Value) & " Attachments\"
Call UploadAttachments(tdc, strScriptName, strQCPath, strFSAPath)
End If
Next
qtApp.TDConnection.Disconnect ' Disconnect from Quality Center
Else
Msgbox "Cannot connect to Quality Center" ' If connection is not successful, display an error message.
End If
qtApp.Quit ' Exit QuickTest
Set qtApp = Nothing ' Release the Application object
Set Locate = Nothing
Set MyTrees = Nothing
Set Trees = Nothing
Set TreeMgr = Nothing
Set tdc = Nothing
Msgbox "Process is completed"
End Sub
Function UploadScripts(qtApp, ScriptName, strQCPath, strFSPath, iRow)
QCScript = "[QualityCenter] " & strQCPath & "\" & ScriptName
ScriptFSScript = strFSPath & "\" & ScriptName
Flag = False
On Error Resume Next
qtApp.Open ScriptFSScript, False ' Open the test
If Err.Number <> 0 Then
Flag = True
Else
qtApp.Test.SaveAs QCScript ' Save it to Quality
End If
If Err.Number <> 0 Then
Flag = True
Else
qtApp.Test.Close ' Disconnect from Quality Cente
End If
If Flag = True Then
Sheets("Scripts").Range("F" & iRow).Value = "Error: " & Err.Description
Flag = False
Err.Clear
Else
Sheets("Scripts").Range("F" & iRow).Value = "Pass"
End If
End Function
'Sub Call1()
'Call GenQCUploadPath
'End Sub
Function GenQCUploadPath()
iMaxRow = Sheets("Scripts").UsedRange.Rows.Count
For nrow = 14 To iMaxRow
If Trim(Sheets("Scripts").Range("D" & nrow).Value) <> "" Then
Sheets("Scripts").Range("C" & nrow).Value = Sheets("Scripts").Range("C8").Value & "\" & Sheets("Scripts").Range("D" & nrow).Value
Else
Sheets("Scripts").Range("C" & nrow).Value = Sheets("Scripts").Range("C8").Value
End If
Next
End Function
Function UploadAttachments(tdc, ScriptName, testPath, strFSAPath)
Flag = 0
On Error Resume Next
For Each oTestSet In tdc.TreeManager.NodeByPath(testPath).TestFactory.NewList("")
ScriptName = oTestSet.Name
If ScriptName = oTestSet.Name And Flag = 0 Then
Flag = 1
Script = "[QualityCenter] " & testPath & "\" & ScriptName
strFSAPath = strFSAPath & "Attachments_" & ScriptName
Dim otaAttachmentFactory
Dim otaAttachment
Dim otaAttachmentList
Dim fso, oFolder, oFile, ExStrg
Set fso = CreateObject("Scripting.FileSystemObject")
Set oFolder = fso.GetFolder(strFSAPath)
If Err.Description = "Path not found" Then
'Msgbox "Test Not found on filesystem. Note the Error. Err.Description:" & Err.Description
nrow = Worksheets("Sheet2").UsedRange.Rows.Count
Sheet2.Cells(nrow + 1, 1) = Err.Description & " for " & ScriptName
End If
'Pending: Check If the folder Exists; If not exit the loop iteration
Set oFile = fso.GetFolder(strFSAPath).Files
On Error Resume Next
For Each oFile In oFolder.Files
Filename = oFile.Name
Set otaAttachmentFactory = oTestSet.Attachments
Set otaAttachment = otaAttachmentFactory.AddItem(Filename)
Filename = strFSAPath & Filename
otaAttachment.Filename = Filename
otaAttachment.Post
Set ExStrg = otaAttachment.AttachmentStorage
ExStrg.ClientPath = Script
ExStrg.Save Filename, True
Next
'Clear
Set otaAttachmentFactory = Nothing
Set otaAttachment = Nothing
Set otaAttachmentList = Nothing
Set fso = Nothing
Set ExStrg = Nothing
End If
Next
End Function
No comments:
Post a Comment