Office中国论坛/Access中国论坛

标题: [原创]用VBA加载自定义菜单 [打印本页]

作者: duomu 时间: 2007-9-10 19:40
标题: [原创]用VBA加载自定义菜单
错误之处,还请各位指正

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

[attach]26209[/attach]

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

作者: andymark 时间: 2007-9-10 21:58
运行错误,提示Create_ChildMenu 对象不支持该属性或方法

作者: 5988143 时间: 2007-9-11 12:38
謝謝分享!

作者: 小戴 时间: 2007-9-11 13:28
直接给个例子好吗?

作者: duomu 时间: 2007-9-11 19:08

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

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

作者: duomu 时间: 2007-9-11 19:09

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

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

作者: andymark 时间: 2007-9-11 19:50

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

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

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

欢迎光临 Office中国论坛/Access中国论坛 (http://www.office-cn.net/)