craigpritchardweb
New Member
- Joined
- Mar 14, 2017
- Messages
- 17
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.
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.
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.
Code:
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.