how to find duplicates in recordset using vb6 - vb6

Hi i have a recordset name rcdDNE. I read the rtn, accno, first name, Middle name, last name, amount, from text file and store it to the recordset. Now I want to store that values to database table. In my table accno is primary key. So before storing that into my table i want to find out if there is any duplicate accno in my recordset. If i have i want to write it to text file.
Can anyone help me.
' Set up rcdDNE structure
With rcdDNE.Fields
.Append "RTN", adVarChar, 9
.Append "AccountNbr", adVarChar, 17
.Append "IndividualName", adVarChar, 22
.Append "FirstName", adVarChar, 50
.Append "MiddleName", adVarChar, 1
.Append "LastName", adVarChar, 50
.Append "Amount", adCurrency
End With
rcdDNE.Open
intFileNbr = FreeFile(1)
Open strFileName For Input As #intFileNbr Len = 95 ' Open file for input.
Do While Not EOF(intFileNbr)
Line Input #intFileNbr, strCurrentLine
If Mid(strCurrentLine, 1, 1) = 6 Then
strRoutingNbr = Mid(strCurrentLine, 4, 8)
strAcct = Trim(Mid(strCurrentLine, 13, 17))
strIndividualName = Trim(Mid(strCurrentLine, 55, 22))
strAmount = Trim(Mid(strCurrentLine, 30, 10))
strAmount = Left(strAmount, Len(strAmount) - 1)
curAmount = CCur(strAmount)
' Add new record to temporary recordset
With rcdDNE
.AddNew
.Fields![RTN] = strRoutingNbr
.Fields![AccountNbr] = strAcct
.Fields![IndividualName] = strIndividualName
.Fields![Amount] = curAmount
.Update
End With
End If
Loop
' Write records to Database
frmDNELoad.lblStatus.Caption = "Loading data into database......"
Dim lngRecCount As Long
lngRecCount = 0
rcdDNE.MoveFirst
With cmdCommand
.ActiveConnection = objConn
.CommandText = "insert into t_DATA_DneFrc (RTN, AccountNbr, FirstName, MiddleName, LastName, Amount) values ('" & rcdDNE("RTN") & "', '" & rcdDNE("AccountNbr") & "', '" & rcdDNE("FirstName") & "', '" & rcdDNE("MiddleName") & "', '" & rcdDNE("LastName") & "', '" & rcdDNE("Amount") & "')"
.CommandType = adCmdText
End With
Set rcddnefrc = New ADODB.Recordset
With rcddnefrc
.ActiveConnection = objConn
.Source = "SELECT * FROM T_DATA_DNEFRC"
.CursorType = adOpenDynamic
.CursorLocation = adUseClient
.LockType = adLockOptimistic
.Open
End With
Do Until rcdDNE.EOF
lngRecCount = lngRecCount + 1
frmDNELoad.lblStatus.Caption = "Adding record " & lngRecCount & " of " & rcdDNE.RecordCount & " to database."
frmDNELoad.Refresh
DoEvents
Call CommitNew
rcdDNE.MoveNext
Loop

In the loop, where reading the data from the text file, Build a list of accno.
Each time you read a line from the text, first check if the list contains the accno, if not, add the record, and add the accno to the list.
If it does contain the accno in the list already, dont add the line to the record set and move to the next line.

Meh. Duplicate checking sucks. You might be better off just dumping the whole dataset into the database, and then doing SELECT DISTINCT...INTO... and creating another table without duplicates. Then you can compare records in the two tables to find the duplicate records.
Otherwise you're going to have to pull the first record, check it against your ENTIRE dataset, pull the second record, etc. High cost to that kind of comparison.

Related

MS access code gives different results each execution against same data

