设为首页收藏本站Access中国
Office中国(www.office-cn.net),专业Office论坛

Office中国论坛/Access中国论坛

 找回密码
 注册

QQ登录

只需一步,快速开始

扫一扫,访问微社区

[原创]用VBA加载自定义菜单-Access常规交流-Office中国论坛

2007-9-11 09:56| 发布者: ivwooo| 查看: 2022| 评论: 0

错误之处,还请各位指正

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

最新评论

关闭

站长推荐上一条 /6 下一条

QQ|站长邮箱|小黑屋|手机版|Office中国/Access中国 ( 粤ICP备10043721号-1 )  

GMT+8, 2018-12-13 00:36 , Processed in 0.059172 second(s), 18 queries .

Powered by Discuz! X3.3

© 2001-2017 Comsenz Inc.

返回顶部