Program running slow to update records

[emboughey]

The program is written to access a dbf file. In doing that, it adds fields (prefix, first, mid, last, etc) and then updates them with information from a library of name elements.

The problem is that it is only running at about 700 updates per minute and my files are usually greater than 10,000 records.

It also doesn't release the table after I close the program as it should. Below is a portion of the code. Is there anything obvious that you can see that is slowing down the update? I know in Foxpro I use do while !eof() instead of reading each record. Is that what this is doing?

Private Sub cmdRun_Click()
Const csActive_Gender_Name_Parser = "Active Gender Name Parser"

Dim vBookMark As Variant
Dim lRecordCount As Long
Dim oRstADODC1 As ADODB.Recordset
Dim oConn As New ADODB.Connection

'* Check if the input and output files have been selected
If GetSetting(App.Title, csDataBase, csFileName, "") = "" Then
MsgBox "Please select a DBF input file using the File Menu.", vbInformation
Exit Sub
End If

Rem OpenConnection

'* Check if there is a table field selected
If cbTableFields.Text = "" Then
MsgBox "Please select a table field to parse.", vbInformation
cbTableFields.SetFocus
Exit Sub
End If

'If GetSetting(App.Title, csDataBase, csOutputFile, "") = "" Then
' MsgBox "Please select a CSV output file using the File Menu.", vbInformation
' Exit Sub
'End If

' Gender Confidence
ActiveGender.Gender_Confidence = "70"
If IsNumeric(Trim$(txtGenderConfidence.Text)) Then
If CInt(Trim$(txtGenderConfidence.Text)) >= "51" _
And CInt(Trim$(txtGenderConfidence.Text)) <= "100" Then
ActiveGender.Gender_Confidence = txtGenderConfidence.Text
End If
End If
txtGenderConfidence.Text = ActiveGender.Gender_Confidence

' Name Style
ActiveGender.Name_Style = cbStyle.Text
ActiveGender.Variable_Default = cbDefaultStyle(0).Text
ActiveGender.Variable_Default2 = cbDefaultStyle(1).Text

' Proper Case
ActiveGender.Output_Case = cbCase.Text

' Company Check
ActiveGender.Company_Check = chkCompanyCheck.Value

' Nicknames Check
ActiveGender.Nickname_Check = chkNicknames.Value

cbNicknames.Clear
cbNicknames2.Clear

fStopFlag = False
cmdRun.Enabled = False
cmdExit.Enabled = False
cmdClear.Enabled = False
Adodc1.Enabled = False
txtInputName.Enabled = False

oConn.ConnectionString = strConnectionString
oConn.CursorLocation = adUseClient
oConn.Open

'* Loop through the whole table...
Adodc1.Refresh '* Ensure start from the first record
Set oRstADODC1 = Adodc1.Recordset '* Cache the recordset refsrence

lRecordCount = 1
With ProgressBar1
.Top = Adodc1.Top
.Left = Adodc1.Left
.Width = Adodc1.Width
.Height = Adodc1.Height
.Width = Adodc1.Width
.Visible = True
.Min = 1
.Max = oRstADODC1.RecordCount
.Value = lRecordCount
End With

Do Until oRstADODC1.EOF Or fStopFlag

txtInputName.Refresh

DoEvents

With ActiveGender
'-------------------------------------------------------------------------------
' Pass the input fields to ActiveGender Class
'-------------------------------------------------------------------------------
' Input Name
.Name_In = txtInputName.Text

'-------------------------------------------------------------------------------
' ActiveGender Class "Parse" method -
' Standardize, parse & gender code the input name
'-------------------------------------------------------------------------------
.Parse

