Thanks so much for your quick reply, Trudy!
We are using HP ALM 11.00 patch level 16. I've attached some jpgs showing what I described in my previous post. I've also inserted the code we're using based on the PDF and text file you posted just in case we have some copy/paste errors.
Common Script:
Dim myFolderID
Dim myFolderPath
Function ActionCanExecute(ActionName)
'Use ActiveModule and ActiveDialogName to get
'the current context.
On Error Resume Next
'beginning of new customized code to move test plan to test lab
select case ActionName
Case "UserDefinedActions.copytolab"
copyToLab()
End Select
'end of new customized code to move test plan to test lab
'Use the following script to redirect this function to the module specific function:
'Select Case ActiveModule
' Case "Defects"
' ActionCanExecute = Defects_ActionCanExecute(ActionName)
' Case "Test Lab"
' ActionCanExecute = TestLab_ActionCanExecute(ActionName)
' Case "Test Plan"
' ActionCanExecute = TestPlan_ActionCanExecute(ActionName)
' Case "Requirements"
' ActionCanExecute = Requirements_ActionCanExecute(ActionName)
' Case "Management"
' ActionCanExecute = Management_ActionCanExecute(ActionName)
' Case "Test Resources"
' ActionCanExecute = Resources_ActionCanExecute(ActionName)
' Case "Business Components"
' ActionCanExecute = Components_ActionCanExecute(ActionName)
' Case "Dashboard"
' ActionCanExecute = Analysis_ActionCanExecute(ActionName)
' Case "Business Models"
' ActionCanExecute = BusinessModels_ActionCanExecute(ActionName)
'End Select
ActionCanExecute = DefaultRes
On Error GoTo 0
End FunctionTestFolder_MoveTo:
Sub TestFolder_MoveTo
On Error Resume Next
'beginning of new customized code to move test plan to test lab
myFolderID = TestFolder_Fields.Field("AL_ITEM_ID").Value
set TreeMgr = TDConnection.TreeManager
set TestPlanFolder = TreeMgr.NodeByID(myFolderID)
myFolderPath = TestPlanFolder.Path
Set TreeMgr = Nothing
set TestPlanFolder = Nothing
'end of new customized code to move test plan to test lab
On Error GoTo 0
End SubExtensions script:
Sub copyToLab()
On Error Resume Next
'Preparation'
Set tdc = TDConnection
Set treemgr = tdc.treemanager
Set myTestFact = tdc.TestFactory
Set myTestFilter = myTestFact.Filter
' build filter regarding the last known folder'
myTestFilter.Filter("TS_SUBJECT") = "^\" & myFolderPath & "^"
Set myTestList = myTestFact.NewList(myTestFilter.Text)
'are you sure you want to copy?'
strMsg = myTestList.Count & " Test Cases to copy!" & vbCRLF
strMsg = strMsg & "Begin copy of " & myFolderPath & " now?"
result = MsgBox (strMsg,vbYesNo,"Test Plan kopieren?")
If result = vbNo Then
' no copy wanted
msgbox "Copy Cancelled"
Exit Sub
End If
'now the fun begins
For Each actTest In myTestList
' Node of Subject-Folder
Set mySNode = actTest.Field("TS_Subject")
' Path of Subject-Folder [Subject\... (w/o Testname)]
myPath = mySNode.Path
'build testset and add testinstance
result = build_case(myPath,actTest)
Next 'Testcase
'now the end is near
MsgBox "Copy Completed", vbOKOnly
MsgBox "Click the Refresh button in the Test Lab module to see the new data", vbOKOnly
Set myTestList = Nothing
Set myTestFilter = Nothing
Set myTestFact = Nothing
On Error GoTo 0
End Sub
Function build_case(CurrentPath, CurrentTest)
Dim tdcF
Dim TStmgr
Dim myRoot
Dim newTSTest
On Error Resume Next
' Preparation
Set tdcF = TDConnection
Set TStmgr = tdcF.TestSetTreeManager
' Split path for loop
subjectArray = Split(currentPath, "\")
' initialize variable for path
' Remember: Test Plan begins with Subject and Test Lab with Root!
NewPath = "Root"
OldPath = ""
'Begin loop
For idx = 1 To UBound(subjectArray)
'save path
OldPath = NewPath
'get new folder
CurrentSubName = subjectArray(idx)
'build new path
NewPath = Trim(NewPath) & "\" & CurrentSubname
'search Folder
Set newNode = TStmgr.NodeByPath(NewPath)
'create folder if it does not exist
If newNode Is Nothing Then
Set TStmgr = Nothing
Set TStmgr = tdcF.TestSetTreeManager
If idx = 1 Then
Set myRoot = TStmgr.Root
Else
Set myRoot = TStmgr.NodeByPath(OldPath)
End If ' idx'
Set newNode = myRoot.addNode(CurrentSubName)
newNode.post
End If 'new Node
' if the current folder is the last folder of the array
' create a testset (if necessary) and add the current test
If idx = UBound(subjectArray) Then
'Check: Does the testset exist?
' create a filter with Folder-id and -name
Set testSetF = newNode.TestSetFactory
Set testSetFilter = testSetF.Filter
testSetFilter.Filter("CY_FOLDER_ID") = NewNode.Nodeid
testSetFilter.Filter("CY_CYCLE") = CurrentSubName
Set TSList = testSetF.newList(testSetFilter.Text)
'Add Testset only if necessary
If TSList.Count = 0 Then
'nothing found'
Set testSet1 = testSetF.AddItem(Null)
testSet1.Name = CurrentSubName
testSet1.Status = "Open"
testSet1.Post
Else
'else get it
Set testSet1 = TSList.Item(1)
End If 'TSList
'Check: testinstance
'DO not use FindTestInstance (way too much overhead)
Set TSTestF = TestSet1.TSTestFactory
Set TSTestList = TSTestF.newList("")
'initialize marker
foundTS = 0
If TSTestList.Count > 0 Then
For Each myTSTest In TSTestList
If myTSTest.testId = Trim(CurrentTest.ID & " ") Then
foundTS = 1
End If
Next ' myTSTest
End If ' TSTestList
'Add Test if necessary :)
If foundTS = 0 Then
'nothing found => add test to testset
Set newTSTest = TSTestF.AddItem(CurrentTest.ID)
newTSTest.Post
End If ' foundTS
End If ' idx
'-------------------------------------------------?-----
'Cleanup for objects (just to be sure)
Set newTSTest = Nothing
Set myTSTest = Nothing
Set testSetFilter = Nothing
Set TSTestF = Nothing
Set TSTestList = Nothing
Set testSetFilter = Nothing
Set testSetF = Nothing
Set folder = Nothing
Set newNode = Nothing
Next 'idx
On Error GoTo 0
build_case = True
End Function
Thanks so much!