CommandBars 与弹出式菜单

一指禅62

为学习 CommandBars，在网上寻了点资料，还管用，因此分享。

CommandBars 教程.zip (9.21 KB, 下载次数: 1546)

2016-4-8 10:17 上传

点击文件名下载附件

这是我的练习，数据源用到了论坛里资料（若有异议请告知）

自定义菜单问题.rar (26.21 KB, 下载次数: 1764)

2016-4-24 12:22 上传

点击文件名下载附件

补充内容 (2017-2-20 15:14):
CommandBars 与会计科目 在9楼




补充内容 (2017-7-19 08:11):
树型菜单在财务中的一个运用实例 11楼

一指禅62

全部代码（模块代码）

1. Option Explicit
   
2. Dim CBar As CommandBar
   
3. 
   
4. Sub CommandBarAdd()
   
5.     Dim arr, i&
   
6.     arr = Sheet4.Range("A1").CurrentRegion
   
7.     Call DelBar
   
8.     Set CBar = Application.CommandBars.Add("树型菜单", msoBarPopup)
   
9.     For i = 2 To UBound(arr)
   
10.         Call AddNewMenu(CStr(arr(i, 1)), arr(i, 2))
    
11.     Next
    
12. End Sub
    
13. 
    
14. Private Sub AddNewMenu(ByVal key As String, ByVal txt As String)
    
15.     Dim j%, iPath$, n%
    
16.     Dim FindMenu As CommandBarControl
    
17.     Dim NewMenu As CommandBarControl
    
18.     On Error Resume Next
    
19.     n = WorksheetFunction.CountIf(Sheet4.Range("A:A"), key & "*")
    
20.     j = IIf(n = 1, msoControlButton, msoControlPopup)
    
21.     Set FindMenu = CommandBars.FindControl(Tag:=CStr(Left(key, Len(key) - 2)))  '查找这个父级
    
22.     On Error GoTo 123
    
23.     If FindMenu Is Nothing Then '没有父级
    
24.         iPath = txt    '路径
    
25.         Set NewMenu = CBar.Controls.Add(Type:=j)
    
26.     Else
    
27.         iPath = FindMenu.DescriptionText & "" & txt
    
28.         'iPath = FindMenu.DescriptionText & txt  '如果输出在一个单元格则用这句代码
    
29.         Set NewMenu = FindMenu.Controls.Add(Type:=j)
    
30.     End If
    
31.     With NewMenu
    
32.         .BeginGroup = True
    
33.         .Caption = txt
    
34.         .Tag = key
    
35.         .DescriptionText = iPath
    
36.         .OnAction = IIf(j < 2, "'输出到单元格 """ & iPath & """'", "")
    
37.     End With
    
38.     Set NewMenu = Nothing
    
39.     Exit Sub
    
40. 123:
    
41.     FindMenu.Delete
    
42. End Sub
    
43. 
    
44. Sub 输出到单元格(iStr As String)
    
45.     Dim a: a = Split(iStr, "")
    
46.     If Len(ActiveCell.Value) > 0 Then
    
47.         If MsgBox("是否替换这条记录？", vbQuestion + vbYesNo) = vbNo Then Exit Sub
    
48.     End If
    
49.     ActiveCell.Resize(1, 15) = ""
    
50.     ActiveCell.Resize(1, UBound(a) + 1) = a
    
51. End Sub
    
52. 
    
53. Sub DelBar()
    
54.     For Each CBar In CommandBars
    
55.         If CBar.Name = "" Or CBar.Name Like "树型菜单*" Then CBar.Delete
    
56.     Next
    
57. End Sub
    

复制代码

zhaogang1960

谢谢分享！！！！

一指禅62

zhaogang1960 发表于 2016-4-8 10:34
谢谢分享！！！！

感谢赵老师关注！请您多指点！

鄂龙蒙

一指禅62 发表于 2016-4-8 10:21
全部代码（模块代码）

请教：用的是什么控件？怎么添加？谢谢！

一指禅62

鄂龙蒙 发表于 2016-5-5 08:24
请教：用的是什么控件？怎么添加？谢谢！

CommandBar 是 Application 的对象

microyip

thank you for your share

鄂龙蒙

附件不能下载。

一指禅62

CommandBars 与会计科目.zip (34.72 KB, 下载次数: 1020)

2017-2-20 15:13 上传

点击文件名下载附件

wffmoon

谢谢大神   顶礼膜拜