'-------------------------------------------------------------------------------
' ActiveGender Exception Codes
'-------------------------------------------------------------------------------
If .Return_Code <> "" Then
Select Case .Return_Code
Case "G04": MsgBox "Gender File Corrupt", vbCritical, csActive_Gender_Name_Parser
Case "G35": MsgBox "Gender File Not Found", vbCritical, csActive_Gender_Name_Parser
Case "R35": MsgBox "Reference File Not Found", vbCritical, csActive_Gender_Name_Parser
Case "T00": MsgBox "Prefix/Suffix Table Limit: 1,024", vbCritical, csActive_Gender_Name_Parser
Case "T01": MsgBox "Gender Override Table Limit: 1,024", vbCritical, csActive_Gender_Name_Parser
Case "L00": MsgBox "Demo Expired", vbCritical, csActive_Gender_Name_Parser
Case "L01": MsgBox "Static Key Validation Failed", vbCritical, csActive_Gender_Name_Parser
Case "L50" To "L69": MsgBox "ActiveGender.Return_Code: " & .Return_Code & vbCrLf & "License Validation Failed", vbCritical, csActive_Gender_Name_Parser
Case Else: MsgBox "ActiveGender.Return_Code: " & .Return_Code, vbCritical, csActive_Gender_Name_Parser
End Select
End If

'-------------------------------------------------------------------------------
' Populate the text boxes with data returned from ActiveGender Class
'-------------------------------------------------------------------------------
txtPrefix.Text = .Prefix
txtPrefix2.Text = .Prefix2
txtFirst.Text = .First
txtFirst2.Text = .First2
txtMiddle.Text = .Middle
txtMiddle2.Text = .Middle2
txtLast.Text = .Last
txtLast2.Text = .Last2
txtSuffix.Text = .Suffix
txtSuffix2.Text = .Suffix2
txtName.Text = .Name_Out
txtName2.Text = .Name2_Out
txtCompany.Text = .Company
txtCompany2.Text = .Company2
txtGender.Text = .Gender
txtGender2.Text = .Gender2
txtNameQuality.Text = .Name_Quality
txtNameQuality2.Text = .Name2_Quality
txtFilteredData.Text = .Name_Filtered_Data
txtFilteredData2.Text = .Name2_Filtered_Data

' Nicknames
Dim Nicknames As String
Dim Nickname As String
Dim Gender As String
Dim i As Integer

#If False Then

cbNicknames.Clear
cbNicknames2.Clear

' Nicknames for Name 1
For i = 1 To 1009 Step 16
If Mid(.Nicknames, i, 16) = "" Then Exit For
Nickname = Mid(.Nicknames, i, 15)
Gender = Mid(.Nicknames, i + 15, 1)
cbNicknames.AddItem Nickname & Space(16 - Len(Nickname)) & Gender
Next i
If cbNicknames.ListCount > 0 Then cbNicknames.ListIndex = 0

' Nicknames for Name 2
For i = 1 To 1009 Step 16
If Mid(.Nicknames2, i, 16) = "" Then Exit For
Nickname = Mid(.Nicknames2, i, 15)
Gender = Mid(.Nicknames2, i + 15, 1)
cbNicknames2.AddItem Nickname & Space(16 - Len(Nickname)) & Gender
Next i
If cbNicknames2.ListCount > 0 Then cbNicknames2.ListIndex = 0

#End If

#If False Then

'**** THIS METHOD CAUSES ERRORS AFTER ABOUT 100 UPDATES
'* Now update the recordset with the values found from the parse
oRstADODC1.Fields(vNewFieldNames(0)).Value = .Prefix
oRstADODC1.Fields(vNewFieldNames(1)).Value = .First
oRstADODC1.Fields(vNewFieldNames(2)).Value = .Middle
oRstADODC1.Fields(vNewFieldNames(3)).Value = .Last
oRstADODC1.Fields(vNewFieldNames(4)).Value = .Company

oRstADODC1.Fields(vNewFieldNames(5)).Value = .Prefix2
oRstADODC1.Fields(vNewFieldNames(6)).Value = .First2
oRstADODC1.Fields(vNewFieldNames(7)).Value = .Middle2
oRstADODC1.Fields(vNewFieldNames(8)).Value = .Last2
oRstADODC1.Fields(vNewFieldNames(9)).Value = .Company2
oRstADODC1.Fields(vNewFieldNames(10)).Value = .Gender

