I executed the Insert statement twice in the code. The first time the inserts statement is working, but the second time the inserts statement does not work. I wish all the cooperation. Code as below:
Private Sub cmdOrder_Click()
On Error Resume Next
Dim dbs As DAO.Database, rst As DAO.Recordset, lstID As Integer
Set dbs = CurrentDb
If Nz(DCount("[Active]", "tblReview", "[EmpID] = [TempVars]![tmpUserID] And [Active]=-1"), 0) = 0 Then
dbs.Execute "INSERT INTO tblReview(EmpID, Active, Created, Submitted)" & _
"VALUES (" & [TempVars]![tmpUserID] & " ,-1, Date(), 0)"
lstID = dbs.OpenRecordset("SELECT ##IDENTITY")(0)
'If IsNull(DLookup("ReviewID", "tblReviewDetails", "[EmpID] = " & [TempVars]![tmpUserID] & " And [ReviewID] =" & lstID)) Then
Set rst = dbs.OpenRecordset("SELECT ActionsAndBehaviors FROM tblReviewItmes WHERE MgtLevel=" & [TempVars]![tmpAccess])
Do While Not rst.EOF
dbs.Execute "INSERT INTO tblReviewDetails(ReviewID, ReviewItems, EmpID)" & _
"VALUES (lstID , rst!ActionsAndBehaviors, [TempVars]![tmpUserID])", dbFailOnError
'Debug.Print rst!ActionsAndBehaviors
rst.MoveNext
Loop
'End If
rst.Close
Set rst = Nothing
Set dbs = Nothing
End If
End Sub
The second insert command is incorrect?
dbs.Execute "INSERT INTO tblReviewDetails(ReviewID, ReviewItems, EmpID)" & _
"VALUES (lstID , rst!ActionsAndBehaviors, [TempVars]![tmpUserID])", dbFailOnError
should be
dbs.Execute "INSERT INTO tblReviewDetails(ReviewID, ReviewItems, EmpID)" & _
"VALUES (" & lstID & " , " & rst!ActionsAndBehaviors ", " & [TempVars]![tmpUserID] & ")", dbFailOnError
but please use a recordset.AddNew method to add new records. Your method is very prone to further errors/ SQL Injection
Always add MoveFirst before iteration:
...
Set rst = dbs.OpenRecordset("SELECT ActionsAndBehaviors FROM tblReviewItmes WHERE MgtLevel=" & [TempVars]![tmpAccess])
rst.MoveLast
rst.MoveFirst
Do While Not rst.EOF
...
Related
We have a Front end app created in MS Access and a back-end supported by an Oracle database.
The users are required to upload an Excel file (around 6000 rows) every day and the process is done currently like this:
we have a temporary table where a VBA code is moving the excel data (the table is empty at every load)
once the file is uploaded another VBA code is pulling the data from that table and moves it using DAO to the server, line by line
The process takes a huge amount of time and we need to speed up the process.
The existing code with some adjustments and fields not presented here:
Public Function import_to_dwh_old_1() As Boolean
Dim rst As DAO.Recordset
Dim strSQL As String
Dim bol As Boolean
Dim strSQL_hr As Object
Dim rs As DAO.Recordset
Dim cnt As Integer
Dim i As Integer
Dim varReturn As Variant
Dim HR_ID As String
'######## 05/26/2019 - Fix to upload multiple times per day the HR file
db.Execute ("DELETE FROM DISPUTE_MGMT.DD_HR WHERE SNAPSHOT='" & Format(GetUTC(), "mm/dd/yyyy") & "'")
'######## End fix to upload ###########
bol = True
strSQL = "Select * FROM temp_hr"
Set rst = db.OpenRecordset(strSQL, dbOpenSnapshot)
Set rs = db.OpenRecordset("DISPUTE_MGMT_DD_HR")
rst.MoveLast
rst.MoveFirst
cnt = rst.RecordCount
i = 1
Do While Not rst.EOF
On Error GoTo capture_error
'varReturn = SysCmd(acSysCmdSetStatus, "Uploading dispute " & i & " out of " & cnt & " for snapshot [" & Format(GetUTC(), "mm/dd/yyyy") & "]")
rs.AddNew
rs!USER_NAME = Environ("USERNAME")
rs!IS_DELETED = 0
rs!DATE_CREATED = GetUTC()
rs!DATE_MODIFIED = GetUTC()
rs!SNAPSHOT = Format(GetUTC(), "mm/dd/yyyy")
rs!HR_ID = rst!ID
'### deleted fields from code
rs.Update
rst.MoveNext
i = i + 1
Loop
varReturn = SysCmd(acSysCmdSetStatus, " ")
import_to_dwh = True
Exit Function
capture_error:
Debug.Print Err.Description
MsgBox Err.Description & " - HR_ID = " & HR_ID
varReturn = SysCmd(acSysCmdSetStatus, " ")
import_to_dwh = False
Exit Function
End Function
The new idea is more direct but I am not sure how to use in the same time a MS Access table and a SQL database table in the same statement
Public Function import_to_dwh() As Boolean
Dim qdf As DAO.QueryDef, rst As DAO.Recordset
Dim strSQL As String
On Error GoTo Error_Handler
Set qdf = CurrentDb.CreateQueryDef("")
If env = "prod" Then
qdf.Connect = prod_credentials
Else
qdf.Connect = dev_credentials
End If
'Delete current snapshot
qdf.SQL = "DELETE FROM DISPUTE_MGMT.DD_HR WHERE SNAPSHOT='" & Format(GetUTC(), "dd-mmm-yyyy") & "';"
Debug.Print qdf.SQL
qdf.ReturnsRecords = False
qdf.Execute
qdf.SQL = "INSERT INTO DISPUTE_MGMT.DD_HR (USER_NAME, IS_DELETED, DATE_CREATED, DATE_MODIFIED, SNAPSHOT, HR_ID) SELECT '" & Environ("USERNAME") & "', 0, to_date('" & GetUTC() & "','mm/dd/yyyy hh:mi:ss am'), to_date('" & GetUTC() & "','mm/dd/yyyy hh:mi:ss am'), " _
& "'" & Format(GetUTC(), "dd-mmm-yyyy") & "', ID FROM temp_hr;"
Debug.Print qdf.SQL
qdf.ReturnsRecords = False
qdf.Execute
Error_Handler_Exit:
On Error Resume Next
If Not rst Is Nothing Then
rst.Close
Set rst = Nothing
qdf.Close
Set qdf = Nothing
End If
import_to_dwh = True
'If Not db Is Nothing Then Set db = Nothing
Exit Function
Error_Handler:
MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: " & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occured!"
Dim L As Long
For L = 0 To Errors.Count - 1
Debug.Print Errors(L) & " - " & Errors(L).Description
Next
import_to_dwh = False
Resume Error_Handler_Exit
End Function
Obviously, the second method does not work.. Could someone point me to the right direction?
Thank you!
This code is a function and not a private subroutine. I'm suddenly getting this error with the Me.[field name here]. I'm not getting that error in my other code, just in this one. Here's my full code without the boring end part, but I'm getting the error starting from the line:
Me.assignedby.Column(1)
Public Function AssignNullProjects() As Long
Dim db As dao.Database
Dim rs As dao.Recordset
Dim strSQL As String
assignedby = TempVars("user").Value
Set db = CurrentDb
strSQL = "SELECT CFRRRID FROM CFRRR WHERE assignedto Is Null"
Set rs = db.OpenRecordset(strSQL, dbOpenDynaset)
If Not rs.BOF And Not rs.EOF Then
While Not rs.EOF
strSQL = "UPDATE CFRRR SET assignedto = " & GetNextAssignee & ", assignedby = " & Me.assignedby.Column(1) & ", Me.Dateassigned = #" & Now & "#, Me.actiondate = #" & Now & "#, Me.Workername = " & _
Me.assignedto.Column(0) & ", Me.WorkerID = " & Me.assignedto.Column(0) & " WHERE CFRRRID = " & rs!CFRRRID
db.Execute strSQL, dbFailOnError
rs.MoveNext
Wend
End If
rs.Close
db.Close
Set rs = Nothing
Set db = Nothing
What could be the possible reason for the above-stated error, and how it could be removed?
Put that code in the form's code module. When you try to use Me in a standard module, you will always get that "Invalid use of Me keyword" complaint.
Check out the "Invalid use of Me keyword" and "Me <keyword>" topics in Access' help system for further details.
I want to read a linked table and update the local one.
Importing new entries works.
When I try to update an existing one it throws an exception
runtime error 3073
Sub UpdateBLPNR()
With CurrentDb
Set tdf = .CreateTableDef("ext_BEL_PLZ")
tdf.Connect = "ODBC;DSN=EasyProd PPS;DataDirectory=PATH;SERVER=NotTheServer;Compression= ;DefaultType=FoxPro;Rows=False;Language=OEM;AdvantageLocking=ON;Locking=Record;MemoBlockSize=64;MaxTableCloseCache=5;ServerTypes=6;TrimTrailingSpaces=False;EncryptionType=RC4;FIPS=False"
tdf.SourceTableName = "BEL_PLZ"
.TableDefs.Append tdf
.TableDefs.Refresh
End With
Dim SQLUpdate As String
Dim SQLInsert As String
SQLUpdate = "UPDATE BEL_PLZ " & _
"INNER JOIN ext_BEL_PLZ " & _
"ON(BEL_PLZ.NR = ext_BEL_PLZ.NR) " & _
"SET BEL_PLZ.BEZ = ext_BEL_PLZ.BEZ "
SQLInsert = "INSERT INTO BEL_PLZ (NR,BEZ) " & _
"SELECT NR,BEZ FROM ext_BEL_PLZ t " & _
"WHERE NOT EXISTS(SELECT 1 FROM BEL_PLZ s " & _
"WHERE t.NR = s.NR) "
DoCmd.SetWarnings False
DoCmd.RunSQL (SQLUpdate)
DoCmd.RunSQL (SQLInsert)
DoCmd.SetWarnings True
DoCmd.DeleteObject acTable, "ext_BEL_PLZ"
End Sub
Already figured out that Access might have some problems using a linked table to update a local one but I can't figure out a workaround.
(SQLInsert is working, SQLUpdate is not)
This is my final and working solution (thanks to ComputerVersteher)
Sub UpdateBLPNR()
'Define Variables
Dim SQLUpdate As String
Dim SQLInsert As String
Dim qdf As DAO.QueryDef
'Create temporary table and update entries
With CurrentDb
Set tdf = .CreateTableDef("ext_BEL_PLZ")
tdf.Connect = "ODBC;DSN=EasyProd PPS;DataDirectory=PATH;SERVER=NotTheServer;Compression= ;DefaultType=FoxPro;Rows=False;Language=OEM;AdvantageLocking=ON;Locking=Record;MemoBlockSize=64;MaxTableCloseCache=5;ServerTypes=6;TrimTrailingSpaces=False;EncryptionType=RC4;FIPS=False"
tdf.SourceTableName = "BEL_PLZ"
.TableDefs.Append tdf
.TableDefs.Refresh
With .OpenRecordset("SELECT ext_BEL_PLZ.NR, ext_BEL_PLZ.BEZ " & _
"FROM ext_BEL_PLZ INNER JOIN BEL_PLZ ON BEL_PLZ.NR = ext_BEL_PLZ.NR", dbOpenSnapshot)
Set qdf = .Parent.CreateQueryDef("")
Do Until .EOF
qdf.sql = "PARAMETERS paraBEZ Text ( 255 ), paraNr Text ( 255 );" & _
"Update BEL_PLZ Set BEL_PLZ.BEZ = [paraBEZ] " & _
"Where BEL_PLZ.NR = [paraNr]"
qdf.Parameters("paraBez") = .Fields("BEZ").Value
qdf.Parameters("paraNr") = .Fields("NR").Value
qdf.Execute dbFailOnError
.MoveNext
Loop
End With
End With
'Run SQL Query (Insert)
SQLInsert = "INSERT INTO BEL_PLZ (NR,BEZ) " & _
"SELECT NR,BEZ FROM ext_BEL_PLZ t " & _
"WHERE NOT EXISTS(SELECT 1 FROM BEL_PLZ s " & _
"WHERE t.NR = s.NR) "
DoCmd.SetWarnings False
DoCmd.RunSQL (SQLInsert)
DoCmd.SetWarnings True
'Drop temporary table
DoCmd.DeleteObject acTable, "ext_BEL_PLZ"
End Sub
Create a recordset from read only table to get values.
Dim qdf As DAO.QueryDef
With CurrentDb
With .OpenRecordset("SELECT ext_BEL_PLZ.NR, ext_BEL_PLZ.BEZ " & _
"FROM ext_BEL_PLZ INNER JOIN BEL_PLZ ON BEL_PLZ.NR = ext_BEL_PLZ.NR", dbOpenSnapshot)
Set qdf = .Parent.CreateQueryDef(vbNullString)
qdf.SQL = "PARAMETERS paraBEZ Text ( 255 ), paraNr Long;" & _
"Update BEL_PLZ Set BEL_PLZ.BEZ = [paraBEZ] " & _
"Where BEL_PLZ.NR = [paraNr]"
Do Until .EOF
qdf.Parameters("paraBez") = .Fields("BEZ").Value
qdf.Parameters("paraNr") = .Fields("NR").Value
qdf.Execute dbFailOnError
.MoveNext
Loop
End With
End With
You can't do that.
Linked tables on other data sources than Access itself require a primary key to support updates.
When linking through the GUI, Access does allow you to specify an alternate key that uniquely identifies rows if there is no primary key, but if there is one that should be your primary key.
rs2.FindFirst "[aniin] ='" & strTemp & "'"
aniin being an alias from the SQL within the function.
also tried ...
rs2.FindFirst (niin = newdata)
is my attempt to isolate the field name niin from the record value in the form from the one in the strSQL2. All my attempts have failed. I am trying to make sure that what the user typed in does match the list from the SQL string.
Private Function IsPartOfAEL(newdata) As Boolean
On Error GoTo ErrTrap
Dim db2 As DAO.Database
Dim rs2 As DAO.Recordset
Dim strTemp As String
strSQL2 = "SELECT tbl_ael_parts.master_ael_id, tbl_master_niin.niin as aniin " & vbCrLf & _
"FROM tbl_master_niin INNER JOIN tbl_ael_parts ON tbl_master_niin.master_niin_id = tbl_ael_parts.master_niin_id " & vbCrLf & _
"WHERE (((tbl_ael_parts.master_ael_id)= " & Forms!frm_qry_niin_local!master_ael_id & "));"
Set db2 = CurrentDb
Set rs2 = db2.OpenRecordset(strSQL2)
strTemp = newdata
If rs2.RecordCount <> 0 Then
rs2.FindFirst "[aniin] ='" & strTemp & "'"
If rs2.NoMatch Then
IsPartOfAEL = False
Else
IsPartOfAEL = True
End If
Else
MsgBox "Query Returned Zero Records", vbCritical
Exit Function
End If
rs.Close
Set rs2 = Nothing
Set db2 = Nothing
ExitHere:
Exit Function
ErrTrap:
MsgBox Err.description
Resume ExitHere
End Function
First: You should never include a constant like vbCrLf when building a query string. The query parser doesn't care if there's a linefeed, and in fact this can sometimes cause issues.
Your code seems to do nothing more that verify whether the value in newdata exists in the tbl_ael_parts and is associated with the value master_ael_id value currently showing on frm_qry_niin_local. If so, then just use DCount, or use this for your query:
strSQL2 = "SELECT tbl_ael_parts.master_ael_id INNER JOIN tbl_ael_parts ON
tbl_master_niin.master_niin_id = tbl_ael_parts.master_niin_id WHERE (((tbl_ael_parts.master_ael_id)=
" & Forms!frm_qry_niin_local!master_ael_id & ") AND niin=" & newdata & ");"
Dim rst As DAO.Recordset
Set rst = currentdb.OPenrecordset(strsql2)
If (rst.EOF and rst.BOF) Then
' no records returned
Else
' records found
End If
If niin is a Text field:
strSQL2 = "SELECT tbl_ael_parts.master_ael_id INNER JOIN tbl_ael_parts ON
tbl_master_niin.master_niin_id = tbl_ael_parts.master_niin_id WHERE (((tbl_ael_parts.master_ael_id)=
" & Forms!frm_qry_niin_local!master_ael_id & ") AND (niin='" & newdata & "'));"
If both niin and master_ael_id are Text fields:
strSQL2 = "SELECT tbl_ael_parts.master_ael_id INNER JOIN tbl_ael_parts ON
tbl_master_niin.master_niin_id = tbl_ael_parts.master_niin_id WHERE (((tbl_ael_parts.master_ael_id)=
'" & Forms!frm_qry_niin_local!master_ael_id & "') AND (niin='" & newdata & "'));"
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