i'm in the process of roughing out a proof of concept for desktop software i'd like to develop. I'm using Access 2013.
The following code is supposed to analyse records in one table ('tblRestructures') and depending on the analysis it should then populate records in another table ('tblInScopeRestructures'). The sample data in tblRestructures is set up such that the code should cause there to be records with field(Gen) with values 1 to 6 inclusive. Sometimes the code does succeed in populating tblInScopeRestructures as expected but other times the code ends early (ie conditions for ending various loops are met). Despite a lot of time spent trying to identify the cause of the variability and looking for similar questions here, I am still none the wiser.
Any help here is gratefully received. And I apologise up front for my ugly code - I am not experienced and at this stage I am just trying to speed through a proof of concept.
Here is the code:
Public Function NbrOfShares3(strCode As String, dteDate As Date) As Single
Dim i As Integer
Dim strPrevCode1 As String
Dim adConn As ADODB.Connection
Set adConn = New ADODB.Connection
adConn.Open CurrentProject.Connection
Dim adrsa As ADODB.Recordset
Set adrsa = New ADODB.Recordset
adConn.Execute "DELETE * from tblInScopeRestructures"
adrsa.ActiveConnection = CurrentProject.Connection
adrsa.CursorType = adOpenStatic
' Identify all gen 1 (Code1 = CODE) restructures up to dteDate and put in a temp table
adrsa.Open "SELECT tblRestructure.Code1, tblRestructure.Code2, tblRestructure.RecDate " & _
"FROM tblRestructure " & _
"WHERE (((tblRestructure.Code1)='" & strCode & "')) AND (((tblRestructure.RecDate)<=#" & Format(dteDate, "mm/dd/yyyy") & "#));"
If adrsa.RecordCount <> 0 Then
adrsa.MoveFirst
Do While Not adrsa.EOF
adConn.Execute ("INSERT INTO tblInScopeRestructures(Code1,Code2,RecDate,Gen) VALUES ('" & adrsa.Fields("Code1") & "','" & adrsa.Fields("Code2") & _
"',#" & Format(adrsa.Fields("RecDate"), "mm/dd/yyyy") & "#," & 1 & ")")
adrsa.MoveNext
Loop
End If
i = 0
'Identify all code1 in
Dim adrsb As ADODB.Recordset
Set adrsb = New ADODB.Recordset
adrsb.ActiveConnection = CurrentProject.Connection
Do
i = i + 1
If adrsb.State = 1 Then
adrsb.Close
End If
adrsb.CursorType = adOpenStatic
adrsb.Open "SELECT tblInScopeRestructures.Code1, tblInScopeRestructures.Gen " & _
"FROM tblInScopeRestructures " & _
"GROUP BY tblInScopeRestructures.Code1, tblInScopeRestructures.Gen " & _
"HAVING (((tblInScopeRestructures.Gen)=" & i & "));"
Dim adrsc As ADODB.Recordset
Set adrsc = New ADODB.Recordset
adrsc.ActiveConnection = CurrentProject.Connection
adrsc.CursorType = adOpenStatic
If Not adrsb.EOF Then
adrsb.MoveLast
adrsb.MoveFirst
End If
If adrsb.RecordCount <> 0 Then
adrsb.MoveFirst
strPrevCode1 = adrsb.Fields("Code1")
Do While Not adrsb.EOF
If adrsc.State = 1 Then
adrsc.Close
End If
adrsc.CursorType = adOpenStatic
adrsc.Open "SELECT tblRestructure.Code1, tblRestructure.Code2, tblRestructure.RecDate " & _
"FROM tblRestructure " & _
"WHERE (((tblRestructure.Code2)='" & strPrevCode1 & "'));"
If adrsc.RecordCount <> 0 Then
adrsc.MoveFirst
Do While Not adrsc.EOF
adConn.Execute ("INSERT INTO tblInScopeRestructures(Code1,Code2,RecDate,Gen) VALUES ('" & adrsc.Fields("Code1") & "','" & adrsc.Fields("Code2") & _
"',#" & Format(adrsc.Fields("RecDate"), "mm/dd/yyyy") & "#," & i + 1 & ")")
adrsc.MoveNext
Loop
End If
adrsb.MoveNext
Loop
End If
Loop While adrsb.RecordCount <> 0
Debug.Print "finished"
End Function

Search using Combo Box and Filter the results in text boxes