'* Update the record
oRstADODC1.Update

#Else

'* Now update the table fields with the data parsed into in the text boxes
Dim strSQL As String
Dim oRstSQL As New ADODB.Recordset

strSQL = "UPDATE " & strTableName & " SET "

strSQL = strSQL & vNewFieldNames(0) & " = " & AddApostrophes(txtPrefix.Text) & ", "
strSQL = strSQL & vNewFieldNames(1) & " = " & AddApostrophes(txtFirst.Text) & ", "
strSQL = strSQL & vNewFieldNames(2) & " = " & AddApostrophes(txtMiddle.Text) & ", "
strSQL = strSQL & vNewFieldNames(3) & " = " & AddApostrophes(txtLast.Text) & ", "
strSQL = strSQL & vNewFieldNames(4) & " = " & AddApostrophes(txtCompany.Text) & ", "

strSQL = strSQL & vNewFieldNames(5) & " = " & AddApostrophes(txtPrefix2.Text) & ", "
strSQL = strSQL & vNewFieldNames(6) & " = " & AddApostrophes(txtFirst2.Text) & ", "
strSQL = strSQL & vNewFieldNames(7) & " = " & AddApostrophes(txtMiddle2.Text) & ", "
strSQL = strSQL & vNewFieldNames(8) & " = " & AddApostrophes(txtLast2.Text) & ", "
strSQL = strSQL & vNewFieldNames(9) & " = " & AddApostrophes(txtCompany2.Text) & ", "
strSQL = strSQL & vNewFieldNames(10) & " = " & AddApostrophes(txtGender.Text) & " "

strSQL = strSQL & "WHERE " & cbTableFields.Text & " = " & AddApostrophes(Trim(txtInputName.Text))
oRstSQL.Open strSQL, oConn, adOpenStatic, adLockOptimistic

#End If

vBookMark = oRstADODC1.Bookmark '* Remember the position in the recordset
oRstADODC1.MoveNext

ProgressBar1.Value = lRecordCount
lRecordCount = lRecordCount + 1

End With '* ActiveGender

Loop

oConn.Close
Adodc1.Refresh
On Error Resume Next '* In case there are no records
'* Move to the last record accessed
Adodc1.Recordset.Move 0, vBookMark
On Error GoTo 0
txtInputName.Refresh
DoEvents

fStopFlag = False
ProgressBar1.Visible = False
Adodc1.Enabled = True
cmdRun.Enabled = True
cmdExit.Enabled = True
cmdClear.Enabled = True
txtInputName.Enabled = True

'With Adodc1
' .Recordset.Close
' .ConnectionString = ""
' .RecordSource = ""
' .Enabled = False
'End With

End Sub

 

[emboughey]

Does what I've sent help at all in figuring out what's causing such a long time in processing?

 

[BobRodes]

As a general rule, what is inside the loop should be "lean and mean." Here are some things to look at.

1. Consider updating the progressbar only every so many records, rather than every record. So, remove your DoEvents statement, and then make this mod:

lRecordCount = lRecordCount + 1
if lRecordCount Mod 100 = 0 then (play with the value 100, maybe 1000 is better for example)
    ProgressBar1.Value = lRecordCount
    DoEvents
end if

2. You are setting the bookmark in each iteration of the loop. You can set the bookmark when you exit the loop, because you will be on the last record accessed when you do so. Of course you will have to check for EOF and handle that. Consider moving your bookmarking outside of the loop.

3. Comment out your .parse method and see how quickly the loop runs then. If things speed up dramatically, you might visit your class and see what you can do to streamline it.

4. While I don't see you doing much lookup work in your loop, you may find it useful to index a recordset, perhaps in your parse method. Here's how:

myRs.Fields("myField").Properties("Optimize") = True

HTH

Bob