Changing navigation bar group when accessed via vba

EDIT: Added some extra code to add other types of objects to the custom Nav group.

The following code will assign tables to your custom navigation group.

ATTENTION!! There is a "update" issue for the "MSysNavPaneObjectID" table that I am still trying to solve. If you create a new table and then try to add it to your group - sometimes it fires on the first try, sometimes it fails but will work after a delay (sometimes up to five or ten minutes!)

At this point, I got around the problem (when it failed) by reading information from the "MSysObjects" table and then adding a new entry to "MSysNavPaneObjectID".

The code below just creates five small tables and adds to the Nav Group 'Clients' tabs

Modify the code to use the group / 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 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 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