I'm passing record set from one function (i.e.chkMismatchData) to another (CheckMismatches) and if the record is not found I update some values of passed recordset.
Even I declare variable of recordset in module level still finding the error.
My code is :
Set rec1 = CurrentDb.OpenRecordset("select * from CBWCFAVENDORMATCHOFFMASTER where [vendor]='" & rec![Vendor] & "'")
While Not rec.EOF
Set rec3 = CurrentDb.OpenRecordset("select ID,[HCI_NO],CLEARLOC,SUM([AMOUNT])AS AMOUNT1 from CBWCFAMISUPLOAD WHERE [vendor]='" & rec![Vendor] & "' and nz([match],'')='' and nz([HCI_NO],'')<>'' GROUP BY HCI_NO,CLEARLOC,ID ")
While Not rec3.EOF
Set rec2 = CurrentDb.OpenRecordset("select ID,DEPSLIPNO,CLEARLOC from CBWCFAPENDINGPAYMENTDATA WHERE [DEPSLIPNO]='" & rec3![HCI_NO] & "' GROUP BY DEPSLIPNO,CLEARLOC,ID HAVING CLEARLOC='" & rec3![CLEARLOC] & "' AND SUM([amt])=" & rec3![AMOUNT1])
If rec2.EOF = False Then
If rec2.RecordCount = 1 Then
CurrentDb.Execute ("UPDATE CBWCFAMISUPLOAD SET [MATCH]='Y' ,[CASHIN_ID]='" & rec2![ID] & "' WHERE [HCI_NO]='" & rec3![HCI_NO] & "' ")
CurrentDb.Execute ("UPDATE CBWCFAPENDINGPAYMENTDATA SET [MATCH]='Y' ,[MIS_ID]='" & rec3![ID] & "' WHERE [DEPSLIPNO]='" & rec3![HCI_NO] & "'")
ElseIf rec1.RecordCount > 1 Then
Call UpdateRec(rec3, 0, "Duplicate Match", 0)
End If
Else
strSlipType = "HCI_NO"
Call UpdateRec(rec3, 0, CheckMismatches(rec3), 0) 'here im passing
End If
rec3.MoveNext
Wend
Wend
Private Function CheckMismatches(rec As DAO.Recordset) As String
Dim RecCheck As DAO.Recordset
Dim strDepSlipNo As String, strID As String
If strSlipType = "HCI_NO" Then
'--Clearing Loc Not Matching
Set RecCheck = CurrentDb.OpenRecordset("select ID,DEPSLIPNO,CLEARLOC from CBWCFAPENDINGPAYMENTDATA WHERE [DEPSLIPNO]='" & rec![HCI_NO] & "' GROUP BY DEPSLIPNO,CLEARLOC,ID HAVING CLEARLOC<>'" & rec![CLEARLOC] & "' AND SUM([amt])=" & rec![AMOUNT1])
If RecCheck.EOF = True Then
rec.Edit 'here i'm geting error
rec![match]="Y" 'added line
rec!.update 'added line
CheckMismatches = "Clearing Loc Not Matching"
RecCheck.Close
Exit Function
End If
RecCheck.Close
end function
Your rec3 has a GROUP BY clause.
A recordset that is aggregated is by definition read-only. So you have to edit the table separately from this recordset.
Why do you have rec.Edit in the function when you don't edit any fields of it?
Please help below code is not generating the mail and hangs access application:
Where is issue as when I dont do dQuery Processing Email Generates properly but dont include subform records aswell.
Without Subform Details Mail is something like this Email Generated with Proper variables present on MainForm
Private Sub InformCustomer_Click()
On Error GoTo Err_InformCustomer_Click
Dim CustName As String ' Customer Name
Dim varTo As Variant '-- Address for SendObject
Dim stText As String '-- E-mail text
Dim DelDate As Variant '-- Rec date for e-mail text
Dim stSubject As String '-- Subject line of e-mail
Dim stOrderID As String '-- The Order ID from form
Dim strSQL As String '-- Create SQL update statement
Dim errLoop As Error
Dim dQuery As String
Dim MyDb As DAO.Database
Dim rs As DAO.Recordset
stOrderID = Me![OdrID]
strSQL = "SELECT BrandName, ModelName, Status " _
& " FROM OrderProdDetails " _
& " WHERE (OrdID)=" & stOrderID & ";"
Set MyDb = CurrentDb
Set rs = CurrentDb.OpenRecordset(strSQL, dbOpenDynaset)
While Not rs.EOF
dQuery = dQuery & rs![BrandName].Value & vbTab & rs![ModelName].Value & rs![Status].Value & vbCrLf
Wend
Set rs = Nothing
CustName = Me![CustName]
varTo = Me![CustEmail]
stSubject = ":: Update - Oder Status ::"
stOrderID = Me![OdrID]
DelDate = Me![OdrDeliveryDate]
stText = "Dear" & CustName & Chr$(13) & _
"You have been assigned a new ticket." & Chr$(13) & Chr$(13) & _
"Order Number: " & stOrderID & Chr$(13) & _
_
"Please refer to your order status " & Chr$(13) & _
"Exp Delevery Date: " & DelDate & Chr$(13) & Chr$(13) & _
dQuery & Chr$(13) & _
"This is an automated message. Please do not respond to this e-mail."
'Write the e-mail content for sending to assignee
DoCmd.SendObject , , acFormatTXT, varTo, , , stSubject, stText, True
MsgBox "Done"
Exit Sub
Err_InformCustomer_Click:
MsgBox Err.Description
End Sub
You have created an endless loop.
While Not rs.EOF
dQuery = dQuery & rs![BrandName].Value & vbTab & rs![ModelName].Value & rs![Status].Value & vbCrLf
' This is missing -->
rs.MoveNext
Wend
I am currently working on a form to update fields in my database. The button (cmdFind) is meant to find the record for the part # (entered into text box txtFindPart), and then populate the data into In1-52 and out1-52. When I run it I get Run-time Error 2465 Microsoft Access can not find the field '|1' referred to in your expression.
Private Sub cmdFind_Click()
Dim i As Integer
i = 1
If IsNull(txtFindPart) = False Then
If Me.Recordset.NoMatch Then
MsgBox "No record found", vbOKOnly + vbInformation, "Sorry"
Me!txtFindPart = Null
End If
Do Until i = 53
Me.Controls("in" & i) = DLookup("[In-Week " & i & "]", [Parts], "(([Parts].[Part #]) = '" & txtFindPart & "')")
Me.Controls("out" & i) = DLookup("[Out-Week " & i & "]", [Parts], "(([Parts].[Part #]) = '" & txtFindPart & "')")
i = i + 1
Loop
End If
End Sub
Any help would be greatly appreciated.
I figured it out the problem was that the table Parts Was not open and it was causing the error. I just had to add a line to open the table and at the end close it.
DoCmd.OpenTable "Parts"
Dim i As Integer
i = 1
If IsNull(txtFindPart) = False Then
If Me.Recordset.NoMatch Then
MsgBox "No record found", vbOKOnly + vbInformation, "Sorry"
Me!txtFindPart = Null
End If
Do Until i = 53
Me.Controls("in" & i) = DLookup("[In-Week " & i & "]", "[Parts]", "(([Parts].[Part #]) = '" & txtFindPart & "')")
Me.Controls("out" & i) = DLookup("[Out-Week " & i & "]", "[Parts]", "(([Parts].[Part #]) = '" & txtFindPart & "')")
i = i + 1
Loop
End If
DoCmd.Close , "Parts"
I have a module of VBA code in access that creates 4 new tables and adds them to the database. I would like to add in a part at the end where they are organized in the navigation pane through custom groups so that way they are all organized. Would this be possible through vba?
EDIT:
I don't want the tables to be in the unassigned objects group. I want to change the name of that group through VBA.
EDIT: Added more code to add other object types to the custom Nav group.
The following code will assign tables to your custom Navigation Group.
WARNING!! There is a 'refresh' issue of table 'MSysNavPaneObjectIDs' that I am still trying to resolve. If you create a new table and then try to add to your group - sometimes it works on the first try, other times it fails but will work after a delay (sometimes up to five or ten minutes!)
At this moment, I got around the issue (when it fails) by reading info from table 'MSysObjects', then adding a new record to 'MSysNavPaneObjectIDs'.
The code below simply creates five small tables and adds to Nav Group 'Clients'
Modify the code to use your Group name / table names.
Option Compare Database
Option Explicit
Sub Test_My_Code()
Dim dbs As DAO.Database
Dim strResult As String
Dim i As Integer
Dim strSQL As String
Dim strTableName As String
Set dbs = CurrentDb
For i = 1 To 5
strTableName = "Query" & i
'>>> CHANGE FOLLOWING LINE TO YOUR CUSTOM NAME
' Pass the Nav Group, Object Name, Object Type
strResult = SetNavGroup("Clients", strTableName, "Query")
Debug.Print strResult
Next i
For i = 1 To 5
strTableName = "0000" & i
strSQL = "CREATE TABLE " & strTableName & " (PayEmpID INT, PayDate Date);"
dbs.Execute strSQL
'>>> CHANGE FOLLOWING LINE TO YOUR CUSTOM NAME
' Pass the Nav Group, Object Name, Object Type
strResult = SetNavGroup("Clients", strTableName, "Table")
Debug.Print strResult
Next i
dbs.Close
Set dbs = Nothing
End Sub
Function SetNavGroup(strGroup As String, strTable As String, strType As String) As String
Dim strSQL As String
Dim dbs As DAO.Database
Dim rs As DAO.recordSet
Dim lCatID As Long
Dim lGrpID As Long
Dim lObjID As Long
Dim lType As Long
SetNavGroup = "Failed"
Set dbs = CurrentDb
' Ignore the following code unless you want to manage 'Categories'
' Table MSysNavPaneGroupCategories has fields: Filter, Flags, Id (AutoNumber), Name, Position, SelectedObjectID, Type
' strSQL = "SELECT Id, Name, Position, Type " & _
' "FROM MSysNavPaneGroupCategories " & _
' "WHERE (((MSysNavPaneGroupCategories.Name)='" & strGroup & "'));"
' Set rs = dbs.OpenRecordset(strSQL)
' If rs.EOF Then
' MsgBox "No group named '" & strGroup & "' found. Will quit now.", vbOKOnly, "No Group Found"
' rs.Close
' Set rs = Nothing
' dbs.Close
' Set dbs = Nothing
' Exit Function
' End If
' lCatID = rs!ID
' rs.Close
' When you create a new table, it's name is added to table 'MSysNavPaneObjectIDs'
' Types
' Type TypeDesc
'-32768 Form
'-32766 Macro
'-32764 Reports
'-32761 Module
'-32758 Users
'-32757 Database Document
'-32756 Data Access Pages
'1 Table - Local Access Tables
'2 Access object - Database
'3 Access object - Containers
'4 Table - Linked ODBC Tables
'5 Queries
'6 Table - Linked Access Tables
'8 SubDataSheets
If LCase(strType) = "table" Then
lType = 1
ElseIf LCase(strType) = "query" Then
lType = 5
ElseIf LCase(strType) = "form" Then
lType = -32768
ElseIf LCase(strType) = "report" Then
lType = -32764
ElseIf LCase(strType) = "module" Then
lType = -32761
ElseIf LCase(strType) = "macro" Then
lType = -32766
Else
MsgBox "Add your own code to handle the object type of '" & strType & "'", vbOKOnly, "Add Code"
dbs.Close
Set dbs = Nothing
Exit Function
End If
' Table MSysNavPaneGroups has fields: Flags, GroupCategoryID, Id, Name, Object, Type, Group, ObjectID, Position
Debug.Print "---------------------------------------"
Debug.Print "Add '" & strType & "' " & strTable & "' to Group '" & strGroup & "'"
strSQL = "SELECT GroupCategoryID, Id, Name " & _
"FROM MSysNavPaneGroups " & _
"WHERE (((MSysNavPaneGroups.Name)='" & strGroup & "') AND ((MSysNavPaneGroups.Name) Not Like 'Unassigned*'));"
Set rs = dbs.OpenRecordset(strSQL)
If rs.EOF Then
MsgBox "No group named '" & strGroup & "' found. Will quit now.", vbOKOnly, "No Group Found"
rs.Close
Set rs = Nothing
dbs.Close
Set dbs = Nothing
Exit Function
End If
Debug.Print rs!GroupCategoryID & vbTab & rs!ID & vbTab & rs!Name
lGrpID = rs!ID
rs.Close
Try_Again:
' Filter By Type
strSQL = "SELECT Id, Name, Type " & _
"FROM MSysNavPaneObjectIDs " & _
"WHERE (((MSysNavPaneObjectIDs.Name)='" & strTable & "') AND ((MSysNavPaneObjectIDs.Type)=" & lType & "));"
Set rs = dbs.OpenRecordset(strSQL)
If rs.EOF Then
' Seems to be a refresh issue / delay! I have found no way to force a refresh.
' This table gets rebuilt at the whim of Access, so let's try a different approach....
' Lets add the record vis code.
Debug.Print "Table not found in MSysNavPaneObjectIDs, try MSysObjects."
strSQL = "SELECT * " & _
"FROM MSysObjects " & _
"WHERE (((MSysObjects.Name)='" & strTable & "') AND ((MSysObjects.Type)=" & lType & "));"
Set rs = dbs.OpenRecordset(strSQL)
If rs.EOF Then
MsgBox "This is crazy! Table '" & strTable & "' not found in MSysObjects.", vbOKOnly, "No Table Found"
rs.Close
Set rs = Nothing
dbs.Close
Set dbs = Nothing
Exit Function
Else
Debug.Print "Table not found in MSysNavPaneObjectIDs, but was found in MSysObjects. Lets try to add via code."
strSQL = "INSERT INTO MSysNavPaneObjectIDs ( ID, Name, Type ) VALUES ( " & rs!ID & ", '" & strTable & "', " & lType & ")"
dbs.Execute strSQL
GoTo Try_Again
End If
End If
Debug.Print rs!ID & vbTab & rs!Name & vbTab & rs!type
lObjID = rs!ID
rs.Close
' Add the table to the Custom group
strSQL = "INSERT INTO MSysNavPaneGroupToObjects ( GroupID, ObjectID, Name ) VALUES ( " & lGrpID & ", " & lObjID & ", '" & strTable & "' )"
dbs.Execute strSQL
dbs.Close
Set dbs = Nothing
SetNavGroup = "Passed"
End Function
Thanks a lot for your code,
I had to modify it a little on my specific case due to the issue on the refresh of the table.
In fact I am recreating a table (deleting the old one before). As the MSysNavPaneObjectIDs does not refresh, the old ID is kept inside.
e.g. let's use a table tmpFoo that I want to put in a group TEMP.
tmpFoo is already in group TEMP. TEMP has ID 1 and tmpFoo has ID 1000
Then I delete tmpFoo, and immediately recreate tmpFoo.
tmpFoo is now in 'Unassigned Objects'.
In MSysObjects, ID of tmpFoo is now 1100, but in MSysNavPaneObjectIDs the table is not refreshed and the ID of tmpFoo here is still 1000.
In this case, in the table MSysNavPaneGroupToObjects a link between TEMP(1) and tmpFoo(1000) is created => Nothing happen as ID 1000 does not exists anymore in MSysObjects.
So, the modified code below get in all cases ID from MSysObjects, then check if the ID exists in MSysNavPaneObjectIDs.
If not, add the line, then use the same ID to add it to MSysNavPaneGroupToObjects.
In this way seems I do not have any refresh issue (adding Application.RefreshDatabaseWindow in the upper function).
Thanks again Wayne,
Function SetNavGroup(strGroup As String, strTable As String, strType As String) As String
Dim strSQL As String
Dim dbs As DAO.Database
Dim rs As DAO.Recordset
Dim lCatID As Long
Dim lGrpID As Long
Dim lObjID As Long
Dim lType As Long
SetNavGroup = "Failed"
Set dbs = CurrentDb
' When you create a new table, it's name is added to table 'MSysNavPaneObjectIDs'
' Types
' Type TypeDesc
'-32768 Form
'-32766 Macro
'-32764 Reports
'-32761 Module
'-32758 Users
'-32757 Database Document
'-32756 Data Access Pages
'1 Table - Local Access Tables
'2 Access object - Database
'3 Access object - Containers
'4 Table - Linked ODBC Tables
'5 Queries
'6 Table - Linked Access Tables
'8 SubDataSheets
If LCase(strType) = "table" Then
lType = 1
ElseIf LCase(strType) = "query" Then
lType = 5
ElseIf LCase(strType) = "form" Then
lType = -32768
ElseIf LCase(strType) = "report" Then
lType = -32764
ElseIf LCase(strType) = "module" Then
lType = -32761
ElseIf LCase(strType) = "macro" Then
lType = -32766
Else
MsgBox "Add your own code to handle the object type of '" & strType & "'", vbOKOnly, "Add Code"
dbs.Close
Set dbs = Nothing
Exit Function
End If
' Table MSysNavPaneGroups has fields: Flags, GroupCategoryID, Id, Name, Object, Type, Group, ObjectID, Position
Debug.Print "---------------------------------------"
Debug.Print "Add '" & strType & "' '" & strTable & "' to Group '" & strGroup & "'"
strSQL = "SELECT GroupCategoryID, Id, Name " & _
"FROM MSysNavPaneGroups " & _
"WHERE (((MSysNavPaneGroups.Name)='" & strGroup & "') AND ((MSysNavPaneGroups.Name) Not Like 'Unassigned*'));"
Set rs = dbs.OpenRecordset(strSQL)
If rs.EOF Then
MsgBox "No group named '" & strGroup & "' found. Will quit now.", vbOKOnly, "No Group Found"
rs.Close
Set rs = Nothing
dbs.Close
Set dbs = Nothing
Exit Function
End If
Debug.Print rs!GroupCategoryID & vbTab & rs!ID & vbTab & rs!Name
lGrpID = rs!ID
rs.Close
' Get Table ID From MSysObjects
strSQL = "SELECT * " & _
"FROM MSysObjects " & _
"WHERE (((MSysObjects.Name)='" & strTable & "') AND ((MSysObjects.Type)=" & lType & "));"
Set rs = dbs.OpenRecordset(strSQL)
If rs.EOF Then
MsgBox "This is crazy! Table '" & strTable & "' not found in MSysObjects.", vbOKOnly, "No Table Found"
rs.Close
Set rs = Nothing
dbs.Close
Set dbs = Nothing
Exit Function
End If
lObjID = rs!ID
Debug.Print "Table found in MSysObjects " & lObjID & " . Lets compare to MSysNavPaneObjectIDs."
' Filter By Type
strSQL = "SELECT Id, Name, Type " & _
"FROM MSysNavPaneObjectIDs " & _
"WHERE (((MSysNavPaneObjectIDs.ID)=" & lObjID & ") AND ((MSysNavPaneObjectIDs.Type)=" & lType & "));"
Set rs = dbs.OpenRecordset(strSQL)
If rs.EOF Then
' Seems to be a refresh issue / delay! I have found no way to force a refresh.
' This table gets rebuilt at the whim of Access, so let's try a different approach....
' Lets add the record via this code.
Debug.Print "Table not found in MSysNavPaneObjectIDs, add it from MSysObjects."
strSQL = "INSERT INTO MSysNavPaneObjectIDs ( ID, Name, Type ) VALUES ( " & lObjID & ", '" & strTable & "', " & lType & ")"
dbs.Execute strSQL
End If
Debug.Print lObjID & vbTab & strTable & vbTab & lType
rs.Close
' Add the table to the Custom group
strSQL = "INSERT INTO MSysNavPaneGroupToObjects ( GroupID, ObjectID, Name ) VALUES ( " & lGrpID & ", " & lObjID & ", '" & strTable & "' )"
dbs.Execute strSQL
dbs.Close
Set dbs = Nothing
SetNavGroup = "Passed"
End Function
Here's my code it's not as user-error friendly as the main code, but it should be a bit quicker to make a mass move.
Public Sub Test_My_Code()
Dim i As Long, db As Database, qd As QueryDef
Set db = CurrentDb
For i = 1 To 10
DoCmd.RunSQL "CREATE TABLE [~~Table:" & Format(i, "00000") & "](PayEmpID INT, PayDate Date)"
Set qd = db.CreateQueryDef("~~Query:" & Format(i, "00000"), "SELECT * FROM [~~Table:" & Format(i, "00000") & "];")
Next i
MsgBox IIf(SetNavGroup(CategorySelection:="Like '*'", GroupSelection:="='TestGroup'", ObjectSelection:="Like '~~Table:#####'"), "New Tables Moved", "Table Move Failed")
MsgBox IIf(SetNavGroup(CategorySelection:="Like '*'", GroupSelection:="='TestGroup'", ObjectSelection:="Like '~~Query:#####'"), "New Queries Moved", "Query Move Failed")
End Sub
Private Sub SetNavGroup_tst(): MsgBox IIf(SetNavGroup(GroupSelection:="='Verified Formularies'", ObjectSelection:="Like '*Verified*'"), "Tables Moved OK", "Failed"): End Sub
'Parameters:
' CategorySelection -- used to filter which custom(type=4) categories to modify
' ex select the 'Custom' Navigation Category (default): "='Custom'"
' GroupSelection -- used to filter which custom(type=-1) groups to add the objects to
' ex select a specific group: "='Verified Formularies'"
' ex select set of specific groups: "In ('Group Name1','Group Name2')"
' ObjectSelection -- used to filter which database objects to move under the groups
' ex select a range of tables: "Like '*Verified*'"
' UnassignedOnly -- used to only look at objects from the Unassigned group
' True - set only unassigned objects
' False - add objects even if they're already in a group
Public Function SetNavGroup(GroupSelection As String, ObjectSelection As String, Optional CategorySelection As String = "='Custom'", Optional UnassignedOnly As Boolean = True) As Boolean
SetNavGroup = False
If Trim(GroupSelection) = "" Then Exit Function
If Trim(ObjectSelection) = "" Then Exit Function
DoCmd.SetWarnings False
On Error GoTo SilentlyContinue
'TempTable Name
Dim ToMove As String
Randomize: ToMove = "~~ToMove_TMP" & (Fix(100000 * Rnd) Mod 100)
'Build temporary table of what to move
Dim SQL As String: SQL = _
"SELECT [Ghost:ToMove].* INTO [" & ToMove & "] " & _
"FROM ( " & _
"SELECT MSysNavPaneGroups.GroupCategoryID, MSysNavPaneGroupCategories.Name AS CategoryName, MSysNavPaneGroups.Id AS GroupID, MSysNavPaneGroups.Name AS GroupName, MSysObjects.Id AS ObjectID, MSysObjects.Name AS ObjectName, MSysObjects.Type AS ObjectType, '' AS ObjectAlias " & _
"FROM MSysObjects, MSysNavPaneGroupCategories INNER JOIN MSysNavPaneGroups ON MSysNavPaneGroupCategories.Id = MSysNavPaneGroups.GroupCategoryID " & _
"WHERE (((MSysNavPaneGroupCategories.Name) " & CategorySelection & ") AND ((MSysNavPaneGroups.Name) " & GroupSelection & ") AND MSysObjects.Name " & ObjectSelection & " AND ((MSysNavPaneGroupCategories.Type)=4) AND ((MSysNavPaneGroups.[Object Type Group])=-1)) " & _
"GROUP BY MSysNavPaneGroups.GroupCategoryID, MSysNavPaneGroupCategories.Name, MSysNavPaneGroups.Id, MSysNavPaneGroups.Name, MSysObjects.Id, MSysObjects.Name, MSysObjects.Type " & _
"ORDER BY Min(MSysNavPaneGroupCategories.Position), Min(MSysNavPaneGroups.Position)" & _
") AS [Ghost:ToMove] LEFT JOIN ( " & _
"SELECT MSysNavPaneGroups.GroupCategoryID, MSysNavPaneGroupToObjects.GroupID, MSysNavPaneGroupToObjects.ObjectID " & _
"FROM MSysNavPaneGroups INNER JOIN MSysNavPaneGroupToObjects ON MSysNavPaneGroups.Id = MSysNavPaneGroupToObjects.GroupID " & _
") AS [Ghost:AssignedObjects] ON ([Ghost:ToMove].ObjectID = [Ghost:AssignedObjects].ObjectID) AND ([Ghost:ToMove].GroupID = [Ghost:AssignedObjects].GroupID) AND ([Ghost:ToMove].GroupCategoryID = [Ghost:AssignedObjects].GroupCategoryID) " & _
"WHERE [Ghost:AssignedObjects].GroupCategoryID Is Null;"
If Not UnassignedOnly Then SQL = _
"SELECT MSysNavPaneGroups.GroupCategoryID, MSysNavPaneGroupCategories.Name AS CategoryName, MSysNavPaneGroups.Id AS GroupID, MSysNavPaneGroups.Name AS GroupName, MSysObjects.Id AS ObjectID, MSysObjects.Name AS ObjectName, MSysObjects.Type AS ObjectType, '' AS ObjectAlias " & _
"INTO [" & ToMove & "] " & _
"FROM MSysObjects, MSysNavPaneGroupCategories INNER JOIN MSysNavPaneGroups ON MSysNavPaneGroupCategories.Id = MSysNavPaneGroups.GroupCategoryID " & _
"WHERE (((MSysNavPaneGroupCategories.Name) " & CategorySelection & ") AND ((MSysNavPaneGroups.Name) " & GroupSelection & ") AND MSysObjects.Name " & ObjectSelection & " AND ((MSysNavPaneGroupCategories.Type)=4) AND ((MSysNavPaneGroups.[Object Type Group])=-1)) " & _
"GROUP BY MSysNavPaneGroups.GroupCategoryID, MSysNavPaneGroupCategories.Name, MSysNavPaneGroups.Id, MSysNavPaneGroups.Name, MSysObjects.Id, MSysObjects.Name, MSysObjects.Type " & _
"ORDER BY Min(MSysNavPaneGroupCategories.Position), Min(MSysNavPaneGroups.Position);"
DoCmd.RunSQL SQL
If DCount("*", "[" & ToMove & "]") = 0 Then Err.Raise 63 'Nothing to move
'Add the objects to their groups
DoCmd.RunSQL _
"INSERT INTO MSysNavPaneGroupToObjects ( GroupID, Name, ObjectID ) " & _
"SELECT TM.GroupID, TM.ObjectAlias, TM.ObjectID " & _
"FROM [" & ToMove & "] AS TM LEFT JOIN MSysNavPaneGroupToObjects ON (TM.ObjectID = MSysNavPaneGroupToObjects.ObjectID) AND (TM.GroupID = MSysNavPaneGroupToObjects.GroupID) " & _
"WHERE MSysNavPaneGroupToObjects.GroupID Is Null;"
'Add any missing NavPaneObjectIDs
DoCmd.RunSQL _
"INSERT INTO MSysNavPaneObjectIDs ( Id, Name, Type ) " & _
"SELECT DISTINCT TM.ObjectID, TM.ObjectName, TM.ObjectType " & _
"FROM [" & ToMove & "] AS TM LEFT JOIN MSysNavPaneObjectIDs ON TM.ObjectID = MSysNavPaneObjectIDs.Id " & _
"WHERE (((MSysNavPaneObjectIDs.Id) Is Null));"
SetNavGroup = True
EOFn:
On Error Resume Next
DoCmd.DeleteObject acTable, ToMove
On Error GoTo 0
DoCmd.SetWarnings True
Exit Function
SilentlyContinue: Resume EOFn
End Function
I have a database with linked tables- Staff, Courses and Training_Record. Each staff member has a numeric primary key, as does each course and each entry in the Training_Record table. The Staff_ID and Course_ID in the Training_Record reference records in Staff and Courses.
When a staff member or course is added, the Training_Record (fields: Staff_ID, Course_ID, Date_Taken, Notes) has staff,course records inserted- so adding staff member 1 would insert records (1,1,,,), (1,2,,,) etc, adding course 8 would insert records (1,8,,,), (2,8,,,) and so on. This works.
I then have a form to record training. The user selects the course, enters the date and selects staff members from a listbox. I have a save button which triggers VBA code. The date and course are pulled from the boxes and I loop round the listbox, concatenating selected staff members into a string. This all works and a message box displays, verifying that. Then, an update SQL query should be run, updating the Training_Record.
The problem I have is with the SQL update. I have an update query that will work in the SQL query editor, though it uses written in variables:
UPDATE Training_Record
SET Date_Taken = '12/12/12'
WHERE Staff_ID IN (1,2,3,4,5) AND Course_ID = 4
This updates the Training_Record to show that staff 1,2,3,4 and 5 took course 4 on 12/12/12. However, in VBA this will not work. This is my SQL query in VBA:
strSQL = "UPDATE Training_Record" _
& "SET Date_Taken = (" & strDate & ")" _
& "WHERE Staff_ID IN (" & strCriteria & ") AND Course_ID = (" & strCourse & ")"
DoCmd.RunSQL strSQL
The error that the code generates is "Run-time error '3144': Syntax error in UPDATE statement." and the debugger highlights the DoCmd.RunSQL statement following the query.The entire VBA code:
Private Sub SaveTraining_Click()
Dim db As DAO.Database
Dim VarItem As Variant
Dim strCriteria As String
Dim strDate As Variant
Dim strCourse As Variant
Dim strSQL As String
Set db = CurrentDb()
'Extract the course ID and the training date from the form
strCourse = Me!CourseID.Value
strDate = Me!TrainingDate.Value
'Dealing with empty boxes- zero length
If IsNull(strCourse) Then
MsgBox "Please select a course." _
, vbOKOnly, "No course selected"
End If
If IsNull(strDate) Then
MsgBox "Please enter a date." _
, vbOKOnly, "No date given"
End If
If StaffMembers.ItemsSelected.Count = 0 Then
MsgBox "Please select staff members." _
, vbOKOnly, "No staff members"
End If
If (Not IsNull(strCourse)) And (Not IsNull(strDate)) And (StaffMembers.ItemsSelected.Count > 0) Then
'Extract each selected member and concatenate into a string for sql query
For Each VarItem In Me!StaffMembers.ItemsSelected
strCriteria = strCriteria & "," & Me!StaffMembers.ItemData(VarItem)
Next VarItem
'Gets rid of extra comma on query string
strCriteria = Right(strCriteria, Len(strCriteria) - 1)
'Message box
MsgBox ("Staff: " & strCriteria & vbNewLine & "Date: " & strDate & vbNewLine & "Course: " & strCourse & vbNewLine & "No. Selected staff: " & StaffMembers.ItemsSelected.Count)
strSQL = "UPDATE Training_Record" _
& "SET Date_Taken = (" & strDate & ")" _
& "WHERE Staff_ID IN (" & strCriteria & ") AND Course_ID = (" & strCourse & ")"
DoCmd.RunSQL strSQL
End If
Set db = Nothing
End Sub
TL;DR I can't make a SQL UPDATE query run in VBA
I've got a feeling that it's an error in syntax somewhere, but I can't find where. Any ideas/advice would be much appreciated, thanks.
I think you are simply missing spaces at the end of the lines
You old query print out
UPDATE Training_RecordSET Date_Taken = ()WHERE Staff_ID IN () AND Course_ID = ()
as you can see there will be a name collision before keywords SET and WHERE
therefore change your strSQL to
strSQL = "UPDATE Training_Record " _
& "SET Date_Taken = (" & strDate & ") " _
& "WHERE Staff_ID IN (" & strCriteria & ") AND Course_ID = (" & strCourse & ")"
which prints out as (with no values provided)
UPDATE Training_Record SET Date_Taken = () WHERE Staff_ID IN () AND Course_ID = ()
which in terms of SQL syntax is correct
If I were you I would also check the data types of columns in your Training_Record table
Usually (and this applies to Type-mismatch error),
for dates you wrap the variable or value on both sides with #
example & "SET Date_Taken = (#" & strDate & "#) ...
for strings you use single quotes '
example WHERE Operator_Name = ('" & operName & "') ...
for numerical values you do not need to use anything but casting to provide the correct data type
My guess:
strSQL = "UPDATE Training_Record" _
& "SET Date_Taken = (#" & Format(strDate, "mm\/dd\/yyyy") & "#)" _
& "WHERE Staff_ID IN (" & strCriteria & ") AND Course_ID = (" & strCourse & ")"
If staff_ID is a string:
strSQL = "UPDATE Training_Record" _
& "SET Date_Taken = (#" & Format(strDate, "mm\/dd\/yyyy") & "#)" _
& "WHERE Staff_ID IN ('" & strCriteria & "') AND Course_ID = (" & strCourse & ")"