ADODB error handling variable not setting - vba

I building an ADODB error trap but for some reason, by errSQL.Number and errSQL.Description both give me a "Object variable or With Block variable not set." error....here is my code so far...I have the active x object enabled and I thought that .number and .description are correct...any help would be awesome! The query I'm running also purposely will send an error.
When I comment the error trap out, I do get a message box with a SQL syntax error but can't seem to trap it like below...
Public errSQL As ADODB.Error
Public strErrODBC As String
Private Sub verifySQL()
Dim strSQL2 As String
Dim cn As New ADODB.Connection
Dim cdTxt As String
Dim rs As New ADODB.Recordset
Dim intVerify As Integer
On Error GoTo ODBCErrorHandler
cn.ConnectionString = "DSN=source;"
cn.Open
If cn.State = adStateOpen Then
rs.Open "SELECT CASE WHEN MAX((CASE WHEN " & Forms!dlgSplitName.lstbxFlds.Column(0) & " " & cdTxt & " THEN 1 ELSE 0 END)) =1 THEN 1 ELSE 0 END FROM table;", cn
Else
End If
intVerify = rs.Fields(0).Value
If intVerify = 1 Then
insrt_Test
ElseIf intVerify = 0 Then
MsgBox "No records were found with the code text logic.", vbExclamation + vbOKOnly, "Spliy by Notification"
End If
ODBCErrorHandler:
Debug.Print errSQL.Number
Debug.Print errSQL.Description
strErrODBC = "A SQL error was encountered with the code text logic." & vbCrLf
strErrODBC = strErrODBC & "Error " & errSQL.Number & vbCrLf
strErrODBC = strErrODBC & " " & errSQL.Description
MsgBox strErrODBC & vbCrLf & "Please try again.", vbCritical, "Split by field code text error."
cn.Close
End Sub

The problem is that the errSQL ADODB Error object is never set to anything. the Connection object has an error collection that you need to use to display the errors. Try this:
ODBCErrorHandler:
Dim ErrorCount As Double
Dim strError As String
ErrorCount = cn.Errors.Count
strErrODBC = "A SQL error was encountered with the code text logic." & vbCrLf
If ErrorCount > 0 Then
For index = 0 To (ErrorCount - 1)
Set errSQL = cn.Errors.Item(index)
strErrODBC = strErrODBC & "Error " & errSQL.Number & vbCrLf
strErrODBC = strErrODBC & " " & errSQL.Description & vbCrLf
Next index
End If
MsgBox strErrODBC & vbCrLf & "Please try again.", vbCritical, "Split by field code text error."
cn.Close
Hope this helps.

Related

Loop through continuous form records and adding them to a table

