I wrote this function for selecting all values at option "select all"
Private Function Not_Null()
If CmbGrade.Text = "SELECT ALL" Then
sql = "SELECT A.ROLLNO,A.FIRST_NAME,A.MIDDLE_NAME,A.LAST_NAME,A.ADDRESS,A.GRADE,B.DIV,A.BLOOD_GROUP,C.HOUSE,A.DATE_OF_BIRTH,A.TRANSPORT,A.SNAME,A.MEAL,A.RUTNO FROM STUDENT_RECORD_DATABASE A,DIVISION B,HNM C WHERE A.DIVID=B.DIVID AND A.HID=C.HID AND GRADE IS NOT NULL"
SET rs = cn.Execute(sql)
End If
End Function
After I called this function at command click
Private Sub CmdReport_Click()
Dim STRp As String
STRp = Not_Null()
sql = "SELECT A.ROLLNO,A.FIRST_NAME,A.MIDDLE_NAME,A.LAST_NAME,A.ADDRESS,A.GRADE,B.DIV,A.BLOOD_GROUP,C.HOUSE,A.DATE_OF_BIRTH,A.TRANSPORT,A.SNAME,A.MEAL,A.RUTNO FROM STUDENT_RECORD_DATABASE A,DIVISION B,HNM C WHERE A.DIVID=B.DIVID AND A.HID=C.HID"
Set rs = cn.Execute(sql)
Set DataReport2.DataSource = rs
DataReport2.Show
End Sub
When I choose "select all" option it doesn't show any record
Please help..........
It doesn't matter that you're executing STRp = Not_Null(), because (a) Not_Null doesn't return a value and (b) even though you're doing a SET rs in Not_Null, then even assuming you've declared rs somewhere in your module or form, you're just overwriting its value in CmdReport_Click.
Try this:
Private Sub CmdReport_Click()
sql = "SELECT A.ROLLNO,A.FIRST_NAME,A.MIDDLE_NAME,A.LAST_NAME,A.ADDRESS,A.GRADE,B.DIV,A.BLOOD_GROUP,C.HOUSE,A.DATE_OF_BIRTH,A.TRANSPORT,A.SNAME,A.MEAL,A.RUTNO FROM STUDENT_RECORD_DATABASE A,DIVISION B,HNM C WHERE A.DIVID=B.DIVID AND A.HID=C.HID AND GRADE ='" & CmbGrade.Text & "'"
If CmbGrade.Text = "SELECT ALL" Then
sql = "SELECT A.ROLLNO,A.FIRST_NAME,A.MIDDLE_NAME,A.LAST_NAME,A.ADDRESS,A.GRADE,B.DIV,A.BLOOD_GROUP,C.HOUSE,A.DATE_OF_BIRTH,A.TRANSPORT,A.SNAME,A.MEAL,A.RUTNO FROM STUDENT_RECORD_DATABASE A,DIVISION B,HNM C WHERE A.DIVID=B.DIVID AND A.HID=C.HID AND GRADE IS NOT NULL"
End If
Set rs = cn.Execute(sql)
Set DataReport2.DataSource = rs
DataReport2.Show
End Sub
Also, it's obvious that you're lacking even the most basic understanding of your programming language (VB). I highly suggest picking up an introductory book on the subject, or searching for an online introductory tutorial before you go any further.
Related
private Command1_Click()
Dim a as string
a = text1.text
OpenQuery "SELECT * FROM a WHERE Chair;"
txtChair.Text = myRs.Fields(0).Value
myRs.MoveNext
loop
end sub
Your code sample is missing a an opening Do statement, possibly an over site. Also, #nabuchodonossor is correct in that at best a the end of the loop the value of field(0) for the last record will be in txtChair.Text. But what you're asking for help with is to build a single string query where you are substituting a variable value for part of the string.
Private Command1_Click()
Dim a as string
a = text1.text
'this query isn't right, but not sure what to do with it
'this is something like normally "WHERE Field = 'Chair'"
OpenQuery "SELECT * FROM " & a & " WHERE Chair;" 'The & concatenates the separate strings
Do While rs.EOF = False
txtChair.Text = myRs.Fields(0).Value
myRs.MoveNext
Loop
End Sub
MSDN link to the & Operator
I recently had to migrate an (inherited) old Classic ASP VBScript reporting website from a windows server 2003 to windows server 2012.
After messing about with the AppPool to make it use 32bit mode, and also set up parent paths, I've been able to get the application to work.
However, the following page is currently throwing this error:
Microsoft VBScript runtime error '800a01a8'
Object required: ''
/Dashboard/modules/Monthly_Report/footfall/Save_Session_Variables_Stock.asp, line 69
The code behind the page is
<!--#include file="../../../../Connections/Dashboard_Connection.asp" -->
<%
Session.LCID=2057
'Session("strMonthly_Site")=trim(request("select_site"))
''xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'Set the search screen variables to be nothing
Session("strCategory_Lookup")=""
Session("strSearch_String")=""
'*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-
'Get the market code based on the site
'*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-
DIM rsGet_Market
Set objConn = Server.CreateObject("ADODB.Connection")
objConn.Open strConnection
'Get the Site Level_Code
Session("SITE_LVL") = MID(Session("strMonthly_Site"),INSTR(Session("strMonthly_Site"),",")+ 1, 2)
Session("SITE_LVL_CODE") = LEFT(Session("strMonthly_Site"),INSTR(Session("strMonthly_Site"),",")-1)
SELECT CASE CINT(Session("SITE_LVL"))
CASE 1 'Site
strQuery = "SELECT SITE_MARKET.MARKET_CODE, SITE_MARKET.MARKET_TEXT, SITE_ZONE.ZONE_CODE, SITE_ZONE.ZONE_TEXT, SITE_AREA.AREA_CODE, SITE_AREA.AREA_TEXT, SITE.SITE_CODE, SITE.SITE_TEXT " & _
"FROM SITE_REGION INNER JOIN SITE_MARKET ON SITE_REGION.REGION_CODE = SITE_MARKET.REGION_CODE INNER JOIN SITE INNER JOIN SITE_AREA ON SITE.AREA_CODE = SITE_AREA.AREA_CODE " & _
"INNER JOIN SITE_ZONE ON SITE_AREA.ZONE_CODE = SITE_ZONE.ZONE_CODE ON SITE_MARKET.MARKET_CODE = SITE_ZONE.MARKET_CODE " & _
"WHERE SITE.SITE_CODE = '" & Session("SITE_LVL_CODE") & "'"
Set rsGet_Market = Server.Createobject("ADODB.Recordset")
rsGet_Market.Open strQuery, objConn
Session("Market_Market_Code") = rsGet_Market("MARKET_CODE") & " - " & rsGet_Market("MARKET_TEXT")
Session("Market_Zone_Code") = rsGet_Market("ZONE_CODE") & " - " & rsGet_Market("ZONE_TEXT")
Session("Market_Area_Code") = rsGet_Market("AREA_CODE") & " - " & rsGet_Market("AREA_TEXT")
Session("Market_Site_Code") = rsGet_Market("SITE_CODE") & " - " & rsGet_Market("SITE_TEXT")
Session("MARKET_CODE") = rsGet_Market("MARKET_CODE")
Session("Market_Market_Code1") = rsGet_Market("MARKET_TEXT")
Session("Market_Zone_Code1") = rsGet_Market("ZONE_TEXT")
Session("Market_Area_Code1") = rsGet_Market("AREA_TEXT")
Session("Market_Site_Code1") = rsGet_Market("SITE_CODE") & " - " & rsGet_Market("SITE_TEXT")
Session("Table_Lvl_Label") = "Shop"
CASE 4 'Market
strQuery = "SELECT SITE_MARKET.MARKET_CODE, SITE_MARKET.MARKET_TEXT, SITE_ZONE.ZONE_CODE, SITE_ZONE.ZONE_TEXT, SITE_AREA.AREA_CODE, SITE_AREA.AREA_TEXT, SITE.SITE_CODE, SITE.SITE_TEXT " & _
"FROM SITE_REGION INNER JOIN SITE_MARKET ON SITE_REGION.REGION_CODE = SITE_MARKET.REGION_CODE INNER JOIN SITE INNER JOIN SITE_AREA ON SITE.AREA_CODE = SITE_AREA.AREA_CODE " & _
"INNER JOIN SITE_ZONE ON SITE_AREA.ZONE_CODE = SITE_ZONE.ZONE_CODE ON SITE_MARKET.MARKET_CODE = SITE_ZONE.MARKET_CODE " & _
"WHERE SITE_MARKET.MARKET_CODE = '" & Session("SITE_LVL_CODE") & "'"
Set rsGet_Market = Server.Createobject("ADODB.Recordset")
rsGet_Market.Open strQuery, objConn
Session("Market_Market_Code") = rsGet_Market("MARKET_CODE") & " - " & rsGet_Market("MARKET_TEXT")
Session("Market_Zone_Code") = "N/A"
Session("Market_Area_Code") = "N/A"
Session("Market_Site_Code") = "N/A"
Session("MARKET_CODE") = rsGet_Market("MARKET_CODE")
Session("Market_Market_Code1") = rsGet_Market("MARKET_TEXT")
Session("Market_Zone_Code1") = "N/A"
Session("Market_Area_Code1") = "N/A"
Session("Market_Site_Code1") = "N/A"
Session("Table_Lvl_Label") = "Market"
END SELECT
rsGet_Market.close
objConn.Close
set rsGet_Market= Nothing
set objConn= Nothing
response.redirect "Footfall_Report.asp"
%>
When tracing the SQL query, I can execute the same SELECT without any visible issues.
Would anyone have any ideas as to why this could be failing?
Without going into how to structure your code etc, it is a simple enough fix.
SELECT CASE CINT(Session("SITE_LVL"))
CASE 1 'Site
'Recordset instantiated here
Set rsGet_Market = Server.Createobject("ADODB.Recordset")
rsGet_Market.Open strQuery, objConn
'Lots of fluff here removed to emphasize the point
'...
'Close Recordset inside the Case statement
rsGet_Market.close
CASE 4 'Market
'Recordset instantiated here
Set rsGet_Market = Server.Createobject("ADODB.Recordset")
rsGet_Market.Open strQuery, objConn
'Lots of fluff here removed to emphasize the point
'...
'Close Recordset inside the Case statement
rsGet_Market.close
END SELECT
'Don't close rsGet_Market here as it might not exist and cause an error.
objConn.Close
By moving the rsGet_Market.close inside the Case statement it will only be called when there is a corresponding ADODB.Recordset in the rstGet_Market object.
You can't Close a Recordset that never exists in the first place.
We could improve on this though by moving the instantiation outside of the Case statement to remove yet more duplication (DRY Principle)
'Recordset instantiated here
Set rsGet_Market = Server.Createobject("ADODB.Recordset")
SELECT CASE CINT(Session("SITE_LVL"))
CASE 1 'Site
'Recordset will be open if data is returned.
rsGet_Market.Open strQuery, objConn
'Lots of fluff here removed to emphasize the point
'...
'Close Recordset inside the Case statement
rsGet_Market.close
CASE 4 'Market
'Recordset will be open if data is returned.
rsGet_Market.Open strQuery, objConn
'Lots of fluff here removed to emphasize the point
'...
'Close Recordset inside the Case statement
rsGet_Market.close
END SELECT
'Release Recordset object from memory
Set rsGet_Market = Nothing
'Don't close rsGet_Market here as it might not exist and cause an error.
objConn.Close
Correction, line 71 is rsGet_Market.close
OK. Let's take a look closer to your code.
You calling rsGet_Market.close always, but create it only for Case 1 and Case 4. Perhaps you have CINT(Session("SITE_LVL")) not equal to 1 and not equal to 4.
but that doesn't generate any data.
Yes, but you always calling method (function) for not existing object (Set create it in your case for rsGet_Market). That why you have error Object required: ''
I am using .Open to check if record exists.
If it exists, I delete it.
If not, I an adding it.
Then I close the ADODB Recordset.
I am sure there is a better way of doing this - and this is probably a slow way of doing it.
Is there a way of doing this with only one Open and One close?
Here is my code (which is in a Do Loop):
Dim myRecSet As New ADODB.Recordset
Dim strSql As String
strSql = "select * from RentBalances where KeyTcyIdSubAcDate = '" & sKeyTcyIdSubAcDate & "'"
'Display "SQL: " & strSql
myRecSet.Open strSql, SQLSVSExtractConnection, adOpenKeyset, adLockOptimistic
'Display "Total no of records = " & myRecSet.RecordCount
If myRecSet.RecordCount < 1 Then
'Display ("There are no RentBalances record for this ID. ID = " & sKeyTcyIdSubAcDate)
Else
' delete the record
myRecSet.Delete
myRecSet.UpdateBatch
End If
myRecSet.AddNew
myRecSet!KeyTcyIdSubAcDate = rsLocal.Fields("KeyTcyIdSubAcDate")
myRecSet!KeyTcyId = rsLocal.Fields("KeyTcyId")
myRecSet!SubAc = rsLocal.Fields("SubAc")
myRecSet!PeriodEndDate = rsLocal.Fields("PeriodEndDate")
myRecSet!Amount = rsLocal.Fields("Amount")
myRecSet!RentAmount = rsLocal.Fields("RentAmount")
myRecSet!ChargesAmount = rsLocal.Fields("ChargesAmount")
myRecSet!AdjustmentAmount = rsLocal.Fields("AdjustmentAmount")
myRecSet!BenefitAmount = rsLocal.Fields("BenefitAmount")
myRecSet!BenefitBalance = rsLocal.Fields("BenefitBalance")
myRecSet!TenantBalance = rsLocal.Fields("TenantBalance")
myRecSet!PayAmount = rsLocal.Fields("PayAmount")
myRecSet!TimeStamp = rsLocal.Fields("TimeStamp")
myRecSet!UpdateFlag = rsLocal.Fields("UpdateFlag")
myRecSet.Update
myRecCount = myRecCount + 1
myRecSet.Close
The most optimal way of doing this is to bulk insert into a staging table from your code and then call a stored procedure to merge the data from your staging table into your proper table.
My question today is a rather simple one. What I have is a VB Module that contains the code to return me an ADODB.RecordSet object with records fetched from a SQL Query that has been executed. It works like this:
sSql_SerCheck = "SELECT DISTINCT Serial FROM dbo.WipReservedSerial WHERE Serial LIKE '" & serialTempSearch
sSql_SerCheck = sSql_SerCheck & "' ORDER BY Serial DESC "
dbGetRecordSet(sSql_SerCheck)
Then the results sit in object rs that is accessed like the following
temp = rs(0) 'For the value at the first column for the first record
rs.MoveNext 'This moves to the next record in the record set
Now what I am trying to do here is to the number of records contained within this recordset object. Now I did some research on the class and found there is a
RecordCount att.
So what I want to do is simple:
if( rs.RecordCount > 0) then
serCheck1 = rs(0)
MsgBox serCheck1
end if
The problem is my RecordCount returns -1. I found this article http://www.w3schools.com/asp/prop_rs_recordcount.asp that states that record count will return -1 for the following:
Note: This property will return -1 for a forward-only cursor; the actual count for a static or keyset cursor; and -1 or the actual count for a dynamic cursor.
Note: The Recordset object must be open when calling this property. If this property is not supported it will return -1.
How do I get this object to return the correct number of records??
The code for the VB Module is added below:
Public cn, rs
'Specify pSQL as SQL Statement
Function dbGetRecordset(sSql)
dbCloseConnection()
Set cn = CreateObject("ADODB.Connection")
cn.CommandTimeout = 600
cn.Open(Conn & SystemVariables.CodeObject.CompanyDatabaseName)
Set rs = CreateObject("ADODB.Recordset")
rs.Open sSql, cn, 3, 3
End Function
As your rs.RecordCount > 0 just checks whether the recordset is not empty, you can avoid .Recordcount (and all it's problems) by testing for Not rs.EOF
Don't trust secondary sources; the MS docs contain "... and either -1 or the actual count for a dynamic cursor, depending on the data source". So maybe your provider is to blame. In that case (or when you really need a specific number), a SELECT COUNT() would be a workaround
Don't use magic numbers as in rs.Open sSql, cn, 3, 3, but define (and doublecheck) your Consts like adOpenStatic, adLockOptimistic, ...
From Help
Set oRs = New ADODB.Recordset
oRs.CursorLocation = adUseClient
oRs.Open sSQL, sConn, adOpenStatic, adLockBatchOptimistic, adCmdText
Help has a full description of Cursors in What is a Cursor (ADODB Programmers Guide - Windows Software Development Kit).
You'll burn resources either locally or on the server to get a record count. If you are going through the data anyway, just count them.
This is how to go through a recordset one at a time.
Do While not .EOF
Outp.writeline .Fields("Txt").Value
.MoveNext
Loop
Set connection = CreateObject("adodb.connection")
connection.open "Driver=your driver details"
If connection.State = 1 Then
Set myRecord = CreateObject("ADODB.recordset")
sql= "select * from...."
myRecord.Open sql, connection
i = 0
Do While Not myRecord.EOF
i=i+1
myRecord.MoveNext
loop
msgbox "RecordCount="&i
myRecord.Close
END IF
set myRecord = nothing
set Connection = nothing
I was finding that the vbscript version of this was flaky... the best option seemed to use a CursorLocation of 3.. vbscript didn't seem to understand adUseClient.
set conn=CreateObject("ADOdb.connection")
conn.CursorLocation = 3
conn.open DSNQ
set rs = conn.execute("select * from sometable order by 1 desc")
msgbox (rs.RecordCount & " records" )```
I'm trying to figure out how to speed up this operation. Before I import a record from the text file I first need to see if one exists in the database. If it does exist I'm going to perform an update operation on it. If it does not exist I'm going to create a new record.
Running the code you see below this operation takes somewhere in the neighborhood of 3 hours.
I've tried using ADO's find method and it actually appears to be slower than the filter method.
The database is a Visual Foxpro 6 database. The table does have an index on the item_cd field but the table does not have any primary key established. This is out of my control since I didn't write the software and I'm trying to stay away from making any structural changes to the database.
There are 46652 rows in the text file and about 650,000 records/rows in the ADO recordset. I think slimming down the recordset would be the biggest step in fixing this but I haven't come up with any way of doing that. I'm trying to prevent creating duplicate records since there is no primary key and so I really need to have the entire table in my recordset.
Because I'm running this on my local machine it appears that the operation is limited by the power of the CPU. In actuality this might be used across the network, especially if I can get it to go faster.
Dim sFileToImport As String
sFileToImport = Me.lstFiles.Text
If sFileToImport = "" Then
MsgBox "You must select a file from the listbox to import."
Exit Sub
End If
If fConnectToDatabase = False Then Exit Sub
With gXRst
.CursorLocation = adUseClient
.CursorType = adOpenKeyset
.LockType = adLockReadOnly
.Open "SELECT item_cd FROM xmsalinv ORDER BY item_cd ASC", gXCon
End With
Call fStartProgress("Running speed test.")
Dim rstTxtFile As ADODB.Recordset
Set rstTxtFile = New ADODB.Recordset
Dim con As ADODB.Connection
Set con = New ADODB.Connection
Dim sConString As String, sSQL As String
Dim lRecCount As Long, l As Long
Dim s As String
sConString = "DRIVER={Microsoft Text Driver (*.txt; *.csv)};Dbq=" & gsImportFolderPath & ";Extensions=asc,csv,tab,txt;Persist Security Info=False;"
con.Open sConString
sSQL = "SELECT * FROM [" & sFileToImport & "]"
rstTxtFile.Open sSQL, con, adOpenKeyset, adLockPessimistic
If Not (rstTxtFile.EOF And rstTxtFile.BOF) = True Then
rstTxtFile.MoveFirst
lRecCount = rstTxtFile.RecordCount
Do Until rstTxtFile.EOF = True
'This code appears to actually be slower than the filter method I'm now using
'gXRst.MoveFirst
'gXRst.Find "item_cd = '" & fPQ(Trim(rstTxtFile(0))) & "'"
gXRst.Filter = "item_cd = '" & fPQ(Trim(rstTxtFile(0))) & "'"
If Not (gXRst.EOF And gXRst.BOF) = True Then
s = "Item Found - " & Trim(rstTxtFile(0)) 'item found
Else
s = "Item Not Found - " & Trim(rstTxtFile(0)) 'Item not found found
End If
l = l + 1
Call subProgress(l, lRecCount, s)
rstTxtFile.MoveNext
Loop
End If
Call fEndProgress("Finished running speed test.")
Cleanup:
rstTxtFile.Close
Set rstTxtFile = Nothing
gXRst.Close
A simple solution to speed up Yours_Rs.find response is to use the Yours_Rs.move statement first if it is possible for you. What I have done is to use MyRs.move statement prior to using MyRs.find to come in the vicinity of my actual record. It had really worked for me as response of move statement is quite brisk.
I was using it to locate a patient record. So, moving the pointer to a record near the actual record made MyRs.find statement to work with the speed of light.
regards,
MAS.
doesn't answer your question and this is a pretty old thread, but
why don't you import your text file to a temporary table on your db then do a join?
something like
SELECT tt.* FROM texttemp tt left outer join xmsalinv xal on tt.field1=xal.item_cd where xal.item_cd is null
this should return the contents of your imported text file which don't have any item_cd matches in the database, since you're dealing with a text file that complicates the query which is why i'm wondering your not importing the contents to a temporary table.
now assuming you know the mapping of the fields, you can probably also use this to insert assuming your db accepts insert select notation it'd be insert into xmsalinv (fields) select (matching fields) from (as above...)
this moves your choke points to the import process, which i'm hoping is quick.
the ado collections seem like they're pretty stupid, so they don't benefit from any sort of knowledge about the data and are kinda slow.
ah next item on "vb6 filter" google http://www.techrepublic.com/article/why-ados-find-method-is-the-devil/1045830
this response is based on basic sql knowledge and not tailored to foxpro
Use a firehose cursor for the VFP query's results if you aren't, and see your other post here for suggestions regarding the text file Recordset.
Perhaps better yet though, you might try getting rid of your slow "loop and search" aproach.
I would probably create a temporary Jet 4.0 MDB from scratch for each text file you want to look up. Import the text data, index your key field. Use ADOX to define a linked table over in the VFP database. The use a query to do your matching.
Close and dispose of the MDB afterward.
In response to Bob Riemersma's post, the text file is not causing the speed issues. I've changed my code to open a recordset with a query looking for a single item. This code now runs in 1 minute and 2 seconds as opposed to the three to four hours I was looking at the other way.
Dim sFileToImport As String
sFileToImport = Me.lstFiles.Text
If sFileToImport = "" Then
MsgBox "You must select a file from the listbox to import."
Exit Sub
End If
If fConnectToDatabase = False Then Exit Sub
Call fStartProgress("Running speed test.")
Dim rstTxtFile As ADODB.Recordset
Set rstTxtFile = New ADODB.Recordset
Dim con As ADODB.Connection
Set con = New ADODB.Connection
Dim sConString As String, sSQL As String
Dim lRecCount As Long, l As Long
Dim sngQty As Single, sItemCat As String
sConString = "DRIVER={Microsoft Text Driver (*.txt; *.csv)};Dbq=" & gsImportFolderPath & ";Extensions=asc,csv,tab,txt;Persist Security Info=False;"
con.Open sConString
sSQL = "SELECT * FROM [" & sFileToImport & "]"
rstTxtFile.Open sSQL, con, adOpenKeyset, adLockPessimistic
If Not (rstTxtFile.EOF And rstTxtFile.BOF) = True Then
rstTxtFile.MoveFirst
lRecCount = rstTxtFile.RecordCount
Do Until rstTxtFile.EOF = True
l = l + 1
sItemCat = fItemCat(Trim(rstTxtFile(0)))
If sItemCat <> "[item not found]" Then
sngQty = fItemQty(Trim(rstTxtFile(0)))
End If
Call subProgress(l, lRecCount, sngQty & " - " & sItemCat & " - " & rstTxtFile(0))
sngQty = 0
rstTxtFile.MoveNext
Loop
End If
Call fEndProgress("Finished running speed test.")
Cleanup:
rstTxtFile.Close
Set rstTxtFile = Nothing
My Functions:
Private Function fItemCat(sItem_cd As String) As String
'Returns blank if nothing found
If sItem_cd <> "" Then
With gXRstFind
.CursorLocation = adUseClient
.CursorType = adOpenKeyset
.LockType = adLockReadOnly
.Open "SELECT item_cd, ccategory FROM xmsalinv WHERE item_cd = '" & fPQ(sItem_cd) & "'", gXCon
End With
If Not (gXRstFind.EOF And gXRstFind.BOF) = True Then
'An item can technically have a blank category although it never should have
If gXRstFind!ccategory = "" Then
fItemCat = "[blank]"
Else
fItemCat = gXRstFind!ccategory
End If
Else
fItemCat = "[item not found]"
End If
gXRstFind.Close
End If
End Function
Private Function fIsStockItem(sItem_cd As String, Optional bConsiderItemsInStockAsStockItems As Boolean = False) As Boolean
If sItem_cd <> "" Then
With gXRstFind
.CursorLocation = adUseClient
.CursorType = adOpenKeyset
.LockType = adLockReadOnly
.Open "SELECT item_cd, bal_qty, sug_qty FROM xmsalinv WHERE item_cd = '" & fPQ(sItem_cd) & "'", gXCon
End With
If Not (gXRstFind.EOF And gXRstFind.BOF) = True Then
If gXRstFind!sug_qty > 0 Then
fIsStockItem = True
Else
If bConsiderItemsInStockAsStockItems = True Then
If gXRstFind!bal_qty > 0 Then
fIsStockItem = True
End If
End If
End If
End If
gXRstFind.Close
End If
End Function
Private Function fItemQty(sItem_cd As String) As Single
'Returns 0 if nothing found
If sItem_cd <> "" Then
With gXRstFind
.CursorLocation = adUseClient
.CursorType = adOpenKeyset
.LockType = adLockReadOnly
.Open "SELECT item_cd, bal_qty FROM xmsalinv WHERE item_cd = '" & fPQ(sItem_cd) & "'", gXCon
End With
If Not (gXRstFind.EOF And gXRstFind.BOF) = True Then
fItemQty = CSng(gXRstFind!bal_qty)
End If
gXRstFind.Close
End If
End Function
First can try creating an in-memory index on item_cd with gXRst!item_cd.Properties("OPTIMIZE").Value = True which will speed up both Find and Filter.
For ultimate speed in searching initialize helper index Collection like this
Set cIndex = New Collection
On Error Resume Next
Do While Not gXRst.EOF
cIndex.Add gXRst.Bookmark, "#" & gXRst!item_cd.Value
gXRst.MoveNext
Loop
On Error GoTo ErrorHandler
And insetad of Find use some function like this
Public Function SearchCollection(Col As Object, Index As Variant) As Boolean
On Error Resume Next
IsObject Col(Index)
SearchCollection = (Err.Number = 0)
On Error GoTo 0
End Function
3 hours just for a few hundred thousands of records!!! You are doing it the wrong way. Simply:
-append text file to a VFP table,
-then insert the ones that do not exist in existing table with a single SQL
-and update the ones that exist with another Update sql.
That is all and should take less than a minute (a minute is even very slow). You can do all these using the VFPOLEDB driver and it doesn't matter that you have VFP6 database, VFPOLEDB has VFP9 engine built-in.