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

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

Answer 2

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

Answer 3

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