Excel VBA code to attach files in QC Test Cases - vba

I have a tool that capture screenshots of the application that we test at our workplace. Now once I complete my testing of a particular test case or scenarios, we attach the screenshot that we have taken to HP Quality Center manually.
I want to automate this and make my tool to upload the word document to a test in QC Test Lab. Is this possible? If Yes, How can we do this in Excel VBA?
Operations that we need to perform would be as below:
Connect to QC project with login credentials, domain & project details
Pick a file(s) from a local folder
Upload a file(s) to QC Test Lab, specific test case
I used the below code, but getting error in that code. I marked it in the code below, please check below :
Dim intTestID, FldPath, TestSetName, i
Dim TestSetFact, tsTreeMgr, tSetFolder, TestSetsList, theTestSet
Dim TestSetIdentifier, TSTestFact, TestSetTestsList, testInstanceF, aFilter
Dim lst, tstInstance
intTestID = "8968"
FldPath = TextBox3.Text '"Root\ProjFold\Release1\BRD"
TestSetName = ComboBox3.Text '"BRD" '
Set Connection = CreateObject("TDApiOle80.TDConnection")
Connection.InitConnectionEx Sheet2.Range("B1").Value2
Connection.Login TextBox1.Text, TextBox2.Text
Connection.Connect ComboBox1.Text, ComboBox2.Text
Set TestSetFact = Connection.TestSetFactory
Set tsTreeMgr = Connection.TestSetTreeManager
Set tSetFolder = tsTreeMgr.NodeByPath(FldPath)
Set TestSetsList = tSetFolder.FindTestSets(TestSetName)
Set theTestSet = TestSetsList.Item(1)
TestSetIdentifier = theTestSet.ID
i = 0
Set TSTestFact = theTestSet.TSTestFactory
Set TestSetTestsList = TSTestFact.NewList("")
Set testInstanceF = Connection.TSTestFactory
Set aFilter = testInstanceF.Filter
aFilter.Filter("TC_TEST_ID") = intTestID
Set lst = testInstanceF.NewList(aFilter.Text)
Set tstInstance = lst.Item(1) <---------------- getting error here
MsgBox (tstInstance.Field("TS_Name"))
'tstInstance.Status = "Failed"
'tstInstance.Field("TC_STATUS") = Item1.Status '"Passed"
'tstInstance.Post
Dim RunF, runName, NewRun, runStepF, runlst, Item1, runStep2
MsgBox (tstInstance.Field("TS_Subject"))
Set RunF = tstInstance.RunFactory
runName = "Run_" & Month(Date) & "-" & Day(Date) & "_" & Hour(Now) & "-" & Minute(Now) & "-" & Second(Now)
Set NewRun = RunF.AddItem(Null)
NewRun.Status = "Passed"
NewRun.Name = runName
NewRun.Post
NewRun.CopyDesignSteps
NewRun.Post
Set runStepF = NewRun.StepFactory
Set runlst = runStepF.NewList("")
For Each Item1 In runlst
Set runStep2 = Item1
runStep2.Status = "Passed" '
runStep2.Field("ST_ACTUAL") = "As Expected"
runStep2.Post
Next
'tstInstance.Refresh
tstInstance.Status = "Failed"
tstInstance.Post
Connection.DisconnectProject
Connection.ReleaseConnection
'Set QC = Nothing
Set Connection = Nothing

The error is occurring because the array of objects is not returning. You need to check if the Filter gives you a list of results before assuming that lst.Item(1) exists.
For instance:
If lst.Count > 0 Then Set tstInstance = lst.Item(1)

Related

Find text of a childnode in a javatree in UFT

