Attempting to upload data to DBF file

[craigpritchardweb]

Hello everyone!

I am relatively new to Excel VBA and have been attempting to send a number of queries up to a DBF file via the use of an ActiveX Command button. While everything else seems to work well (through the use of my SELECT query, the right records are found ... then the queries are moved into an array in preparation for sending them to the DBF file), it appears that the queries are not sent up to the DBF file because when I check the file later in FoxPro, there have been no updates to the DBF file's records.

I'm fairly experienced with SQL, so there should not be any issues with the queries, which I've triple-checked and don't appear to be an issue.

Below is the full set of code, minus the file paths and queries.

Public Sub cmdUpload_Click()
    Dim con         As ADODB.Connection
    Dim con2        As ADODB.Connection
    Dim rs          As Object
    Dim rs2         As Object
    Dim DBFFolder   As String
    Dim FileName    As String
    Dim sql         As String
    Dim myValues()  As String
    Dim i           As Integer
    Dim newSql      As String
    Dim qName       As Variant
    
    Application.ScreenUpdating = False
    
    DBFFolder = "C:\joycesupplies\wwstore_lawson\Data\"
    FileName = "wws_supplieritems.dbf"
    
    On Error Resume Next
    
    Set con = New ADODB.Connection
    
    If Err.Number <> 0 Then
        MsgBox "Connection was not created!", vbCritical, "Connection error"
        Exit Sub
    End If
    On Error GoTo 0
    
    con.Open "Provider=vfpoledb;" & "Data Source=" & DBFFolder & FileName & ";Collating Sequence=machine"
    
    sql = "SELECT DISTINCT wws_supplieritems.Suppcode, wws_supplieritems.Lprice, wws_supplieritems.Discount, wws_supplieritems.Mprice FROM wws_supplieritems INNER JOIN wws_items ON wws_supplieritems.Sku = wws_items.Sku WHERE wws_supplieritems.Supplierpk = 1 AND wws_items.Category = 1"


    On Error Resume Next
    
    Set rs = CreateObject("ADODB.recordset")
    
    If Err.Number <> 0 Then
        MsgBox "Connection was not created!", vbCritical, "Connection error"
        Exit Sub
    End If
    On Error GoTo 0
    
    rs.CursorLocation = 3
    rs.CursorType = 1
    
    rs.Open sql, con
    
    ReDim myValues(rs.recordCount, 4)
    
    i = 1
    
    Dim myUpdates() As String
    
    If Not (rs.EOF And rs.BOF) Then
        rs.MoveFirst
        
        Do Until rs.EOF = True
            myValues(i, 1) = rs!Suppcode
            myValues(i, 2) = rs!Lprice
            myValues(i, 3) = rs!Discount
            myValues(i, 4) = rs!Mprice
            
            If Trim(myValues(i, 1)) <> "" Then
                newSql = "UPDATE wws_supplieritems SET lprice = " & myValues(i, 2) & ", discount = " & myValues(i, 3) & ", mprice = " & myValues(i, 4) & " WHERE suppcode = '" & myValues(i, 1) & "' AND supplierpk = 1"
                
                ReDim Preserve myUpdates(i - 1) As String
                 
                myUpdates(UBound(myUpdates)) = newSql
                
                i = i + 1
            End If
            
            rs.MoveNext
        Loop
    Else
        
        rs.Close
        con.Close
        
        Set rs = Nothing
        Set con = Nothing
        
        Application.ScreenUpdating = True
        
        MsgBox "There are no records in the recordset!", vbCritical, "No Records"
        Exit Sub
    End If
    
    rs.Close
    Set rs = Nothing
    
    Set rs2 = CreateObject("ADODB.recordset")
    
    rs2.CursorLocation = 3
    rs2.CursorType = 1
    
    For Each qName In myUpdates
        rs2.Open qName, con
    Next
    
    'Debug.Print Join(myUpdates, ", ")
    
    Application.ScreenUpdating = True


    MsgBox "End of Macro", vbInformation, "Done"
   
End Sub

I would really appreciate if I could get some help with this, as I've slaved away at this for longer than I'd like but to no avail.

 

[craigpritchardweb]

Hello Brian,

Sorry I was so slow to answer. I have been knee deep in getting back to work on this particular project so haven't had the time until now to respond.

The code you provided has proven to be very helpful in solving the issue I had, which was essentially that I had not restarted all of the required connection parameters after finishing with the first connection. While the code I have now is not exactly the same as what you used, it definitely provided pointers on where I was going wrong.

I will post my code in a little while to show you what I've actually done.

