[原创]用VBA加载自定义菜单

duomu

错误之处,还请各位指正

Public Function Create_Menus(ByVal strTable As String, _
                             ByVal strParentMenuID As String, _
                             ByVal strMenuID As String, _
                             ByVal strMenuName As String, _
                             ByVal strMenuType As String)
'===============================================================================
'-函数名称:     Create_Menus
'-功能描述:     加载Office Menu，使用时需要调用Create_ChildMenu子函数
'-输入参数说明: 参数1: 必选 strTable As String  菜单数据来源的表名
'               参数2: 必选 strParentMenuID As String  父菜单字段名
'               参数3: 必选 strMenuID As String  菜单ID字段名
'               参数4: 必选 strMenuName As String  菜单名称字段名
'               参数5: 必选 strMenuType As String  菜单类型字段名
'               参数6: 可选 strConn As String  菜单类型字段名
'-返回参数说明:
'-使用语法示例: Call Create_Menus("tab菜单", "ParentMenuID", "MenuID", "MenuName", "Menutype")
'-参考:
'-使用注意:     strTable为数据表名称
'
'-兼容性:       2000,XP,2003 compatible
'-作者:         duomu
'-更新日期：    2007-09-10
'===============================================================================
    Dim Bar As Office.CommandBar
    Dim conn As New ADODB.Connection
    Dim rst As New ADODB.Recordset
    Dim strSQL As String
    On Error GoTo Err_Create_Menus
    '设置conn连接对象为当前打开的连接
    Set conn = CurrentProject.Connection

    '设置查询语句
    strSQL = "SELECT * FROM [" & strTable
    strSQL = strSQL & "] WHERE [" & strParentMenuID & "] = '0';"
    '设置记录集对象的内容，通过Open方法建立只读一个记录集
    rst.Open strSQL, conn, adOpenStatic, adLockReadOnly
    Do While Not rst.EOF()
        '检测是否菜单是否存在
        On Error Resume Next
        Application.CommandBars(CStr(rst(strMenuName))).Delete
        On Error GoTo 0
        '创建菜单
        If rst.Fields(strMenuType) = "msoBarPopup" Then
            Set Bar = Application.CommandBars.Add(Name:=rst(strMenuName), Position:=StrToConst(rst(strMenuType)), MenuBar:=False, Temporary:=True)
            '调用子函数，加入子菜单
            Call Create_ChildMenu(strTable, strParentMenuID, strMenuID, strMenuName, strMenuType, Bar, rst.Fields(strMenuID))
            Bar.ShowPopup
        Else
            Set Bar = Application.CommandBars.Add(Name:=rst(strMenuName), Position:=StrToConst(rst(strMenuType)), MenuBar:=True, Temporary:=True)
            '调用子函数，加入子菜单
            Call Create_ChildMenu(strTable, strParentMenuID, strMenuID, strMenuName, strMenuType, Bar, rst.Fields(strMenuID))
            Bar.Visible = True
        End If
        '移动指针到下一条记录
        rst.MoveNext
    Loop
    '创建完菜单后,关闭或销毁对象
    rst.Close
    Set rst = Nothing
    Set conn = Nothing
    Set Bar = Nothing
Exit_Create_Menus:
    Exit Function
Err_Create_Menus:
    Set rst = Nothing
    Set conn = Nothing
    Set Bar = Nothing
    MsgBox Err.Description, vbCritical, "Create_Menus"
    Resume Exit_Create_Menus
End Function
Public Function Create_ChildMenu(ByVal strTable As String, _
                                 ByVal strParentMenuID As String, _
                                 ByVal strMenuID As String, _
                                 ByVal strMenuName As String, _
                                 ByVal strMenuType As String, _
                                 ByRef CurrentMenu As Object, _
                                 ByVal CurrentMenuID As String)