I am trying to get the text/label of a child node of a javatree NOT the index.
How do i do that in UFT ?
My Java tree is as below
Code that i have tried :
Dim itemsCount
Dim nodeName
Dim myText
Dim selectItem()
Dim ProgramName
ProgramName = "17030-3 Parameter, programming"
itemsCount = CInt(WpfWindow("Tech Tool").JavaWindow("Program_ECU").JavaTree("Program_Control_Unit").GetROProperty("items count"))
Redim selectItem(itemsCount)
Set objItem = WpfWindow("Tech Tool").JavaWindow("Program_ECU").JavaTree("Program_Control_Unit").Object
For i = 0 To itemsCount-1
'selectItem(i)=WpfWindow("Tech Tool").JavaWindow("Program_ECU").JavaTree("Program_Control_Unit").GetItem(i)
selectItem(i)=WpfWindow("Tech Tool").JavaWindow("Program_ECU").JavaTree("Program_Control_Unit").Select ("#0;#"&i)
If Trim(CStr(ProgramName)) = Trim(CStr(objItem.getItem(i))) Then
objItem.Select(i)
msgbox "Success"
End If
Next
I have also tried using .GetColumnValue("#0;#1") but that also did not work
Traversing JTree in UFT is complicated than it should be. Here is what I did when I had to traverse through a JTree
Set JTree = WpfWindow("Tech Tool").JavaWindow("Program_ECU").JavaTree("Program_Control_Unit").Object
'return how many nodes there are in the tree irrespective of their level
MsgBox JTree.getRowCount
Set JModel = JTree.getModel 'get jtree data model
Set JRoot = JModel.getRoot 'get root so that we can traverse the tree
Call JTreeWalk(JModel, JRoot)
'recursively traverse the jtree
Sub JTreeWalk(JModel, objNode)
ctr = JModel.getChildCount(objNode)
For i = 0 To ctr - 1
Set objChild = JModel.getChild(objNode, i)
If JModel.isLeaf(objChild) Then
Print vbTab & objChild.toString
Else
Print "~~ " & objChild.toString & " ~~"
End If
Call JTreeWalk(JModel, objChild)
Next
End Sub
Useful links
https://docs.oracle.com/javase/tutorial/uiswing/components/tree.html
http://www.rgagnon.com/javadetails/java-0313.html (I used this java code and converted into vbs)

ListRows.Add doesn't appear to work

