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.

 

[btorrean]

Craig,

I'm going to have to look into this some more. Do you know how to insert breakpoints into your code, so that you can see where the code is possibly not functioning as you intended?

Brian

Brian J. Torreano

 

[craigpritchardweb]

No, although I have commented out or cut code at times to see any effect it might have. So I have been debugging in a way, just not the correct way I guess.

 

[btorrean]

Hey Craig,

Below are some resources that can help you learn how to use breakpoints. Breakpoints are really useful as they let you stop the code at certain points during the execution and see what the variables have evaluated as.

Setting Breakpoints and the VBA Stop Statement

https://www.thespreadsheetguru.com/blog/2014/4/8/debugging-vba-code-adding-breakpoints

Brian

Brian J. Torreano

 

[btorrean]

Craig,

I'm going to see if I can make a copy of your code and write heavy error-trapping code into it that will help us determine where it's erroring-out. I'll then post the code in this forum thread so that you can give it a try. I do believe that we will find a solution to this problem. Hang in there!

Brian

Brian J. Torreano

 

[craigpritchardweb]

Cheers, mate.

I have been trying out the breakpoints on other VBA code I've been working on and it seems to work a treat. Definitely better than commenting out or removing some code!

 

[btorrean]

Craig,

Please don't give up. I'm still working on the code. I'll try to post new code for you to try in the next few days. Hang in there!

Brian

Brian J. Torreano

 

[craigpritchardweb]

No worries, Brian. I appreciate your efforts. I have other work to do for the time being, so its all good.

 

[btorrean]

Craig,

I've got some code for you to test. Please give the code below a try. Please also remember to only test this with copies of the data initially, as I have had no way to test this myself. Please also let me know if this works for you. If it doesn't, there is more work we can do. Here's the code:

Option Explicit
Option Compare Text


Public Sub cmdUpload_Click()


On Error GoTo Error_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 j           As Integer
    Dim n           As Integer
    Dim newSql      As String
    Dim qName       As Variant
    
    Dim strErrMsg   As String
    Dim myUpdates() As String
    
    ' Turn off screen updating.
    Application.ScreenUpdating = False
    
    ' Give our variables some values.
    DBFFolder = "C:\joycesupplies\wwstore_lawson\Data\"
    FileName = "wws_supplieritems.dbf"
    
    ' Set up the ADODB connection.
    ' First, describe error trapping.
    strErrMsg = "Setting up ADODB connection."
    ' Set the connection
    Set con = New ADODB.Connection
        
    ' Open the connection
    strErrMsg = "Opening the ADODB connection."
    con.Open "Provider=vfpoledb;" & "Data Source=" & DBFFolder & FileName & ";Collating Sequence=machine"
    
    ' Populate the SQL string.
    strErrMsg = "Populating the SQL string."
    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"


    ' Set the Recordset object.
    strErrMsg = "Setting the recordset object."
    Set rs = CreateObject("ADODB.recordset")
    
    ' Define the recordset parameters.
    strErrMsg = "Setting the recordset parameters."
    rs.CursorLocation = 3
    rs.CursorType = 1
    
    ' Open the recordset.
    strErrMsg = "Opening the recordset."
    rs.Open sql, con
    
    ' Re-dimension the recordset array.
    strErrMsg = "Re-dimensioning the recordset array."
    ReDim myValues(rs.RecordCount, 4)
    
    ' Set the counter
    i = 1
    j = 0
    ' Loop through the recordset
    strErrMsg = "Looping through the recordset array."
    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"
                strErrMsg = "Processing SQL: " & newSql
                ReDim Preserve myUpdates(i - 1) As String
                 
                myUpdates(UBound(myUpdates)) = newSql
                
                i = i + 1
                j = j + 1
            End If
            
            rs.MoveNext
        Loop
    Else
             
        MsgBox "There are no records in the recordset!", vbCritical, "No Records"
        Exit Sub
    End If
    
    strErrMsg = "Closing recordset 'rs'."
    rs.Close
    Set rs = Nothing
    
    strErrMsg = "Creating recordset 'rs2'."
    Set rs2 = CreateObject("ADODB.recordset")
    
    strErrMsg = "Setting cursor for recordset 'rs2'."
    rs2.CursorLocation = 3
    rs2.CursorType = 1
    
    strErrMsg = "Beginning updates using 'rs2'."
    n = 0
    For Each qName In myUpdates
        strErrMsg = "Opening SQL string:" & vbCrLf & qName & vbCrLf & "in recordset 'rs2'."
        rs2.Open qName, con
        strErrMsg = "Commiting changes for SQL string:" & vbCrLf & qName
        rs2.Update
        n = n + 1
    Next
    
    ' Tell the user what we did.
    MsgBox "End of Macro." & vbCrLf & vbCrLf & "Number of requested updates was " & j & _
        vbCrLf & "Number of updates executed was " & n, vbInformation, "Done!"
    
Exit_cmdUpload_Click:


    ' Clean up.
    rs.Close
    rs2.Close
    con.Close
    Set rs = Nothing
    Set rs2 = Nothing
    Set con = Nothing


    ' Turn screen updating back on.
    Application.ScreenUpdating = True


    '... and get out.
    Exit Sub


Error_cmdUpload_Click:


    ' Tell the user what happened.
    MsgBox "A macro error occurred at the following step:" & _
        vbCrLf & vbCrLf & strErrMsg & vbCrLf & vbCrLf & "Aborting.", vbCritical, "Error..."
    
    ' Go to the exit breakpoint.
    Resume Exit_cmdUpload_Click:
   
End Sub

 

[btorrean]

Craig,

Did you have a chance to test the code I provided?

Brian

Brian J. Torreano

 

[btorrean]

Craig,

Could you please let me know if you've had a chance to work with the code I provided? I spent a lot of time researching and modifying the code and would like at least a little feedback, please. Thanks!

Brian

Brian J. Torreano