I'm running a few vb scripts on my QC server using the script editor.
I'm using QC 12, i have a function that is establishing a connection using QC api, getting some data then incrementing this data by one, the thing is that it's getting an empty value from the DB.
Here is the function:
Function SW_KeepTIDLastValue()
On Error Resume Next
Dim tdc, val
Dim cset
Dim bld
On Error Resume Next
bld = ""
Set tdc = TDConnection 'Open a connection using the QC API
Set tdc = CreateObject("TDApiOle80.TDConnection")
Set cset = tdc.CommonSettings
'Set cset = tdc.COMMON_SETTINGS
cset.Open ("KeepTIDValueSetting")
val = cset.Value("KeepTIDValueField") 'Retrieve the value stored in the DB
' val = CDbl(cset.Value("KeepTIDValueField"))
msgbox(TypeName(val) & " " & val)
SW_KeepTIDLastValue = val+1 'Increment the value by 1
msgbox(TypeName(val) & " " & SW_KeepTIDLastValue )
cset.Value("KeepTIDValueField") = val+1 'Store the value back in the DB
cset.Close
If Err.Number <> 0 Then
SW_DisplayError Err.Number, Err.Description, "Keep Last Value (" & action & ")"
End If
On Error GoTo 0
End Function
Related
when I m trying to set Recordset using oracle connection string, I m getting OUt of memory error.
on line "rsLIS.Open sql, gConnLIS, adOpenStatic, adLockReadOnly"
However some time it works like once in 5-6 attempts
but when it works it gives error on some other line
on line "If rsLink.Fields(2).value = rsLIS.Fields(1).value Then"
here are the things which I tried :
instead of directly using recordset, I tried to create array (GetRows) method.
Even though recordset count is 26 but UBound of array is showing 1
I have trying changing 3rd argument value from static to forward only
in line ""rsLIS.Open sql, gConnLIS, adOpenStatic, adLockReadOnly""
it also didn't work, it was showing recordset.count as 0
Did try after restarting the client system still same
I m getting this error on client side and since at my place I don't have development environment to debug
Error is "OUT OF MEMORY"
Public Function GetResults_New(MachName As String, patid As String, bCheckDate As Boolean, SendAssay As Boolean) As ADODB.Recordset
On Error GoTo errdesc
Call ShowTempMsg("Line 1")
Dim bXVar As Boolean
Dim i, j As Integer
Dim tmplis, tmporder
Dim tmpresult
bXVar = False
Dim rec_result As New ADODB.Recordset
Dim rsLink As New ADODB.Recordset
Dim rsLIS As New ADODB.Recordset
Dim xSampleIdType As String
gAppPath = AddEditINIfile("VAHSIF.INI", "IF", "sLinkPath", "")
xSampleIdType = AddEditINIfile(gAppPath & "\sLinkConfig.ini", MachName, "SampleIdType", "SampleId1", False)
Call Open_Connection
Call Open_Connection_LIS
rec_result.CursorLocation = adUseClient
If SendAssay = True Then
rec_result.Fields.Append "machineparamid", adBSTR, 50
rec_result.Fields.Append "Assayno", adBSTR, 50
rec_result.Fields.Append "SType", adBSTR, 50
rec_result.Fields.Append "Dilution", adBSTR, 50
Else
rec_result.Fields.Append "machineparamid", adBSTR, 50
rec_result.Fields.Append "SType", adBSTR, 50
rec_result.Fields.Append "Dilution", adBSTR, 50
End If
rec_result.Open
\
'Link Query For Mapped Params.
sql = "SELECT EquipParamMapping.EquipId, EquipParamMapping.EquipParamCode, EquipParamMapping.LISParamCode, EquipParamMapping.EquipAssayNo from EquipParam, EquipParamMapping where equipParam.equipid = equipparammapping.equipid and equipparam.equipparamcode = equipparammapping.equipparamcode and EquipParam.EquipID = '" & MachName & "' and EquipParam.isProgram = 'Y'"
**rsLink.Open sql, gConn, adOpenStatic, adLockReadOnly**
If enumConnTo = connOracle Then
sql = "select " & xSampleIdType & " , LIS_Param_Code From SL_21CI_View_sampleid_Orders where " & xSampleIdType & " || SuffixCode = '" & patid & "' and isApplicable <> 'N' "
Else
sql = "select " & xSampleIdType & " , LIS_Param_Code From SL_21CI_View_sampleid_Orders where " & xSampleIdType & " + cast(SuffixCode as varchar(20)) = '" & patid & "' and isApplicable <> 'N' "
End If
rsLIS.Open sql, gConnLIS, adOpenStatic, adLockReadOnly
While Not rsLIS.EOF
If bXVar = True Then
rsLink.MoveFirst
bXVar = False
End If
While Not rsLink.EOF
bXVar = True
**If rsLink.Fields(2).value = rsLIS.Fields(1).value Then**
If SendAssay = True Then
rec_result.AddNew
rec_result("machineparamid") = rsLink.Fields("EquipParamCode")
rec_result("Assayno") = rsLink.Fields("EquipAssayNo")
rec_result("SType") = " "
rec_result("Dilution") = "0"
rec_result.Update
rec_result.MoveFirst
Else
rec_result.AddNew
rec_result("machineparamid") = rsLink.Fields("EquipParamCode")
rec_result("SType") = " "
rec_result("Dilution") = "0"
rec_result.Update
rec_result.MoveFirst
End If
GoTo NextParam
End If
rsLink.MoveNext
Wend
NextParam:
rsLIS.MoveNext
Wend
Set GetResults_New = rec_result
Exit Function
errdesc:
Call InsertIntoLogWithFileName("Transaction.GetResults_New" & vbNewLine & sql & vbNewLine & err.Description & "ErrLine : " & ErrLine)
End Function
Thanks
That still leaves the question on which line the error occurs. Also: "it also didn't work, it was showing recordset.count as 0". The RecordSet.Count property depends on the provider. Use a function similar to this instead:
Public Function RecordCount(ByVal cn As ADODB.Connection, ByVal sTable As String) As Long
Dim sSQL As String, lRetVal as Long
Dim rs As ADODB.Recordset
Set rs = New ADODB.Recordset
sSQL = "SELECT COUNT(1) AS RecCount FROM " & sTable & ";"
Call rs.Open(sSQL, cn)
If Not (rs.BOF And rs.EOF) Then
lRetVal = rs.Fields("RecCount").Value
Else
lRetVal = -1
End If
Call rs.Close
Set rs = Nothing
RecordCount = lRetVal
End Function
The .Count property might also very well be the cause of the Out of memory error, as I seem to remember that for determing the number of records, it loads all records (from the server) to count them. But I might be wrong there.
In the code bellow I get an error on the line reading recset.Close.
Char: 5
Error: Operation is not allowed when the object is closed.
Code: 800A0E78
Source: ADODB.Recordset
If the program reaches the line PQ_ID_number = InputBox("Enter PQ Database ID number, Do not use / ? < > \ : * | !", "PQ ID Number", "Replace Text") it seems to work fine (taking manual input) but when it tries to get the ID from the URL of a browser (automaticaly) it gives the error.
valid_name = 0
Dim objInstances, objIE, counterTab
Do While valid_name = 0 'Flag to exit the loop if the Id number has content in the SQL Database'
'-----------------------------------------------------------------------------------------'
Set objInstances = CreateObject("Shell.Application").windows
If objInstances.Count > 0 Then '/// make sure we have IE instances open.
'Loop through each tab.'
For Each objIE In objInstances
'Split the url of current tab using /'
splitURL = Split(objIE.LocationURL,"/")
'Count how many sub strings are in the URL when split'
counter = UBound(splitURL)
if counter = 7 Then
lastSplit = Split(splitURL(7),".")
lastURL = splitURL(0) & "//" & splitURL(2) & "/" & splitURL(3) & "/" & splitURL(4) & "/" & splitURL(5) & "/" & splitURL(6) & "/" & lastSplit(0)
if lastURL = "URL" Then
Set IE = objIE
counterTab = counterTab + 1
end if
end if
'End if
Next
Else
'If no internet explorer window is open.'
MsgBox "No Internet Explorer window found."
wscript.quit
End if
'Check if no [] is open in internet explorer'
if IsObject(IE) Then
url = Split(IE.LocationURL,"=")
url2 = Split(url(1),"&")
PQ_ID_number = url2(0)
else
MsgBox "No incident found."
wscript.quit
end if
'counterTab counts how many [] are open. If there is more than 1, ask for confirmation of last [] number.'
if counterTab > 1 Then
confirm = msgbox("Please confirm Incident ID: " & incidentID,vbYesNo,"Confirmation")
'If no is pressed, ask for manual entry.'
if confirm = vbNo Then
PQ_ID_number = InputBox("Enter PQ Database ID number, Do not use / ? < > \ : * | !", "PQ ID Number", "Replace Text")
On Error Resume Next
If PQ_ID_number = False Then
wscript.quit
End If
end if
end if
'-----------------------------------------------------------------------------------------'
'Open connection in Database'
dbConnectStr = "connection string"
Set con = CreateObject("ADODB.Connection")
Set recset = CreateObject("ADODB.Recordset")
con.Open dbConnectStr
'Get PQ Database title and status of incident number provided.
SQL_String = "Select title, status_id from incident_TBL where incident_ID = " & PQ_ID_number
recset.Open SQL_String, con
title = recset.Fields(0).Value
incidentStatus = recset.Fields(1).Value
con.Close
recset.Close
If title = False Then 'check if PQ_ID given has content in SQL Database
wscript.echo "Invalid PQ Database ID number, please type correct number"
valid_name = 0
Else
valid_name = 1
End If
Loop
Thanks for the help!
you need close Recordset first and only after that close connection
con.Close
recset.Close
change to:
recset.Close
con.Close
Here is my code, I am trying to open a connection to our database and then using ActiveX to return all the data from column in a table and then outputting it to a text document. I'm getting this error.
PullData.vbs(41, 1) ADODB.Recordset: Item cannot be found in the
collection corresponding to the requested name or ordinal.
Here is my code, omitting sensitive information:
Const ForReading = 1
Dim sServer
Dim sLogin
Dim sPwd
Dim sDb
Dim oCn
Dim oRs
sServer = ""
sLogin = ""
sPwd = ""
sDb = ""
Set oCn = CreateObject( "ADODB.Connection" ) ' set oCn to create an object called ADODB.Connection
Set oRs = CreateObject( "ADODB.Recordset" ) ' set oRs to create an object called ADODB.Recordset
oCn.ConnectionString = "PROVIDER=SQLOLEDB" & _
";SERVER=" & sServer & _
";UID=" & sLogin & _
";PWD=" & sPwd & _
";DATABASE=" & sDb & " "
oCn.ConnectionTimeout=600
oCn.open 'Open the connection to the server
strSelString = "select CallID from dbo.CallLog" 'this is the SQL statement that runs a query on the DB
oRs.Open strSelString,oCn 'This opens the record set and has two parameters, strSelString and oCn
If oRs.EOF Then 'If open record set is at the end of file then...
wscript.echo "There are no records to retrieve; Check that you have the correct record number." 'echo that there is no records to retrieve.
End if
'if there are records then loop through the fields
Do While Not oRs.EOF ' Do while not open record set is not end of file
strfield = ors("Tracker")
if strfield <> "" then 'If strfield doesn't equal "" then
Set objFileSystem = WScript.CreateObject("Scripting.FileSystemObject") 'Set objFileSystem to create object Scripting.FileSystemObject
Set objOutPutFile = objFileSystem.CreateTextFile("c:\test.txt", True) 'Set objOutPutFile to create object objFileSystem.CreateTextFile
strcomputer = oRs 'strcomputer is set to read the line
wscript.echo strfield
objOutPutFile.WriteLine strfield &"|"
objFileSystem.close
objOutPutFile.close
end if
oRs.MoveNext
oCn.Close
Loop
You ask for the CallID column;
"select CallID from dbo.CallLog"
but then try to read something else:
strfield = ors("Tracker")
so either select Tracker or read CallID.
You could also probably create/open the file outside of the loop.
I have two .vbs file say a.vbs and b.vbs.Now both are written for the same Excel,but would work on 2 different sheets.So can we run those in parallel?
EDIT
a.vbs will update sheet2 and b.vbs will update sheet3.But for both source sheet is sheet1.
Please advice how to set such environment
CODE A
Option Explicit
Dim objExcel1
Dim strPathExcel1
Dim objSheet1,objSheet2
Dim IntRow1,IntRow2
Dim ColStart
Set objExcel1 = CreateObject("Excel.Application")'Object for Condition Dump
strPathExcel1 = "D:\AravoVB\Copy of Original Scripts\CopyofGEWingtoWing_latest_dump_21112012.xls"
objExcel1.Workbooks.open strPathExcel1
Set objSheet1 = objExcel1.ActiveWorkbook.Worksheets(1)
Set objSheet2 = objExcel1.ActiveWorkbook.Worksheets("Bad Data")
objExcel1.ScreenUpdating = False
objExcel1.Calculation = -4135 'xlCalculationManual
IntRow2=2
IntRow1=4
Do Until IntRow1 > objSheet1.UsedRange.Rows.Count
ColStart = objExcel1.Application.WorksheetFunction.Match("Parent Business Process ID", objSheet1.Rows(3), 0) + 1
Do Until ColStart > objSheet1.UsedRange.Columns.Count And objSheet1.Cells(IntRow1,ColStart) = ""
If objSheet1.Cells(IntRow1,ColStart + 1) > objSheet1.Cells(IntRow1,ColStart + 5) And objSheet1.Cells(IntRow1,ColStart + 5) <> "" Then
objSheet1.Range(objSheet1.Cells(IntRow1,1),objSheet1.Cells(IntRow1,objSheet1.UsedRange.Columns.Count)).Copy
objSheet2.Range(objSheet2.Cells(IntRow2,1),objSheet2.Cells(IntRow2,objSheet1.UsedRange.Columns.Count)).PasteSpecial
IntRow2=IntRow2+1
Exit Do
End If
ColStart=ColStart+4
Loop
IntRow1=IntRow1+1
Loop
objExcel1.ScreenUpdating = True
objExcel1.Calculation = -4105 'xlCalculationAutomatic
CODE B
Option Explicit
Dim objExcel1
Dim strPathExcel1
Dim objSheet1,objSheet2
Dim IntRow1,IntRow2
Dim Flag
Dim IntColTemp,IntRowTemp
Dim Strcmp1,Strcmp2
Flag=0
IntColTemp=1
IntRowTemp=3
Set objExcel1 = CreateObject("Excel.Application")'Object for Condition Dump
If Err.Number <> 0 Then
On Error GoTo 0
Wscript.Echo "Excel application not found."
Wscript.Quit
End If
strPathExcel1 = "D:\VA\CopyofGEWingtoWing_latest_dump_21112012.xls"
objExcel1.Workbooks.open strPathExcel1
Set objSheet1 = objExcel1.ActiveWorkbook.Worksheets(1)
Set objSheet2 = objExcel1.ActiveWorkbook.Worksheets(2)
IntRow1=4
IntRow2=1
Do While objSheet1.Cells(IntRow1, 1).Value <> ""
objSheet2.Cells(IntRow2, 1).Value = objSheet1.Cells(IntRow1, 1).Value
IntColTemp=1
Flag=0
'This will travarse to the Parent Business Process ID column horizantally in the excel.
Do While Flag=0
If objSheet1.Cells(IntRowTemp,IntColTemp).Value="Parent Business Process ID" Then
Flag=1
End If
IntColTemp=IntColTemp+1
Loop
IntColTemp=IntColTemp-1
'MsgBox(IntColTemp)
Strcmp1=trim(objSheet1.Cells(IntRow1, 1).Value)
Strcmp2=trim(objSheet1.Cells(IntRow1,IntColTemp).Value)
If Strcmp1=Strcmp2 Then
objSheet2.Cells(IntRow2, 2).Value="Parent"
Else
objSheet2.Cells(IntRow2, 2).Value="child"
End If
IntRow1=IntRow1+1
IntRow2=IntRow2+1
Loop
Working on two different sheets should be possible by putting something like this in both of your scripts:
strPathExcel1 = "D:\CopyofGEWingtoWing_latest_dump_21112012.xls"
On Error Resume Next
Set objExcel1 = GetObject(, "Excel.Application") ' attach to running instance
If Err.Number = 429 Then ' if that fails
Err.Clear
Set objExcel1 = CreateObject("Excel.Application") ' create new instance
If Err Then ' if that still fails
WScript.Echo Err.Description & " (0x" & Hex(Err.Number) & ")"
WScript.Quit 1 ' report error and terminate
End If
objExcel1.Workbooks.Open strPathExcel1
End If
On Error Goto 0
However, I doubt that this approach would gain you enough performance to justify the additional complexity.
In CODE A replace the lines
Set objExcel1 = CreateObject("Excel.Application")'Object for Condition Dump
strPathExcel1 = "D:\AravoVB\Copy of Original Scripts\CopyofGEWingtoWing_latest_dump_21112012.xls"
objExcel1.Workbooks.open strPathExcel1
with the above code block.
In CODE B replace the lines
Set objExcel1 = CreateObject("Excel.Application")'Object for Condition Dump
If Err.Number <> 0 Then
On Error GoTo 0
Wscript.Echo "Excel application not found."
Wscript.Quit
End If
strPathExcel1 = "D:\VA\CopyofGEWingtoWing_latest_dump_21112012.xls"
objExcel1.Workbooks.open strPathExcel1
with the above code block.
here is my code
Dim Cn1 As ADODB.Connection
Dim iSQLStr As String
Dim field_num As Integer
Set Cn1 = New ADODB.Connection
Cn1.ConnectionString = _
"Driver={Microsoft Text Driver (*.txt; *.csv)};" & _
"DefaultDir=" & "C:\path\"
Cn1.Open
iSQLStr = "Select * FROM " & "file.txt" ' & " ORDER BY " & txtField.Text
field_num = CInt(1) - 1
Set Rs1 = Cn1.Execute(iSQLStr)
lstResults.Clear
While Not Rs1.EOF
DoEvents
Rs1.Fields(field_num).Value = "qaz"
If IsNull(Rs1.Fields(field_num).Value) Then
lstResults.AddItem "<null>"
Else
lstResults.AddItem Rs1.Fields(field_num).Value
End If
Rs1.MoveNext
Wend
The error i get is in this line
Rs1.Fields(field_num).Value = "qaz"
it says "The current recordset does not support updating", what is wrong in the code?
I'm not sure if this is valid for text files but with SQL Server you need to change the LockTypeEnum Value setting to allow editing see this link, the default is adLockReadOnly
Edit
According to this link it is not possible to edit a text file via ADO.