Thank you for all the time you dedicated to helping out.

 

[btorrean]

Craig,

Thanks for getting back to me! I'm glad my code helped point you in the right direction! Please do post your code when you get a chance. This has been a learning experience for me as well. Thanks!

Brian

Brian J. Torreano

 

[craigpritchardweb]

This ended up growing to be a somewhat different beast to what it was originally. Basically, the moral of the story is that every time you want to do a new query, you must close the existing record set and connection, and create a new one. Even with the number of queries that need to be run in the code below, the code runs extremely quickly (less than a few seconds).

It's not absolutely perfect (one improvement would be just to use the "rs" variable again when creating a new record set) but the improvements honestly aren't that big. It still works quite well with this code.

If you have any more questions I'll happily answer. I just don't have a huge amount of time to explain right at this moment.

Dim suppCodePricing As String
    Dim suppCodeCurrent As String
    Dim sku As String
    Dim description As String
    Dim netPrice As String
    Dim discount As String
    Dim listPrice As String
    Dim search As Range
    Dim asAt As Date
    Dim asAtConverted As String
    
    Dim i As Long
    Dim j As Long
    Dim n As Long
    Dim row As Long
    
    Dim catSelect As String
    Dim supSelect As String
    
    Dim con         As ADODB.Connection
    Dim rs          As Object
    Dim rs2         As Object
    Dim rs3         As Object
    Dim DBFFolder   As String
    Dim fileName    As String
    Dim sql         As String
    Dim newSql      As String
    Dim descSql     As String
    Dim qName       As Variant
    
    Dim myQueries As String
    
    Dim suppName   As String
    Dim suppNo     As Long
    Dim catName    As String
    Dim catNo      As Long
    
    Dim sheet       As Worksheet
    Dim lastRow     As Long
     
    suppName = cbxSupplier.Value
    catName = cbxCategory.Value
    
    Application.ScreenUpdating = False
    
    'Where to find the DBF file that needs to be updated
    DBFFolder = "<file path="">"
    fileName = "<file name="">"
    
    On Error Resume Next
    Set con = New ADODB.Connection
    
    If Err.Number <> 0 Then
        MsgBox "Connection was not created!", vbCritical, "Connection error"
        Exit Sub
    End If
    
    On Error GoTo 0
    
    con.Open "Provider=vfpoledb;" & "Data Source=" & DBFFolder & fileName & ";Collating Sequence=machine"


    'Takes value from a combo box that holds the category
    catSelect = cbxCategory.Value
    
    sql = "[SELECT query that finds the category number]"
    
    On Error Resume Next
    Set rs = CreateObject("ADODB.recordset")


    If Err.Number <> 0 Then
        MsgBox "Connection was not created!", vbCritical, "Connection error"
        Exit Sub
    End If
    
    On Error GoTo 0


    rs.CursorLocation = 3
    rs.CursorType = 1


    rs.Open sql, con
    
    If Not (rs.EOF And rs.BOF) Then
        suppNo = rs!supplierpk
    Else
        rs.Close
        con.Close
      
        Set rs = Nothing
        Set con = Nothing
        
        Application.ScreenUpdating = True
        
        MsgBox "There are no records in the recordset!", vbCritical, "No Records"
        Exit Sub
    End If
    
    rs.Close
    con.Close
    Set rs = Nothing
    Set con = Nothing
    
    On Error Resume Next
    Set con = New ADODB.Connection
    
    If Err.Number <> 0 Then
        MsgBox "Connection was not created!", vbCritical, "Connection error"
        Exit Sub
    End If
    On Error GoTo 0
    
    con.Open "Provider=vfpoledb;" & "Data Source=" & DBFFolder & fileName & ";Collating Sequence=machine"
    
    sql = "[SELECT query that finds the supplier number]<based supplier="" and="" category="" numbers,="" a="" select="" query="" finds="" code="" pricing="" information="">"

    On Error Resume Next
    
    Set rs = CreateObject("ADODB.recordset")
    
    If Err.Number <> 0 Then
        MsgBox "Connection was not created!", vbCritical, "Connection error"
        Exit Sub
    End If
    On Error GoTo 0
    
    rs.CursorLocation = 3
    rs.CursorType = 1
    
    rs.Open sql, con
    
    i = 1
    
    Dim myUpdates() As String
    Dim descUpdates() As String
    
    If Not (rs.EOF And rs.BOF) Then
        rs.MoveFirst
        
        Do Until rs.EOF = True
            suppCodeCurrent = rs!suppCode
            
            If suppCodeCurrent <> "" Then
                If Trim(suppCodeCurrent) <> "" Then
                    'Sets the search parameter for finding the correct supplier code
                    Set search = Range("H13:H237").Find(suppCodeCurrent)
                    
                    If Not search Is Nothing Then
                        sku = Range("A" & search.row).Value
                        listPrice = Range("D" & search.row).Value
                        description = Range("B" & search.row).Value
                        discount = Range("E" & search.row).Value
                        netPrice = Range("F" & search.row).Value
                        netPrice = Format(netPrice, "Standard")
                       
                        suppCodePricing = Range("H" & search.row).Value
                        asAt = Date
                        asAtConverted = Format(asAt, "yyyy\/MM\/dd")
                        
                        If suppCodePricing <> "" Then
                            'The {^yyyy/MM/dd} syntax for dates is required by VFP in order to successfully convert dates into their format
                            newSql = "[start of UPDATE query that will update pricing]<beginning of="" update="" query="">"
                            
                            If chkListPrice.Value = True And listPrice <> "" Then
                                newSql = newSql & ", lprice = " & listPrice
                            End If
                            
                            If chkDiscount.Value = True And discount <> "" Then
                                newSql = newSql & ", discount = " & discount
                            End If
                            
                            If chkNetPrice.Value = True And netPrice <> "" Then
                                newSql = newSql & ", mprice = " & netPrice
                            End If
                            
                            If chkCode.Value = True Then
                                newSql = newSql & ", suppcode = '" & suppCodePricing & "'"
                            End If
                            
                            newSql = newSql & "<end of="" update="" query="" with="" the="" where="" clause="" that="" needs="" supplier="" code,="" number="" and="" sku="">"
                            
                             'Adds the new query string to the array
                           ReDim Preserve myUpdates(i - 1) As String
                   
                            myUpdates(UBound(myUpdates)) = newSql
                            
                            If chkDesc.Value = True Then
                                descSql = "[UPDATE query that will update the description string from another table if needed]"
                                
                                ReDim Preserve descUpdates(i - 1) As String
                   
                                descUpdates(UBound(descUpdates)) = descSql
                            End If
                            
                            i = i + 1
                        End If
                    End If
                End If
            End If
            
            rs.MoveNext
        Loop
    Else
        rs.Close
        con.Close
      
        Set rs = Nothing
        Set con = Nothing
        
        Application.ScreenUpdating = True
        
        MsgBox "There are no records in the recordset!", vbCritical, "No Records"
        Exit Sub
    End If
    
    rs.Close
    Set rs = Nothing
    
    For j = 0 To UBound(myUpdates, 1) - LBound(myUpdates, 1)
        On Error Resume Next
        Set con = New ADODB.Connection
    
        If Err.Number <> 0 Then
            MsgBox "Connection was not created!", vbCritical, "Connection error"
            Exit Sub
        End If
        On Error GoTo 0
        
        con.Open "Provider=vfpoledb;" & "Data Source=" & DBFFolder & fileName & ";Collating Sequence=machine"
        
        sql = myUpdates(j)
        
        Set rs2 = CreateObject("ADODB.recordset")
        
        If Err.Number <> 0 Then
            MsgBox "Connection was not created!", vbCritical, "Connection error"
            Exit Sub
        End If
        On Error GoTo 0
        
        rs2.CursorLocation = 3
        rs2.CursorType = 1
        'MsgBox sql
        rs2.Open sql, con
    Next j
    
    If chkDesc.Value = True Then
        'rs2.Close
        'Set rs2 = Nothing
        
        For n = 0 To UBound(descUpdates, 1) - LBound(descUpdates, 1)
            On Error Resume Next
            Set con = New ADODB.Connection
        
            If Err.Number <> 0 Then
                MsgBox "Connection was not created!", vbCritical, "Connection error"
                Exit Sub
            End If
            On Error GoTo 0
            
            con.Open "Provider=vfpoledb;" & "Data Source=" & DBFFolder & fileName & ";Collating Sequence=machine"
            
            sql = descUpdates(n)
            
            Set rs3 = CreateObject("ADODB.recordset")
            
            If Err.Number <> 0 Then
                MsgBox "Connection was not created!", vbCritical, "Connection error"
                Exit Sub
            End If
            On Error GoTo 0
            
            rs3.CursorLocation = 3
            rs3.CursorType = 1
            Debug.Print sql
            MsgBox sql
            rs3.Open sql, con
        Next n
    End If
    
    con.Close
    Set con = Nothing

Application.ScreenUpdating = True

</end></beginning></based></file></file>