Good afternoon,
I have a bound continuous form with a yes/no checkbox for each of the records shown. I'd like to have my users be able to click a "Select all" control and automatically have each one of those records be added to a different table.
So far, I have my loop working but not quite sure where to insert the proper code to add the records. I am using a frame control with a with a "Select all" "Deselect all" options. The [PrintPart] is the Yes/No field in the form.
Many thanks.
Private Sub SelectionFrame_Click()
Dim SQL as String
On Error GoTo errHandler
SQL = "INSERT INTO PARTS_T ([PRINTORDER], [PART_TITLE], [PARTID])
VALUES (" & Me.RecordsetClone.RecordCount + 1 & "," & Chr(34) &
Me.PART_TITLE & Chr(34) & "," & Me.PARTID & ");"
'Toggle select/deselect all
Select Case Me.SelectionFrame
Case 1 'Select
With Me.RecordsetClone
.MoveFirst
Do While Not .EOF
.Edit
!PrintPart = True
RunSQLCode
.Update
.MoveNext
Loop
End With
Case 2 'Deselect
With Me.RecordsetClone
.MoveFirst
Do While Not .EOF
.Edit
!PrintPart = False
.Update
.MoveNext
Loop
End With
End Select
Exit Sub
errHandler:
MsgBox "The following error has occurred: " & vbNewLine & vbNewLine & "Error Number: " & Err.Number & vbNewLine & "Error Description: " & Err.Description, vbCritical, "Error - " & APPNAME
End Sub
Don't run repeated SQL. DAO is way simpler and faster:
Private Sub SelectionFrame_Click()
Dim Source As DAO.Recordset
Dim Target As DAO.Recordset
Dim SQL As String
Dim PrintPart As Boolean
Dim PrintOrder As Long
On Error GoTo errHandler
Set Source = Me.RecordsetClone
PrintOrder = Source.RecordCount
If PrintOrder > 0 Then
SQL = "Select * From PARTS_T"
Set Target = CurrentDb.OpenRecordset(SQL, dbOpenDynaset, dbAppendOnly)
PrintPart = Me.SelectionFrame
Source.MoveFirst
While Not Source.EOF
If Source!PrintPart.Value <> PrintPart Then
Source.Edit
Source!PrintPart.Value = PrintPart
Source.Update
End If
Target.AddNew
Target!PRINTORDER.Value = PrintOrder + 1
Target!PART_TITLE.Value = Source!PART_TITLE.Value
Target!PARTID.Value = Source!PARTID.Value
Target.Update
Wend
Target.Close
End If
Source.Close
Exit Sub
errHandler:
MsgBox "The following error has occurred: " & vbNewLine & vbNewLine & "Error Number: " & Err.Number & vbNewLine & "Error Description: " & Err.Description, vbCritical, "Error - " & APPNAME
End Sub

Checking Null Value in Access VBA recordset throws null exception?

I have tried this every different way, and it was working yesterday, so I really don't know what changed.
I import a spreadsheet to a temp table in an Access app. Then I set that to be the dao.recordset, and start looping through. I check for the ID to not be null and if not go through checking fields for values, and updating as appropriate. the minute I hit a null, I get a system error "94 - invalid use of null"
It doesn't offer a debug, but I have debugs throughout my code, so I can see where it fails. It fails when I do this check: If IsNull(rstImportCList("columnx")) = False Then
I have tried nz(rstImportCList("columnx"),"") <> "" I have tried rstImportCList("columnx") is not null, and everything else I can think of. Why is the check that is supposed to prevent this error, causing this error?
Edit:
This is the beginning where I declare the recordset I can't get past doing anything with the recordset field.
Dim db As DAO.Database
Dim rstImportCList As DAO.Recordset
Dim RSsql As String
Set db = CurrentDb()
RSsql = "Select * from tblTempImportCList"
Set rstImportCList = db.OpenRecordset(RSsql)
If rstImportCList.EOF Then Exit Sub
Do While Not rstImportCList.EOF
whether I try to check
IsNull(rstImportCList("xyz").Value) = False
or
nz(rstImportCList("xyz").Value,"") <> ""
or
dim x as string
x = rstImportCList!xyz.value
I get the same error 94 invalid use of null.
Any idea why this is?
--edit with more code.
I took some time to take a the beginning and some of each section of the code, so I could make it generic and see if anyone can help. Here is what I am working on. The Code1 and Code2 parts don't seem to be the issue. Sometimes it fails on a null value in a Yes/No column (I'm just looking for Y but the value is null), sometimes on the notes being null. It's not consistent, which is why I'm having a hard time nailing down the issue.
Private Sub cmdImportList_Click()
On Error GoTo cmdImportExcel_Click_err:
Dim fdObj As FileDialog
Set fdObj = Application.FileDialog(msoFileDialogFilePicker)
Dim varfile As Variant
Dim importCT As Integer
Dim dbu As DAO.Database
Dim cBadXVal, cBadYVal As Integer
Dim preNotes As String
Dim RSsql As String
Dim uNotesql, uVal1sql, uVal2sql As String
Dim db As DAO.Database
Dim rstImportCList As DAO.Recordset
Dim CheckB4Import As Integer
CheckB4Import = MsgBox("Are you SURE the sheet you are importing has the following column names in the same order:" & vbCrLf & vbCrLf & _
"IDName/ First/ Mid/ Last/ Sfx/ Age/ Telephone/ Code1/ Code2/ YN1/ YN2/ NY3/ Notes/ AsYN1edTo" & vbCrLf & vbCrLf & _
"AND that there are NO empty rows or empty columns?" & vbCrLf & vbCrLf & _
"Click OK to proceed, Click CANCEL to go double-check your CallSheet before importing.", vbOKCancel, "WITH GREAT POWER COMES GREAT RESPONSIBILITY TO QC DATA")
If CheckB4Import = vbOK Then
CurrentDb.Execute "DELETE * FROM tblTempImportCList", dbFailOnError
With fdObj
'CAN ONLY SELECT 1 FILE
.allowmultiselect = False
.Filters.Clear
.Filters.Add "Excel 2007+", "*.xlsx"
.Title = "Please select the completed list to import:"
.Show
If .SelectedItems.Count = 1 Then
varfile = .SelectedItems(1)
DoCmd.TransferSpreadsheet acImport, , "tblTempImportCList", varfile, True, "Sheet1!"
cBadXVal = DLookup("BadXCount", "qryImpCheckBadXVal")
Debug.Print "cBadXVal - " & cBadXVal
If cBadXVal <> 0 Then
DoCmd.OpenForm "frmImportError", acNormal
Forms!frmImportError.Form.lblErrorMsg.Caption = _
"Oh No! Your list import failed!" & vbCrLf & _
cBadXVal & " X values are not valid." & vbCrLf & _
"Don't worry. You can fix your sheet and re-import!" & vbCrLf & _
"Would you like to open the documentation for the valid codes" & vbCrLf & _
"Or are you all set?"
End If
cBadYVal = DLookup("BadYCount", "qryImpCheckBadYVal")
Debug.Print "cBadYVal - " & cBadYVal
If cBadYVal <> 0 Then
DoCmd.OpenForm "frmImportError", acNormal
Forms!frmImportError.Form.lblErrorMsg.Caption = _
"Oh No! Your list import failed!" & vbCrLf & _
cBadYVal & " YN1 values are not valid." & vbCrLf & _
"Don't worry. You can fix your sheet and re-import!" & vbCrLf & _
"Would you like to open the documentation for the valid codes" & vbCrLf & _
"Or are you all set?"
Exit Sub
End If
Else
MsgBox "No file was selected. Try again!", vbCritical, "Uh-oh Spaghettios!"
End If
End With
'PASSED CHECKS
Set db = CurrentDb()
RSsql = "Select * from tblTempImportCList"
Set rstImportCList = db.OpenRecordset(RSsql)
If rstImportCList.EOF Then Exit Sub
Debug.Print "got here"
Do While Not rstImportCList.EOF
Debug.Print "Start Processing: " & Nz(rstImportCList("IDName").Value, "")
'GET NOTES ALREADY ON RECORD
If Nz(rstImportCList("IDName").Value, "") <> "" Then
Debug.Print "got past if IDName is not null"
If Nz(rstImportCList("Notes").Value, "") <> "" Then
Debug.Print "got past if notes is not null"
preNotes = Replace(Nz(DLookup("Notes", "tblVFileImport", "IDName = " & rstImportCList("IDName").Value), ""), """", "")
'UPDATE NOTES
If Nz(preNotes, "") <> "" Then
uNotesql = "Update tblVFileImport SET tblVFileImport.Notes = '" & preNotes & "; " & Replace(Nz(rstImportCList("Notes").Value, ""), """", "") & "' " & _
"WHERE tblVFileImport.IDName = " & rstImportCList("IDName").Value
'debug.print "Notes"
'debug.print "uNotesql - " & uNotesql
Else
uNotesql = "Update tblVFileImport SET tblVFileImport.Notes = '" & Replace(Nz(rstImportCList("Notes").Value, ""), """", "") & "' " & _
"WHERE tblVFileImport.IDName = " & rstImportCList("IDName").Value
End If
RunMySql (uNotesql)
'DoCmd.RunSQL (uNotesql), dbFailOnError
End If
If Nz(rstImportCList("YN1").Value, "") = "Y" Then
'UPDATE YN1
uYN1sql = "Update tblVFileImport SET tblVFileImport.YN1 = '" & rstImportCList("YN1") & "', tblVFileImport.callprocessed = 'Y' " & _
"WHERE tblVFileImport.IDName = " & rstImportCList("IDName")
Debug.Print "YN1 = Y or y"
Debug.Print "uYN1sql - " & uYN1sql
RunMySql (uYN1sql)
'DoCmd.RunSQL (uYN1sql), dbFailOnError
End If
If Nz(rstImportCList("YN2").Value, "") = "Y" Then
'UPDATE YN2
uYN2sql = "Update tblVFileImport SET tblVFileImport.YN2 = '" & rstImportCList("YN2") & "', tblVFileImport.callprocessed = 'Y' " & _
"WHERE tblVFileImport.IDName = " & rstImportCList("IDName")
Debug.Print "YN2 = Y or y"
Debug.Print "uYN2sql - " & uYN2sql
RunMySql (uYN2sql)
'DoCmd.RunSQL (uYN2sql), dbFailOnError
End If
'START Code1 PROCESSING
If Nz(rstImportCList("Code1").Value, "") <> "" Then
'Code1 Case abc
vdispo = DLookup("Code1", "tblvFileImport", "IDName = " & rstImportCList("IDName"))
If rstImportCList("Code1") = "ABC" Then
Debug.Print "Dispo Case ABC"
'DELETE RECORD
dMDsql = "DELETE from tblVFileImport " & _
"WHERE tblVFileImport.IDName = " & rstImportCList("IDName")
Debug.Print "dMDsql - " & dMDsql
RunMySql (dMDsql)
'DoCmd.RunSQL (dMDsql), dbFailOnError
'Code1 Case DEF OR GHI OR JKL
ElseIf Nz(rstImportCList("Code1"), "") = "DEF" Or Nz(rstImportCList("Code1"), "") = "GHI" Or Nz(rstImportCList("Code1"), "") = "JKL" Then
Debug.Print "Dispo Case DEF OR GHI OR JKL "
'IF DEF
If rstImportCList("Code1") = "DEF" Then
'IF CELL SAME - UPDATE NULL
ccellsame = DLookup("IDName", "tblVFileImport", "IDName = " & rstImportCList("IDName") & " AND nz(Cell,'') = Phone ")
If ccellsame = rstImportCList("IDName") Then
uCellsql = "Update tblVFileImport SET tblVFileImport.Cell = NULL, tblVFileImport.CellString = NULL, tblVFileImport.mobileflag = NULL " & _
"WHERE tblVFileImport.IDName = " & rstImportCList("IDName")
Debug.Print "uCellsql - " & uCellsql
RunMySql (uCellsql)
'DoCmd.RunSQL (uCellsql), dbFailOnError
End If
End If
End If
End If
End If
Debug.Print "End Processing: " & rstImportCList("IDName")
rstImportCList.MoveNext
Loop
Debug.Print "Finished Looping"
rstImportCList.Close
importCT = DCount("IDName", "tblTempImportCList")
MsgBox importCT & " Records imported for list.", vbOKOnly, "List Processed"
Else
MsgBox "Good Call. Check twice, import once!", vbOKOnly, "Better Safe Than Sorry"
End If
Exit Sub
cmdImportExcel_Click_err:
Select Case Err.Number
Case Else
Call MsgBox(Err.Number & " – " & Err.Description, vbCritical + vbOKOnly, "System Error …")
End Select
End Sub
Any suggestions are greatly appreciated. I'm 1/2 tempted to suck this into a SQL table and just execute a stored procedure. I can get it to work in there, I think.
If IsNull(rstImportCList("columnx").Value) Then
otherwise you're checking if the Field object itself is null.
https://learn.microsoft.com/en-us/office/client-developer/access/desktop-database-reference/field-object-dao#:~:text=To%20refer%20to,Fields(%22name%22)
This is a case where relying on a default property (in this case Value) causes problems.

How to retrieve data from other Excel using VBA and SQL?

I have a problem with my code. I tried retrieving data from other Excel file. My code works but I received full data in one cell (A1). I'm sorry but I'm just beginner, believe that's the problem related to output, but I'm not find out why:
Sub RefreshData()
'Refresh data
Dim CreateNew As Object
Dim RunSELECT As Object
Dim Data As String
Dim SQL As String
FolderPath = ActiveWorkbook.path
path = Left(FolderPath, InStrRev(FolderPath, "\") - 1)
Set CreateNew = CreateObject("ADODB.Connection")
With CreateNew
.Provider = "Microsoft.ACE.OLEDB.12.0"
.ConnectionString = "Data Source=" & path & "\Task1.xlsm; Extended Properties=Excel 12.0 Xml;HDR=YES;IMEX=1;CorruptLoad=xlRepairFile"
.Open
End With
'Run SQL
SQL = "SELECT * FROM [tw$]"
Set RunSELECT = CreateNew.Execute(SQL)
Do
output = output & RunSELECT(0) & ";" & RunSELECT(1) & ";" & RunSELECT(2) & vbNewLine
Debug.Print RunSELECT(0); ";" & RunSELECT(1) & ";" & RunSELECT(2)
RunSELECT.Movenext
Loop Until RunSELECT.EOF
ThisWorkbook.Worksheets("Dic").Range("A1").Value = output
RunSELECT.Close
CreateNew.Close
Set CreateNew = Nothing
Set RunSELECT = Nothing
End Sub
No need to wrap recordset values wtih semicolon delimiters using a Do loop. Simply use Range.CopyFromRecordset:
SQL = "SELECT * FROM [tw$]"
Set RunSELECT = CreateNew.Execute(SQL)
ThisWorkbook.Worksheets("Dic").Range("A1").CopyFromRecordset RunSELECT
RunSELECT.Close
CreateNew.Close
Set CreateNew = Nothing
Set RunSELECT = Nothing
ADOdb to Retrieve Data From Another Workbook (Without Opening It)
While playing around with Parfait's solution combined with a few posts, I came up with the function copySheetADOdb.
Adjust the constants under Source and Target in testCopySheetADOdb to test it.
The Code
Option Explicit
Sub testCopySheetADOdb()
' Initialize error handling.
Const ProcName = "testCopySheetADOdb"
On Error GoTo clearError ' Turn on error trapping.
' Source
Const Path As String = "F:\Test"
Const FileName As String = "Test.xlsx"
' Sheet Name ('SheetName') is case-insensitive i.e. 'A = a'.
Const SheetName As String = "Sheet1"
' Target
Const tgtName As String = "Sheet1"
Const tgtCell As String = "A1"
Dim wb As Workbook: Set wb = ThisWorkbook
' Define FilePath.
Dim FilePath As String
FilePath = Path & Application.PathSeparator & FileName
' Define Target Range.
Dim rng As Range
Set rng = wb.Worksheets(tgtName).Range(tgtCell)
' Test Result.
Dim Result As Boolean
Result = copySheetADODb(rng, FilePath, SheetName)
' Of course you can do all the above in one line:
'Result = copySheetADODB(Thisworkbook.Worksheets("Sheet1").Range("A1"), _
"C:\Test\Test.xlsx", "Sheet1")
' Inform user.
If Result Then
MsgBox "Worksheet successfully copied.", vbInformation, "Success"
Else
MsgBox "Worksheet not copied.", vbExclamation, "Failure"
End If
ProcExit:
Exit Sub
clearError:
Debug.Print "'" & ProcName & "':" & vbLf & " " & "Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
On Error GoTo 0 ' Turn off error trapping.
GoTo ProcExit
End Sub
Function copySheetADOdb(TargetCellRange As Range, _
ByVal SourceFilePath As String, _
Optional ByVal SourceSheetName As String = "Sheet1") _
As Boolean
' Initialize error handling.
Const ProcName = "copySheetADOdb"
On Error GoTo clearError ' Turn on error trapping.
' Test Target Cell Range ('TargetCellRange').
If TargetCellRange Is Nothing Then
GoTo NoTargetCellRange
End If
If TargetCellRange.Rows.Count > 1 Or TargetCellRange.Columns.Count > 1 Then
GoTo OneCellOnly
End If
'
' Define SQL Generic String.
Const sqlGeneric As String = "SELECT * FROM [SheetName$]"
Dim conn As Object
Set conn = CreateObject("ADODB.Connection")
Dim strErr As String
With conn
.Provider = "Microsoft.ACE.OLEDB.12.0"
' If you need the headers, HDR=NO means there are no headers
' (not: do not retrieve headers) so the complete data will be retrieved.
.ConnectionString = "Data Source='" _
& SourceFilePath _
& "';" _
& "Extended Properties='" _
& "Excel 12.0 Xml;" _
& "HDR=NO;" _
& "IMEX=1;" _
& "CorruptLoad=xlRepairFile" _
& "';"
On Error GoTo connOpenError
.Open
On Error GoTo clearError
' Run SQL.
Dim SQL As String
' Replace 'SheetName' in SQL Generic String
' with the actual sheet name ('SourceSheetName').
SQL = Replace(sqlGeneric, "SheetName", SourceSheetName)
Dim rs As Object
On Error GoTo connExecuteError
Set rs = .Execute(SQL)
On Error GoTo clearError
If Not TargetCellRange Is Nothing Then
' Copy sheet.
If Not rs.EOF Then
TargetCellRange.CopyFromRecordset rs
' Write result.
copySheetADOdb = True
Else
GoTo NoRecords
End If
End If
NoRecordsExit:
rs.Close
connExecuteExit:
.Close
End With
ProcExit:
Set rs = Nothing
connOpenExit:
Set conn = Nothing
Exit Function
NoTargetCellRange:
Debug.Print "'" & ProcName & "': " & "No Target Cell Range ('Nothing')."
GoTo ProcExit
OneCellOnly:
Debug.Print "'" & ProcName & "': " _
& "Target Cell Range has to be one cell range only."
GoTo ProcExit
NoRecords:
Debug.Print "'" & ProcName & "': No records found."
GoTo NoRecordsExit
connOpenError:
If Err.Number = "-2147467259" Then ' "-2147467259 (80004005)"
strErr = "'" & SourceFilePath & "' is not a valid path"
If Left(Err.Description, Len(strErr)) = strErr Then
Debug.Print "'" & ProcName & "': " & strErr & "..."
On Error GoTo 0 ' Turn off error trapping.
GoTo connOpenExit
End If
Else
GoTo clearError
End If
connExecuteError:
If Err.Number = "-2147467259" Then ' "-2147467259 (80004005)"
strErr = "'" & SourceSheetName & "' is not a valid name"
If Left(Err.Description, Len(strErr)) = strErr Then
Debug.Print "'" & ProcName & "': " & strErr & "..."
On Error GoTo 0 ' Turn off error trapping.
GoTo connExecuteExit
End If
Else
GoTo clearError
End If
clearError:
Debug.Print "'" & ProcName & "':" & vbLf & " " & "Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
On Error GoTo 0 ' Turn off error trapping.
GoTo ProcExit
End Function
You have problem in this code:
ThisWorkbook.Worksheets("Dic").Range("A1").Value = output
you are yourself asking to save the output to A1 Cell.
I would suggest you use for or while loop to enter the data in cells according to your need.

How can I manage error code SQL in MS access form database?

I want manage SQL server error code in access form
sample duplicate error from SQL server
In Access VBA, you need to use:
On Error GoTo Error_Handler
' YOUR CODE HERE
.
.
.
Return_Label:
Exit Function
Error_Handler:
'What goes here depends on the data access model
Resume Return_Label
You may have to retrieve the Errors collection of the Error object as described here.
It shows this example code:
Sub DescriptionX()
Dim dbsTest As Database
On Error GoTo ErrorHandler
' Intentionally trigger an error.
Set dbsTest = OpenDatabase("NoDatabase")
Exit Sub
ErrorHandler:
Dim strError As String
Dim errLoop As Error
' Enumerate Errors collection and display properties of
' each Error object.
For Each errLoop In Errors
With errLoop
strError = _
"Error #" & .Number & vbCr
strError = strError & _
" " & .Description & vbCr
strError = strError & _
" (Source: " & .Source & ")" & vbCr
strError = strError & _
"Press F1 to see topic " & .HelpContext & vbCr
strError = strError & _
" in the file " & .HelpFile & "."
End With
MsgBox strError
Next
Resume Next
End Sub

Microsoft Access - Multiple Transactions when Inserting into Remote DB

I'm currently trying to do multiple inserts from an access database to a remote sql server. Thus far I've had no luck. When I attempt to code in a workspace and transactions I receive a data mismatch error, but the functional insert works perfectly fine separately.
Here is my code: Transaction One has been commented out
Private Sub cmdInsSqlSrvr_Click()
On Error GoTo ErrHandler
Dim dbAccess As DAO.Database
Dim strTableName As String
Dim strSQL As String
Dim strSqlServerDB As String
Dim strTableName2 As String
Dim cInTrans As Boolean
Dim wsp As DAO.Workspace
strTableName = "po_header_sql"
strTableName2 = "po_line_Sql"
'<configuration specific to SQL Server ODBC driver>
strSqlServerDB = "ODBC;DRIVER={SQL Server};" & _
"Server=;" & _
"DATABASE=;" & _
"Uid=;" & _
"Pwd=;"
'Start Transaction One
'Set dbAccess = DBEngine(0)(0)
' strSQL = "INSERT INTO [" & strSqlServerDB & "].TABLE3 SELECT * FROM " & strTableName & ";"
'dbAccess.Execute strSQL, dbFailOnError
'InitConnect = True
'MsgBox (dbAccess.RecordsAffected & " records have been moved from " & strTableName & " to remote DB")
'Command9.SetFocus
'cmdInsSqlSrvr.Enabled = False
'cmdInsertTbl.Enabled = True
' End Transaction One
'Begin Transaction Two
Set wsp = DBEngine(0)(0)
wsp.BeginTrans
Set dbAccess = wsp(0)
cInTrans = True
strSQL = "INSERT INTO [" & strSqlServerDB & "].TABLE4 SELECT * FROM " & strTableName2 & ";"
dbAccess.Execute strSQL, dbFailOnError
InitConnect = True
MsgBox (dbAccess.RecordsAffected & " records have been moved from " & strTableName & " to remote DB")
wsp.CommitTrans
cInTrans = False
Command9.SetFocus
cmdInsSqlSrvr.Enabled = False
cmdInsertTbl.Enabled = True
'End Transaction Two
ExitProcedure:
On Error Resume Next
Set dbAccess = Nothing
Exit Sub
ErrHandler:
InitConnect = False
MsgBox Err.Description, vbExclamation, "Moving data to Sql Server failed: Error " & Err.Number
Resume ExitProcedure
End Sub
Fixed it by separating the insert statements and putting dbAccess.Execute after each one. Also cleaned up the code substantially. Code follows:
Private Sub cmdInsSqlSrvr_Click()
On Error GoTo ErrHandler
Dim dbAccess As DAO.Database
Dim strTableName As String
Dim strSQL As String
Dim strSqlServerDB As String
Dim strTableName2 As String
strTableName = "po_header_sql"
strTableName2 = "po_line_Sql"
'<configuration specific to SQL Server ODBC driver>
strSqlServerDB = "ODBC;DRIVER={SQL Server};" & _
"Server=<server ip>;" & _
"DATABASE=<database name>;" & _
"Uid=<database uid>;" & _
"Pwd=<database password>;"
Set dbAccess = DBEngine(0)(0)
strSQL = "INSERT INTO [" & strSqlServerDB & "].TABLE3 SELECT * FROM " & strTableName & ";"
dbAccess.Execute strSQL, dbFailOnError
MsgBox (dbAccess.RecordsAffected & " records have been moved from " & strTableName & " to remote DB")
strSQL = "INSERT INTO [" & strSqlServerDB & "].TABLE4 SELECT * FROM " & strTableName2 & ";"
dbAccess.Execute strSQL, dbFailOnError
InitConnect = True
MsgBox (dbAccess.RecordsAffected & " records have been moved from " & strTableName2 & " to remote DB")
Command9.SetFocus
cmdInsSqlSrvr.Enabled = False
cmdInsertTbl.Enabled = True
ExitProcedure:
On Error Resume Next
Set dbAccess = Nothing
Exit Sub
ErrHandler:
InitConnect = False
MsgBox Err.Description, vbExclamation, "Moving data to Sql Server failed: Error " & Err.Number
Resume ExitProcedure
End Sub