通过vba更改访问中的导航窗格组 [英] Change Navigation pane group in access through vba

问题描述

我具有访问权限的VBA代码模块，该模块创建4个新表并将它们添加到数据库中。我想在末尾添加一个部分，它们通过自定义组在导航窗格中进行组织，从而将它们全部组织起来。

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?

编辑：

我不希望表格位于表格中吗？未分配的对象组。我想通过VBA更改该组的名称。

I don't want the tables to be in the unassigned objects group. I want to change the name of that group through VBA.

推荐答案

编辑：添加了更多代码，以将其他对象类型添加到自定义Nav组。

Added more code to add other object types to the custom Nav group.

以下代码将分配表到您的自定义导航组。

The following code will assign tables to your custom Navigation Group.

警告！我仍在尝试解决表格 MSysNavPaneObjectIDs的刷新问题。如果您创建一个新表然后尝试将其添加到您的组中-有时它会在第一次尝试时起作用，有时它会失败，但会在延迟（有时长达五到十分钟！）后起作用。

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!)

此刻，我通过从表'MSysObjects'中读取信息，然后向'MSysNavPaneObjectIDs'中添加新记录来解决该问题（当失败时）。

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

这篇关于通过vba更改访问中的导航窗格组的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！