Change Navigation pane group in access through vba

Question

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 navi

Answer 1

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