I am trying to do a small program on VB 6.0 to find the records in database and print it in text box based on combo box selection but i failed to find a code which allow me to do this.
Any help please.
Dim adoCon
Dim adoRs
Dim strSQL As String
Dim strDB As String
'Change YourDatabaseName to actual database you have
strDB = "c:\path\YourDatabaseName.accdb"
Set adoCon = CreateObject("ADODB.Connection")
adoCon.Open "Provider = Microsoft.ACE.OLEDB.12.0; " & _
"Data Source = " & strDB & ";" & _
"Persist Security Info = False;"
'Change Table1 to your table name in MS Access
'change the name of combobox and the fieldname in MS Access table
'
'''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''''''''''''''''
' if combo is numeric
strSQL = "SELECT [fieldNameToReturn] FROM Table1 Where [fieldName] = " + [combo].Value + ";"
' if combo is text
'strSQL = "SELECT [fieldNameToReturn] FROM Table1 Where [fieldName] = '" + [combo].Value + "';"
'''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''
Set adoRs = CreateObject("ADODB.Recordset")
'Set the cursor type we are using so we can navigate through the recordset
adoRs.CursorType = 2
'Set the lock type so that the record is locked by ADO when it is updated
adoRs.LockType = 3
'Open the tblComments table using the SQL query held in the strSQL varaiable
'adoRs.Open strSQL, adoCon
If Not adoRS.Eof() Then
[yourTextBox] = adoRs(0)
End If
adoRs.Close
adoCon.Close
Set adoRs = Nothing
Set adoCon = Nothing
"BOF" below is not a typo. If the recordset is empty (the query returned no records) BOF will be true.
adoRs.Open strSQL, adoCon
If Not adoRS.BOF Then
'If not _BOF_ we have records so load the first record
adoRs.MoveFirst
'If first field is a string then use this
[yourTextBox] = adoRs.Fields(0).Value
'If first field is numeric then use this
[yourTextBox] = CStr(adoRs.Fields(0).Value)
Else
Msgbox "No records returned."
End If
If you were processing multiple records you would still do the MoveFirst and then loop until EOF was true, processing each record. The MoveNext will set EOF = True when there are no more records to process.
adoRs.Open strSQL, adoCon
If Not adoRS.BOF Then
'If not _BOF_ we have records so load the first record
adoRs.MoveFirst
Do While Not adoRS.EOF
'Process records here
'.
'.
'.
adoRS.MoveNext
Loop
Else
Msgbox "No records returned."
End If

VB6. Proceesing ADODB Table Is there a better way of doing this?

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.

How to save picture in BLOB format?

I did code for procedure that prompts for a .jpeg file, converts that file to a Byte array, and saves the Byte Array to the table using the Append chunk method.
Another procedure retrieves the picture image from the table using the GetChunk method, converts the data to a file and displays that file in the Picture box.
Now, my question is that how do I save that image displayed in picture box into the database, so that I can perform operations like: add/update etc.
I did something like this way:
Private Sub CmdSave_Click()
if(cmbRNO=" ") then
sql = "INSERT INTO STUDENT_RECORD_DATABASE(ROLLNO,PICS)"
sql = sql + "VALUES(" & RNo & ","& picture1.picture &")"
Set RES = CON.Execute(sql)
Else
sql = "UPDATE STUDENT_RECORD_DATABASE SET "
sql = sql + "ROLLNO= " & Val(CmbRNO) & ","
sql = sql + "PICS=" & Picture1.Picture & " "
sql = sql + "WHERE ROLLNO= " & Val(CmbRNO) & ""
Set RES = CON.Execute(sql)
End If
End Sub
<code for appendchunk method>
Public Sub Command1_Click()
Dim PictBmp As String
Dim ByteData() As Byte 'Byte array for Blob data.
Dim SourceFile As Integer
' Open the BlobTable table.
strSQL = "Select ID, DOC from LOB_TABLE WHERE ID = 1"
Set Rs = New ADODB.Recordset
Rs.CursorType = adOpenKeyset
Rs.LockType = adLockOptimistic
Rs.Open strSQL, Cn
' Retrieve the picture and update the record.
CommonDialog1.Filter = "(*.jpeg)|*.jpeg"
CommonDialog1.ShowOpen
PictBmp = CommonDialog1.FileName
' Save Picture image to the table column.
SourceFile = FreeFile
Open PictBmp For Binary Access Read As SourceFile
FileLength = LOF(SourceFile) ' Get the length of the file.
If FileLength = 0 Then
Close SourceFile
MsgBox PictBmp & " empty or not found."
Exit Sub
Else
Numblocks = FileLength / BlockSize
LeftOver = FileLength Mod BlockSize
ReDim ByteData(LeftOver)
Get SourceFile, , ByteData()
Rs(1).AppendChunk ByteData()
ReDim ByteData(BlockSize)
For i = 1 To Numblocks
Get SourceFile, , ByteData()
Rs(1).AppendChunk ByteData()
Next i
Rs.Update 'Commit the new data.
Close SourceFile
End If
End Sub
While trying to save image to specific record, run-time error occurs:
inconsistent datatype,expected BLOB got number
Where as:
?sql
UPDATE STUDENT_RECORD_DATABASE SET ROLLNO= 132,PICS=688195876 WHERE ROLLNO= 132

VB6 Recordset update

I am running a vb6 program that is looping through many records in a database table and entering a date into a field. This will take many hours to run.
I am noticing that the number of records in the table is increasing by 1 every few seconds and then reducing by 1 (going back to the original count). Is there a reason for this?
I am using a VB6 recordset and the update function i.e. rs.update. I am not inserting any new records.
The code is as follows:
rs.Open "select reference,value1,datefield from datetable where field1 = 'value1' " & _
"order by reference", objAuditCon.ActiveCon, adOpenStatic, adLockPessimistic
Do While Not rs.EOF
intReadCount = intReadCount + 1
DoEvents
If Not IsNull(rs("value1")) Then
testArray = Split(rs("value1"), ",")
rs2.Open "SELECT Date FROM TBL_TestTable WHERE Record_URN = '" & testArray(1) & "'", objSystemCon.ActiveCon, adOpenStatic, adLockReadOnly
If rs2.EOF Then
End If
If Not rs2.EOF Then
rs("DateField") = Format$(rs2("Date"), "dd mmm yy h:mm:ss")
rs.Update
intWriteCount = intWriteCount + 1
End If
rs2.Close
Else
End If
rs.MoveNext
Loop
rs.Close
Well you can greatly reduce your SQL work here.
If Not IsNull(rs("value1")) Then
testArray = Split(rs("value1"), ",")
rs2.Open "SELECT Date FROM TBL_TestTable WHERE Record_URN = '" & testArray(1) & "'", objSystemCon.ActiveCon, adOpenStatic, adLockReadOnly
If rs2.EOF Then
End If
If Not rs2.EOF Then
rs("DateField") = Format$(rs2("Date"), "dd mmm yy h:mm:ss")
rs.Update
intWriteCount = intWriteCount + 1
End If
rs2.Close
You're essentially, it looks to me(I haven't used VB6 & ADO in 10 years), loading up your record initial recordset, checking a value, and if that value is not null running a second select THEN updating the recordset....
You can instead of doing all this just create a command object
Declare these before your loops
dim objComm
set objComm = Server.CreateObject("ADODB.Command")
objComm.ActiveConnection = objSystemCon.ActiveCon 'I think this is your connn.
objComm.CommandType = 1 'adCmdText
Use this in your loop
objComm.CommandText = "UPDATE DateTable SET DateField = (SELECT Date FROM TBL_TestTable WHERE Record_URN = '" & testArray(1) & "'")
objComm.Execute
Rather than doing a 2nd discreet select, pulling the data in, then doing an update and pushing it back out just push out an update statement. This should speed up the processing of your records.....I know i used to write stuff in VB6 like this a long while back :)
So your code should now read like
dim objComm
set objComm = Server.CreateObject("ADODB.Command")`
objComm.ActiveConnection = objSystemCon.ActiveCon 'I think this is your connn.
objComm.CommandType = 1 'adCmdText
rs.Open "select reference,value1,datefield from datetable where field1 = 'value1' " & _
"order by reference", objAuditCon.ActiveCon, adOpenStatic, adLockPessimistic
Do While Not rs.EOF
intReadCount = intReadCount + 1
DoEvents
If Not IsNull(rs("value1")) Then
testArray = Split(rs("value1"), ",")
objComm.CommandText = "UPDATE DateTable SET DateField = (SELECT Date FROM TBL_TestTable WHERE Record_URN = '" & testArray(1) & "'")
objComm.Execute
End If
rs.MoveNext
Loop
rs.Close
your select statement is still there as you can see, it's a sub select now, the advantage being huge, you're not drawing records to the server, then updating them. You're sending the server a statement to do the updating. You're cutting your trips in half.
Hope this made sense.
Simple answer: take out the DoEvents statement. If you are using it to get screen refresh, the periodically do a manual refresh of your GUI after, say, 1000 iterations of the loop.
The reason why this may be causing an issue is that other code you may have no control over might be being executed when you call DoEvents.

Resources