'===============================================================================
'-函数名称:     Create_ChildMenu
'-功能描述:     Create_ChildMenu子函数
'-输入参数说明: 参数1: 必选 strTable As String  菜单数据来源的表名
'               参数2: 必选 strParentMenuID As String  父菜单字段名
'               参数3: 必选 strMenuID As String  菜单ID字段名
'               参数4: 必选 strMenuName As String  菜单名称字段名
'               参数5: 必选 strMenuType As String  菜单类型字段名
'               参数6: 必选 CurrentMenu As Object  当前菜单对象
'               参数7: 必选 CurrentMenuID As String  当前菜单字段名
'-返回参数说明:
'-使用语法示例: Call Create_ChildMenu(strTable, strParentMenuID, strMenuID, strMenuName, strMenuType, Bar, rst.Fields(strMenuID))
'-参考:
'-使用注意:     strTable为数据表名称
'               CurrentMenu As Object  菜单对象
'-兼容性:       2000,XP,2003 compatible
'-作者:         duomu
'-更新日期：    2007-09-10
'===============================================================================
    On Error GoTo Err_Create_ChildMenu
    Dim conn As New ADODB.Connection
    Dim rst As New ADODB.Recordset
    Dim strSQL As String
    Dim Menu As CommandBarControl
    'Dim BarCombo As CommandBarComboBox   '创建组合框控件,暂不支持该菜单类型
   
    '设置conn连接对象为当前打开的连接
    Set conn = CurrentProject.Connection
    '设置查询语句
    strSQL = "SELECT * FROM [" & strTable
    strSQL = strSQL & "] WHERE " & strParentMenuID & "='" & CurrentMenuID & "';"
    '设置记录集对象的内容，通过Open方法建立只读一个记录集
    rst.Open strSQL, conn, adOpenStatic, adLockReadOnly
    '使用循环语句
    Do While Not rst.EOF
        '载入数据
        Set Menu = CurrentMenu.Controls.Add(StrToConst(rst(strMenuType)), 1, , , True)
        '判断要加载的菜单类型
        If rst(strMenuType) = "msoControlPopup" Then
            With Menu
                .Caption = rst.Fields(strMenuName)
                .Tag = rst.Fields(strMenuName)
                .BeginGroup = True
            End With
        ElseIf rst(strMenuType) = "msoControlButton" Then
            With Menu
                .Caption = rst.Fields(strMenuName)
                .OnAction = Nz(Trim(rst.Fields(3)), "")
                .Style = msoButtonCaption
                '.State = msoButtonDown
            End With
        End If
        '递归:调用自身，加入子菜单,若无子菜单,则会递归至下一次时,自动跳出.
        Call Create_ChildMenu(strTable, strParentMenuID, strMenuID, strMenuName, strMenuType, Menu, rst.Fields(strMenuID))
        '移动指针到下一条记录
        rst.MoveNext
    Loop
    '创建完菜单后,关闭或销毁对象
    rst.Close
    Set rst = Nothing
    Set conn = Nothing
Exit_Create_ChildMenu:
    Exit Function
Err_Create_ChildMenu:
    Set rst = Nothing
    Set conn = Nothing
    MsgBox Err.Description, vbCritical, "Create_ChildMenu"
    Resume Exit_Create_ChildMenu
End Function



[ 本帖最后由 duomu 于 2007-9-10 19:42 编辑 ]

andymark

运行错误,提示Create_ChildMenu 对象不支持该属性或方法

5988143

謝謝分享!

小戴

直接给个例子好吗?

duomu

原帖由 andymark 于 2007-9-10 21:58 发表
运行错误,提示Create_ChildMenu 对象不支持该属性或方法

我试过2002，2003，没问题呀，版主能截个图上来吗

duomu

原帖由 小戴 于 2007-9-11 13:28 发表
直接给个例子好吗?

楼主没用心看贴，不是有附件吗

andymark

原帖由 duomu 于 2007-9-11 19:08 发表


我试过2002，2003，没问题呀，版主能截个图上来吗

代码能通过编译,运行出错