I've got a really odd case… hopefully someone is able to help me out, I've search many forums looking for a solution, the closest I could find related to it (kinda) is here, though I've tried all the suggestions to no avail…
I'm trying to run a function to return a data list in a string delimitated by a semicolon from an oracle stored function. (This value function call seems to work fine).
I then loop through the string for each data value and print it to a blank table (0 rows) declared in my subroutine. which I use to load into an access data base. (just trust it make sense in the big picture…).
The issue, fundamentally is that no information is printed into the table. However when I step through the code it works fine.
After troubleshooting I THINK (see my test scenarios below code) the issue comes up after the listrows.add line... though not obviously.
I don't think this line is executed by the time the first value is trying to print to the table.
The most confusing part is I'm running through 2 nearly identical procedures (call function -> Return value -> print values to table) immediately before this portion of the code and they work without fail.
Code Excerpt:
'run function to get string ... this works
DoEvents ' not in original design
RelRtnStr = Prnt(Cat, "A Third Oracle Function Name")
DoEvents ' not in original design
RelChopVar = RelRtnStr
StrFldCnt = 0
Checking = True ''' CodeBreak Test 1
DoEvents ' not in original design
AppendRlLmTbl.ListRows.Add ''''''''This isn't appearing to work...
DoEvents ' not in original design
Debug.Print Now ' not in original design
Application.Wait (Now + TimeValue("0:00:3")) ' not in original design
Debug.Print Now ' not in original design
While StrFldCnt < 80 And (Len(RelChopVar) - Len(Replace(RelChopVar, ";", ""))) > 0 And Checking
'## Count String Position
StrFldCnt = StrFldCnt + 1
'## Find Current String Value & Remainder String
If InStr(RelChopVar, ";") <> 0 Then
'Multiple Values Left
FldVal = Replace(Left(RelChopVar, InStr(RelChopVar, ";")), ";", "")
RelChopVar = Right(RelChopVar, Len(RelChopVar) - InStr(RelChopVar, ";"))
Else
'Last Value
FldVal = RelChopVar
Checking = False
End If
'## Get Field Name For Current Value & Print to Table
FldNm = CStr(RefRtrn(2, CStr(StrFldCnt))) ''' CodeBreak Test 2
AppendRlLmTbl.ListColumns(FldNm).DataBodyRange.Value = FldVal '''CodeBreak 2 error thrown
Debug.Print StrFldCnt & FldNm & FldVal
Wend
AppendRlLmTbl.ListColumns("Catalogue").DataBodyRange.Value = Cat
So far I've tested a ton of options suggested online, not necessarily understanding each test... This is what I've gleaned.
If I step through the code, it works
If I set a breakpoint at "CodeBreak Test 1" and "F5" the rest, it works …
If I set a breakpoint at "CodeBreak Test 2" I get an "Object with variable not set" error thrown …
Things I've tried …
Wrapping anything and everything with DoEvents
setting a wait time after the listObjects.add row
Validated the code performs the While loop when running the "full procured" (as opposed to stepping through)
The worst part, I have no idea why the object won't declare properly when setting a break point after the add row line but sets properly when break point is set before and has no error thrown when running the full procedure (I have no on error declarations.)...
It of course must be related in my mind but I can't find any information online and unfortunately have no formal VBA background and 1 undergrad course as a programming background in general. Aka I'm out of my depth and super frustrated.
PS. first post, so please be nice :p
Full Code Below:
Option Explicit
'## Here's my attempt to clean up and standardize the flow
'## Declare my public variables
' WorkBook
Public WB As Workbook
' Sheets
Public Req2ByWS As Worksheet
Public ReqSpecsWS As Worksheet
Public ReqInstrcWS As Worksheet
Public ConfigReqWS As Worksheet
Public AppendReqWS As Worksheet
Public AppendRlLmWS As Worksheet
' Objects (tables)
Public ReqConfigTbl As ListObject
Public SpecConfigTbl As ListObject
Public CurrRegIDTbl As ListObject
Public AppendReqTbl As ListObject
Public AppendRlLmTbl As ListObject
'## ##
'## Get Data from Tom's Functions ##
Sub GetSpotBuyData()
'## Preliminary Config ##
'## Turn OFF Warnings & Screen Updates
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'## Set global Referances to be used in routine
' WorkBooks
Set WB = Workbooks("MyWb.xlsm")
' WorkSheets
Set Req2ByWS = WB.Sheets("MyWb Pg1")
Set ReqSpecsWS = WB.Sheets("MyWb Pg2")
Set ConfigReqWS = WB.Sheets("MyWb Pg3")
Set AppendReqWS = WB.Sheets("MyWb Pg4")
Set AppendRlLmWS = WB.Sheets("MyWb Pg5")
' Tables
Set ReqConfigTbl = ConfigReqWS.ListObjects("MyWS Tbl1")
Set SpecConfigTbl = ConfigReqWS.ListObjects("MyWS Tbl2")
Set CurrRegIDTbl = ConfigReqWS.ListObjects("MyWS Tbl3")
Set AppendReqTbl = AppendReqWS.ListObjects("MyWS Tbl4")
Set AppendRlLmTbl = AppendRlLmWS.ListObjects("MyWS Tbl5")
'## Declare Routine Specefic Variables
Dim Doit As Variant
Dim Checking As Boolean
Dim Cat As String
Dim CatRtnStr As String
Dim CatChopVar As String
Dim SpecRtnStr As String
Dim SpecChopVar As String
Dim RelRtnStr As String
Dim RelChopVar As String
Dim FldVal As String
Dim FldNm As String
Dim StrFldCnt As Integer
'## 1) General Set-Up ##
'## Unprotect tabs (loop through All Tabs Unprotect)
Doit = Protct(False, WB, "Mypassword")
'## Refresh Data
Doit = RunUpdateAl(WB)
'## 2) Find the Catalgue we are playing with ##
'## Grab Catalogue input from ISR
If [Catalogue].Value = "" Then
MsgBox ("Please Enter a Catalogue")
GoTo ExitSub
Else
Cat = [Catalogue].Value
End If
'## 3) Run Toms Function and print the results to the form & Append Table ##
'## 3a) Do it for Cat Info Function
'## Get Cat Info String From Function
CatRtnStr = Prnt(Cat, "An Oracle Functions Name")
CatChopVar = CatRtnStr
If CatChopVar = "No Info" Then
MsgBox ("No Info Found in Catalogue Data Search.")
GoTo SkipCatInfoPrint
End If
'## Loop Through Data String & Write to Form
StrFldCnt = 0
Checking = True
AppendReqTbl.ListRows.Add
While Checking
'## Count String Position
StrFldCnt = StrFldCnt + 1
'## Find Current String Value & Remainder String
If InStr(CatChopVar, ";") <> 0 Then
'Multiple Values Left
FldVal = Replace(Left(CatChopVar, InStr(CatChopVar, ";")), ";", "")
CatChopVar = Right(CatChopVar, Len(CatChopVar) - InStr(CatChopVar, ";"))
Else
'Last Value
FldVal = CatChopVar
Checking = False
End If
'## Get Field Name For Current Value & Print to Form
FldNm = CStr(RefRtrn(1, CStr(StrFldCnt)))
If FldNm <> "CustomerSpecification" And FldNm <> "ShiptoAddress" Then
'Take Value as is
Req2ByWS.Range(FldNm).Value = FldVal
AppendReqTbl.ListColumns(FldNm).DataBodyRange.Value = FldVal
ElseIf FldNm = "CustomerSpecification" Then
'Replace : with New Line
FldVal = Replace(FldVal, " : ", vbLf)
Req2ByWS.Range(FldNm).Value = FldVal
AppendReqTbl.ListColumns(FldNm).DataBodyRange.Value = FldVal
ElseIf FldNm = "ShiptoAddress" Then
'Replace - with New Line
FldVal = Replace(FldVal, " - ", vbLf)
Req2ByWS.Range(FldNm).Value = FldVal
AppendReqTbl.ListColumns(FldNm).DataBodyRange.Value = FldVal
End If
Wend
'## 3b) Do it for Spec Function
SkipCatInfoPrint:
'## Get Spec Info String From Function
SpecRtnStr = Prnt(Cat, "Another Oracle Functions Name")
SpecChopVar = SpecRtnStr
If SpecChopVar = "No Info" Then
MsgBox ("No Info Found in Data Search.")
GoTo SkipSpecInfoPrint
End If
'## Loop Through Data String & Write to Form
StrFldCnt = 0
Checking = True
While StrFldCnt < 80 And (Len(SpecChopVar) - Len(Replace(SpecChopVar, ";", ""))) > 0 And Checking
'## Count String Position
StrFldCnt = StrFldCnt + 1
'## Find Current String Value & Remainder String
If InStr(SpecChopVar, ";") <> 0 Then
'Multiple Values Left
FldVal = Replace(Left(SpecChopVar, InStr(SpecChopVar, ";")), ";", "")
SpecChopVar = Right(SpecChopVar, Len(SpecChopVar) - InStr(SpecChopVar, ";"))
Else
'Last Value
FldVal = SpecChopVar
Checking = False
End If
'## Get Field Name For Current Value & Print to Form
FldNm = CStr(RefRtrn(2, CStr(StrFldCnt)))
ReqSpecsWS.Range(FldNm).Value = FldVal
AppendReqTbl.ListColumns(FldNm).DataBodyRange.Value = FldVal
Wend
'## 3c) Do it for Rel Limits Function
SkipSpecInfoPrint:
'## Get Rel Limits String From Function
RelRtnStr = Prnt(Cat, "A Third Functions Name")
RelChopVar = RelRtnStr
If RelChopVar = "No Info" Then
MsgBox ("No Info Found in Data Search.")
GoTo ExitSub
End If
'## Loop Through Data String & Write to Form
StrFldCnt = 0
Checking = True
AppendRlLmTbl.ListRows.Add
While StrFldCnt < 80 And (Len(RelChopVar) - Len(Replace(RelChopVar, ";", ""))) > 0 And Checking
'## Count String Position
StrFldCnt = StrFldCnt + 1
'## Find Current String Value & Remainder String
If InStr(RelChopVar, ";") <> 0 Then
'Multiple Values Left
FldVal = Replace(Left(RelChopVar, InStr(RelChopVar, ";")), ";", "")
RelChopVar = Right(RelChopVar, Len(RelChopVar) - InStr(RelChopVar, ";"))
Else
'Last Value
FldVal = RelChopVar
Checking = False
End If
'## Get Field Name For Current Value & Print to Form
FldNm = CStr(RefRtrn(2, CStr(StrFldCnt)))
AppendRlLmTbl.ListColumns(FldNm).DataBodyRange.Value = FldVal
Wend
AppendRlLmTbl.ListColumns("SpecificFieldName").DataBodyRange.Value = Cat
'## 4) Re-Format and Clean Up Program ##
ExitSub:
'## Clean-Up Formatting
Req2ByWS.Range("F:F", "C:C").ColumnWidth = 30
Req2ByWS.UsedRange.Rows.AutoFit
Req2ByWS.UsedRange.Columns.AutoFit
Req2ByWS.Range("G:G").ColumnWidth = 15
Req2ByWS.Range("J:R").ColumnWidth = 12
Req2ByWS.Range("D:D").ColumnWidth = 12
'## Protect tabs (loop through All Tabs Protect)
'Doit = Protct(True, WB, "Mypassword", Req2ByWS.Name)
'Req2ByWS.Unprotect ("Mypassword")
'Application.Wait (Now + TimeValue("0:00:10"))
Req2ByWS.Select
'## Turn ON Warnings & Screen Updates
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
I stupidly had an enable background refresh for that specific table. An early call to refresh all data triggered the refresh, code would execute and the refresh would finally complete shortly after the code finished executing... in break mode the refresh would complete prior too. Thanks PEH for helping me look into this.

VBA Send/Pull Data from External Workbook -- Interesting Issue

I have a rather interesting problem going on in my excel problem. Basically I have two Workbooks, lets say
ACTIVE.xlsm and EXTERNAL.xls
Active has a macro that opens external and drops in some data from active, then reads a solution on external and returns it to the user on the active workbook. Whew. Thats a tough one. Now that we're through that, heres the problem. It is my personal opinion that there is a glitch in external (which I'm unable to fix as its a company read-only file) that when active drops in its data into a specific drop-down (data validation) cell (other data validation cells work fine with this macro, its only this one that doesn't), the solution cell on external doesnt update, but rather jumps to "#N/A". At this point, my VBA has run into a bug, and the code stops with external still open. When I look at external, I've deduced that this singular variable cell is the problem amdist all the other variable cells determining the solution.
The variable cell at this point contains the number "150" and although the data validation allows for this option, the solution cell still says "#N/A". It isn't until I physically click inside of the cell with "150" like I'm going to edit it, then I press enter, that the #N/A corrects to the appropriate solution (Let's say this solution is "$352.08") Keep in mind, the value within the variable cell never changed, it perhaps only was "refreshed".
Any ideas as to why this is happening? I know this is long-winded, but I suppose that's why I have been unable to find a solution thus far. Perhaps there's a VBA workaround that can simulate clicking in the cell, then pressing enter, who knows!
Thanks in advance!
Here's some code for funsies, though I don't believe this is a code issue, as it works for all other "external"'s that I've been working with.
...ElseIf Left(Range("C9").Value, 4) = "LA23" Then
CurWkbk = ActiveWorkbook.Name
PartNo = Worksheets("LINAK ONE").Range("C6").Value
PartNoID_B = Worksheets("GPL Pull").Range("B8").Value
PartNoID_C = Worksheets("GPL Pull").Range("C8").Value
PartNoID_D = Worksheets("GPL Pull").Range("D8").Value
PartNoID_E = Worksheets("GPL Pull").Range("E8").Value
PartNoID_F = Worksheets("GPL Pull").Range("F8").Value
PartNoID_G = Worksheets("GPL Pull").Range("G8").Value
PartNoID_H = Worksheets("GPL Pull").Range("H8").Value
PartNoID_I = Worksheets("GPL Pull").Range("I8").Value
PartNoID_J = Worksheets("GPL Pull").Range("J8").Value
PartNoID_K = Worksheets("GPL Pull").Range("K8").Value
Workbooks.Open ("EXTERNAL.xls")
Workbooks("EXTERNAL.xls").Sheets("Price").Activate
Range("E9").Value = PartNoID_B
Range("G9").Value = PartNoID_C
Range("I9").Value = PartNoID_D
Range("K9").Value = PartNoID_E
Range("M9").Value = PartNoID_F
Range("O9").Value = PartNoID_G
Range("Q9").Value = PartNoID_H
Range("S9").Value = PartNoID_I
Range("S9").Select
ActiveCell.Calculate
Range("U9").Value = PartNoID_J
Range("W9").Value = PartNoID_K
Range("AD7").Value = "LUS"
LUSPrice = Range("AE9").Value
Range("AD7").Value = "USD"
USDPrice = Range("AE9").Value
Range("AD7").Value = "DKK"
DKKPrice = Range("AE9").Value
Windows(CurWkbk).Activate
ActiveWorkbook.Sheets("Discount Calculator").Activate
Range("D5").Value = LUSPrice
ActiveWorkbook.Sheets("PRICE GENERATOR").Activate
Range("C25").Value = PartNo & " Pricing | LUS: $" & Round(LUSPrice, 2) & " | USD: $" & Round(USDPrice, 2) & " | DKK: kr " & Round(DKKPrice, 2)
MsgBox "Tillykke! Pricing for the " & PartNo & " has been generated. The price has been entered into the discount calculator.", , "Pricing Generated"
Workbooks("EXTERNAL.xls").Close False...
you should be using fully qualified references to cells
this is a rewrite of your code
...ElseIf Left(Range("C9").Value, 4) = "LA23" Then ' which workbook/sheet ????
CurWkbk = ActiveWorkbook.Name ' which workbook ????
PartNo = Worksheets("LINAK ONE").Range("C6").Value ' which workbook ????
With Worksheets("GPL Pull")
PartNoID_B = .Range("B8").Value
PartNoID_C = .Range("C8").Value
PartNoID_D = .Range("D8").Value
PartNoID_E = .Range("E8").Value
PartNoID_F = .Range("F8").Value
PartNoID_G = .Range("G8").Value
PartNoID_H = .Range("H8").Value
PartNoID_I = .Range("I8").Value
PartNoID_J = .Range("J8").Value
PartNoID_K = .Range("K8").Value
End With
Workbooks.Open ("EXTERNAL.xls")
With Workbooks("EXTERNAL.xls").Worksheets("Price")
.Range("E9").Value = PartNoID_B
.Range("G9").Value = PartNoID_C
.Range("I9").Value = PartNoID_D
.Range("K9").Value = PartNoID_E
.Range("M9").Value = PartNoID_F
.Range("O9").Value = PartNoID_G
.Range("Q9").Value = PartNoID_H
.Range("S9").Value = PartNoID_I
.Range("S9").Calculate
.Range("U9").Value = PartNoID_J
.Range("W9").Value = PartNoID_K
.Range("AD7").Value = "LUS"
LUSPrice = .Range("AE9").Value
.Range("AD7").Value = "USD"
USDPrice = .Range("AE9").Value
.Range("AD7").Value = "DKK"
DKKPrice = .Range("AE9").Value
End With
CurWkbk.Worksheets("Discount Calculator").Range("D5").Value = LUSPrice ' which workbook ????
CurWkbk.Worksheets("PRICE GENERATOR").Range("C25").Value = PartNo & " Pricing | LUS: $" & Round(LUSPrice, 2) & " | USD: $" & Round(USDPrice, 2) & " | DKK: kr " & Round(DKKPrice, 2)
MsgBox "Tillykke! Pricing for the " & PartNo & " has been generated. The price has been entered into the discount calculator.", , "Pricing Generated"
Workbooks("EXTERNAL.xls").Close False...

How to Retrieve Values only from Nodes Having Specific Attributes in VBA EXCEL (VBA DOM) XML.

I need to retrieve only the values from nodes which their attribute are "true". Here's what I have and what I need - appreciate any help:
<AudioTracks>
<original available="true">ENG</original>
<localized available="false">SPA</localized>
<localized available="true">POR</localized>
</AudioTracks>
Here's my code, it will retrieve all values, but I would like to find a way to only retrieve ENG and POR (true). I can't seem to find a suitable way to do it.
'AudioTracks
Set oAudioNodes = featureNode.SelectSingleNode("videos/video/AudioTracks")
For i = 0 To oAudioNodes.ChildNodes.Length
sAudio = oAudioNodes.ChildNodes.Item(i).nodeTypedValue & ";" & sAudio
Next
sAudio = Left(sAudio, Len(sAudio) - 1)
ActiveSheet.Cells(intRow, colAudioTracks).Value = NullCheck(sAudio)
sAudio = ""
sRawData = ""
This will return me ENG;SPA;POR ... But I need it to return only ENG;POR
Help me Obi Wan, you're my only hope.
Eureka. I have found a way to make this happen. Not beautiful but works just fine! I just did a small conditional using the getAttribute property. As a parameter, I have just used the attribute name (in this case "available"). Ha! Beautiful - for me.
Set oAudioNodes = featureNode.SelectSingleNode("videos/video/AudioTracks")
txt = ""
For i = 0 To oAudioNodes.ChildNodes.Length
txt = oAudioNodes.ChildNodes.Item(i).getAttribute("available")
If txt = "true" Then sAudio = oAudioNodes.ChildNodes.Item(i).nodeTypedValue & ";" & sAudio
Next
sAudio = Left(sAudio, Len(sAudio) - 1)
ActiveSheet.Cells(intRow, colAudioTracks).Value = NullCheck(sAudio)
sAudio = ""
sRawData = ""
txt = ""

CMS automation in VBA stalls after 63 iterations

I am writing an automation script as I have a need to run a report on 16 separate split skills each day for a period of 6 months. The script works, with one problem. It will run 63 iterations (i.e. 3 days at 16 = 48 + 15 = 63). After the 15th loop (63rd overall iteration) it will give an error: "microsoft excel is waiting for another application to complete an OLE action" It would appear to me, though I could very easily be wrong, that either I am overloading a variable or possibly not fully closing something on the CMS side. The fact that it is the 63rd iteration (64-1) seems awfully suspicious, but I am not sure what I could be overloading as far as variables going. I don't have any 8-bit variables (unless I am missing something). Also, I should point out that after running the macro, I am uanble to log back into the CMS app manually without restarting, so my hunch is that I am not fully closing something and that maybe there is a limit on the number of instances allowed in CMS. I included the script below, except that the names of the skills, server address, username and password have been removed for security reasons. Any help would be greatly appreciated.
Public Sub Single_CMS_Report_Extract()
On Error Resume Next
' Add the files specified below to the References section:
' Tools -> References -> Browse to the CMS directory,
' e.g.: "C:\Program Files\Avaya\CMS Supervisor R14"
Dim cmsApplication As ACSUP.cvsApplication 'acsApp.exe
Dim cmsServer As ACSUPSRV.cvsServer 'acsSRV.exe
Dim cmsConnection As ACSCN.cvsConnection 'cvsconn.dll
Dim cmsCatalog As ACSCTLG.cvsCatalog 'cvsctlg.dll
Dim cmsReport As Object 'ACSREP.cvsReport 'acsRep.exe
Dim myLog As String, myPass As String, myServer As String
Dim reportPath As String, reportName As String, reportPrompt(1 To 2, 1 To 3) As String
Dim exportPath As String, exportName As String
Dim StartRunTime, EndRunTime As Date
Dim DayToRun, EndDate As Date
Dim Skill(1 To 16) As String
MsgBox ("Please ensure CMS open and logged in prior to continuing")
StartRunTime = Now
'Start Date
DayToRun = "12/16/2015"
'End Date
EndDate = "12/21/2015"
Skill(1) = "XXXXXXXX"
Skill(2) = "XXXXXXXX"
Skill(3) = "XXXXXXXX"
Skill(4) = "XXXXXXXX"
Skill(5) = "XXXXXXXX"
Skill(6) = "XXXXXXXX"
Skill(7) = "XXXXXXXX"
Skill(8) = "XXXXXXXX"
Skill(9) = "XXXXXXXX"
Skill(10) = "XXXXXXXX"
Skill(11) = "XXXXXXXX"
Skill(12) = "XXXXXXXX"
Skill(13) = "XXXXXXXX"
Skill(14) = "XXXXXXXX"
Skill(15) = "XXXXXXXX"
Skill(16) = "XXXXXXXX"
While DayToRun < (EndDate + 1)
For i = 1 To 16
' Assigns Variables
myLog = "myuser"
myPass = "mypass"
myServer = "xx.xx.xx.xx"
'reportPath is the tab and "Category" that the report is found in Avaya
reportPath = "Historical\Split/Skill\"
reportName = "Summary Interval"
'list of input names requested.....
reportPrompt(1, 1) = "Split/Skill"
reportPrompt(1, 2) = "Date"
reportPrompt(1, 3) = "Times"
'list of responses being used for input
reportPrompt(2, 1) = Skill(i)
reportPrompt(2, 2) = DayToRun
reportPrompt(2, 3) = "00:00-23:30"
'path and name of exported report file
exportPath = "H:\Avaya data\"
If i <> 5 Then
exportName = Month(DayToRun) & "-" & Day(DayToRun) & "-" & Skill(i) & ".csv"
Else
exportName = Month(DayToRun) & "-" & Day(DayToRun) & "- DL-Toll Free" & ".csv"
End If
' Open the CMS Application, launches acsApp.exe
' If a CMS Supervisor console is already open,
' the existing acsApp.exe is used.
Set cmsApplication = CreateObject("ACSUP.cvsApplication")
Set cmsServer = CreateObject("ACSUPSRV.cvsServer")
Set cmsConnection = CreateObject("ACSCN.cvsConnection")
cmsConnection.bAutoRetry = True
' Connetsc to the server, launches acsSRV.exe & ACSTrans.exe (2x)
If cmsApplication.CreateServer(myLog, myPass, "", myServer, False, "ENU", cmsServer, cmsConnection) Then
If cmsConnection.login(myLog, myPass, myServer, "ENU", "", False) Then
End If
End If
' Gets collection of Reports available on cmsServer
Set cmsCatalog = cmsServer.Reports
If cmsServer.Connected = False Then cmsServer.Reports.ACD = 1
' Sets parameters for report, launches ACSRep.exe (2x)
cmsCatalog.CreateReport cmsCatalog.Reports.Item(reportPath & reportName), cmsReport
If cmsReport.SetProperty(reportPrompt(1, 1), reportPrompt(2, 1)) And cmsReport.SetProperty(reportPrompt(1, 2), reportPrompt(2, 2)) And cmsReport.SetProperty(reportPrompt(1, 3), reportPrompt(2, 3)) Then
End If
' Runs report and extracts results --- the 44 is the field delimiter
cmsReport.ExportData exportPath & exportName, 44, 0, False, False, True
' Kills active report & server
If Not cmsServer.Interactive Then
cmsServer.ActiveTasks.Remove cmsReport.TaskID
cmsApplication.Servers.Remove cmsServer.ServerKey
End If
' Logs out
cmsReport.Quit
cmsConnection.Logout
cmsConnection.Disconnect
cmsServer.Connected = False
' Releases objects
Set cmsReport = Nothing
Set cmsCatalog = Nothing
Set cmsConnection = Nothing
Set cmsServer = Nothing
Set cmsApplication = Nothing
Next
i = Nothing
DayToRun = DateAdd("d", 1, DayToRun)
Wend
EndRunTime = Now
MsgBox ("Run-time = " & Minute(EndRunTime - StartRunTime) & ":" & Second(EndRunTime - StartRunTime))
End Sub