Help! i am having some trouble with my access codes on a database whereby it says that access error 3061 Too Few parameters expected 1. Problem highlighted was
Set oRS = CurrentDb.OpenRecordset(sSQL)
Dim i As Date, n As Integer, oRS As DAO.Recordset, sSQL As String
Dim db As DAO.Database
Set db = CurrentDb
Dim BookedDate As Date
Dim FacilitiesID As String
Dim StartTime As Date
cboTime.RowSourceType = "Value List"
cboTime.RowSource = ""
If IsNull(Start) Then Exit Sub Else i = Start
If Me.NewRecord = True Then
DoCmd.RunCommand acCmdSaveRecord
End If
sSQL = "SELECT FacilitiesID, StartTime, BookedDate"
sSQL = sSQL & " FROM qrysubform"
sSQL = sSQL & " WHERE FacilitiesID= " & Me.FacilitiesID & _
" AND BookedDate=# " & Me.txtDate & "#"
Set oRS = CurrentDb.OpenRecordset(sSQL)
Your Facilities ID is dimensioned as a string, though in your SQL statement it is referenced as a number. If your form's FacilitiesID is in fact a string, you need to enclose it in quotes:
sSQL = "SELECT FacilitiesID, StartTime, BookedDate"
sSQL = sSQL & " FROM qrysubform"
sSQL = sSQL & " WHERE FacilitiesID= '" & Me.FacilitiesID & _
"' AND BookedDate=#" & Me.txtDate & "#"
In such cases, insert a debug line and study the output:
Debug.Print sSQL
' Study output
Set oRS = CurrentDb.OpenRecordset(sSQL)
That said, this error is typically caused by a missing or misspelled field name.
Generating a Report from Query; capturing data from several tables. The Report has two calculated boxes and I want to UPDATE the data back to one of the tables. Debugging shows I'm capturing the variables but keeps giving me Syntax errors in the WHERE clause. I've tried lots of syntax iterations from scouring the net.
Private Sub Report_Load()
Dim sqls As String
Dim TEP As Single
Dim PPS As Single
Dim RecipeN As String
TEP = Reports![RecipeBuild]![txtTEP]
PPS = Reports![RecipeBuild]![txtPPS]
RecipeN = Reports![RecipeBuild]![RecipeName]
sqls = "Update [tblRecipeBuild] " _
& "Set TEP = " & TEP & " " _
& "Set PPS = " & PPS & " " _
& "WHERE [RecipeName] = '" & RecipeN & "';"
DoCmd.SetWarnings False
DoCmd.RunSQL sqls
DoCmd.SetWarnings True
End Sub
An Access SQL UPDATE should include the SET keyword only once.
When you want to update more than one field, use SET once, and then use a comma between the pairs of FieldName=Value segments.
sqls = "Update [tblRecipeBuild] " _
& "Set TEP = " & TEP & ", PPS = " & PPS & " " _
& "WHERE [RecipeName] = '" & RecipeN & "';"
I think that should work but suggest you consider a parameter query instead of concatenating values into an UPDATE statement.
Dim db As DAO.Database
Dim qdf As DAO.QueryDef
Dim strUpdate As String
strUpdate = "UPDATE tblRecipeBuild SET TEP=pTEP, PPS=pPPS WHERE RecipeName=pRecipeN;"
Debug.Print strUpdate
Set db = CurrentDb
Set qdf = db.CreateQueryDef(vbNullString, strUpdate)
With qdf
.Parameters("pTEP").Value = TEP
.Parameters("pPPS").Value = PPS
.Parameters("pRecipeN").Value = RecipeN
End With
qdf.Execute dbFailOnError
Error: "Run-time error '3061' Too few parameters. Expected 2.
I wrote this simple function that returns the remaining percentage calculated for number of records changed. It is supposed to occur when the user updates the field called 'percentage' I am certain the code below should work, but obviously something is wrong. It occurs on the line:
Set rs = db.OpenRecordset("SELECT Tier1, [Percentage], Tier3 AS Battalion, Month " _
& "FROM tbl_CustomPercent " _
& "WHERE (((Tier1)=[Forms]![frmEntry]![cmbImport_T1]) AND ((Month)=[Forms]![frmEntry]![cmbMonth]));", dbOpenSnapshot)
I wonder how it could fail when the very same query is what populates the 'record source' for the form with the 'percentage' textbox.
Function RemainingPercentAvailable() As String
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim strSQL As String
Set db = CurrentDb
Set rs = db.OpenRecordset("SELECT Tier1, [Percentage], Tier3 AS Battalion, Month " _
& "FROM tbl_CustomPercent " _
& "WHERE (((Tier1)=[Forms]![frmEntry]![cmbImport_T1]) AND ((Month)=[Forms]![frmEntry]![cmbMonth]));", dbOpenSnapshot)
Dim CurrentTotal As Single
CurrentTotal = 0
If Not (rs.EOF And rs.BOF) Then
rs.MoveFirst
Do Until rs.EOF = True
CurrentTotal = CurrentTotal + rs!Percentage
rs.MoveNext
Loop
End If
RemainingPercentAvailable = "Remaing available: " & Format(1 - CurrentTotal, "0.000%")
Set rs = Nothing
Set db = Nothing
End Function
Adapt your code to use the SELECT statement with a QueryDef, supply values for the parameters, and then open the recordset from the QueryDef.
Dim db As DAO.Database
Dim qdf As DAO.QueryDef
Dim rs As DAO.Recordset
Dim strSQL As String
strSQL = "SELECT Tier1, [Percentage], Tier3 AS Battalion, [Month] " _
& "FROM tbl_CustomPercent " _
& "WHERE (((Tier1)=[Forms]![frmEntry]![cmbImport_T1]) AND (([Month])=[Forms]![frmEntry]![cmbMonth]));"
Set db = CurrentDb
Set qdf = db.CreateQueryDef(vbNullString, strSQL )
' supply values for the 2 parameters ...
qdf.Parameters(0).Value = Eval(qdf.Parameters(0).Name)
qdf.Parameters(1).Value = Eval(qdf.Parameters(1).Name)
Set rs = qdf.OpenRecordset
Note: Month is a reserved word. Although that name apparently caused no problems before, I enclosed it in square brackets so the db engine can not confuse the field name with the Month function. It may be an unneeded precaution here, but it's difficult to predict exactly when reserved words will create problems. Actually, it's better to avoid them entirely if possible.
This one is calling a query directly in a DAO.Recordset and it works just fine.
Note the same 'Set rs = db.OpenRecordset(strSQL, dbOpenDynaset) This is a parameter SQL as well.
The only difference is with this one is that I DIDN'T need to move through and analyze the recordset - but the error occurs on the 'Set rs = " line, so I wasn't able to get further anyway.
Dim rs As DAO.Recordset
Dim db As DAO.Database
Dim strSQL As String
strSQL = "SELECT Sum(tbl_SP.AFP) AS AFP_TOTAL, tbl_SP.T1_UNIT " _
& "FROM tbl_SP " _
& "GROUP BY tbl_SP.T1_UNIT " _
& "HAVING (((tbl_SP.T1_UNIT)='" & strUnit & "'));"
Set db = CurrentDb
Set rs = db.OpenRecordset(strSQL, dbOpenDynaset)
AFP_Total = rs!AFP_Total
There is an even simpler way to calculate the total percentage.
Instead of looping through the records, you can use the DSum() function.
Note that DSum will return Null if there are no records, so you need to wrap it in Nz().
Just for fun, here is your function but written as one single statement:
Function RemainingPercentAvailable() As String
RemainingPercentAvailable = "Remaining available: " & Format(1 - _
Nz(DSum("Percentage", _
"tbl_CustomPercent", _
"Tier1 = " & QString(cmbImport_T1) & _
" AND [Month] = " & QString(cmbMonth))) _
, "0.000%")
End Function
I don't recommend building a temporary parameterized query in VBA, because it makes the code too complicated. And slower. I prefer to build "pure" SQL that will run directly in the db engine without any callbacks to Access. I'm assuming that your function is defined in the frmEntry form, and that cmbImport_T1 and cmbMonth are string fields. If they are numeric, omit qString().
Here is my version of your function. It handles the empty-recordset case correctly.
Function RemainingPercentAvailable() As String
Dim CurrentTotal As Double, q As String
q = "SELECT Percentage" & _
" FROM tbl_CustomPercent" & _
" WHERE Tier1 = " & QString(cmbImport_T1) & _
" AND [Month] = " & QString(cmbMonth)
CurrentTotal = 0
With CurrentDb.OpenRecordset(q)
While Not .EOF
CurrentTotal = CurrentTotal + .Fields("Percentage")
.MoveNext
Wend
End With
RemainingPercentAvailable = "Remaining available: " & _
Format(1 - CurrentTotal, "0.000%")
End Function
' Return string S quoted, with quotes escaped, for building SQL.
Public Function QString(ByVal S As String) As String
QString = "'" & Replace(S, "'", "''") & "'"
End Function
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