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,

It may be possible that you need to have a

Commit

statement after you populate the recordset and before you close the file. I think I remember that from my PLSQL days. I apologize that I do not have time right now to check that. Perhaps someone with more knowledge than me on the subject can chime in.

Brian

Brian J. Torreano

 

[craigpritchardweb]

Thanks for your quick reply, Brian. Sadly, COMMIT didn't seem to work in VBA or in Visual FoxPro.

I also tried using REPLACE instead of UPDATE but the macro would not complete when I did that, and the query syntax seemed to be correct. So I assume using UPDATE is still the way to go.

 

[craigpritchardweb]

Also, I am using Excel 2007 to do this task. Sorry for the bump but not sure how to edit posts yet.

 

[btorrean]

Craig,

Unfortunately, I'm not able to test this in the environment you are working in. However, I've done some more research and it appears that you need a

rs.CommitTrans

statement right before your code

rs.Close

. Please see these additional links about that:

https://docs.microsoft.com/en-us/sq...ans-committrans-and-rollbacktrans-methods-ado

https://msdn.microsoft.com/en-us/library/aa227162(v=vs.60).aspx

Please let me know if this helps.

Brian

Brian J. Torreano

 

[btorrean]

Craig,

Did you try the code? Did it work?

Brian

Brian J. Torreano

 

[craigpritchardweb]

Sorry for the late reply. I did try it and don't believe it worked. There doesn't appear to be any mistake with the queries as the UPDATE queries work correctly when I test them on Visual FoxPro.

 

[btorrean]

Craig,

Sorry, I'm out of ideas. Hopefully someone else on the forum can come up with a solution for you.

Brian

Brian J. Torreano

 

[btorrean]

Craig,

Actually, can you tell me at what point the code errors-out? All hope may not yet be lost.

Brian

Brian J. Torreano

 

[craigpritchardweb]

There isn't an error as such. The code runs to the end, including showing the "End of Macro" message box. That makes the mistake harder to pin down but I believe the mistake is around here:

For Each qName in myUpdates
   rs2.Open qName, con
Next