|
Sub main() '根据数据表初始化弹出菜单
On Error Resume Next
Dim data
Dim nrows, ncols
'读入源数据
data = Range("扣分表!a1").CurrentRegion.Value '定位源数据区,源数据放入数组data
nrows = UBound(data, 1)
ncols = UBound(data, 2)
ReDim Preserve data(1 To nrows, 1 To ncols)
Call 快捷菜单(data, nrows, ncols, "qlbh") '生成桥梁病害的快捷菜单
End Sub
Sub 快捷菜单(data, nrows, ncols, cbarName) '源数据,源数据行数,源数据列数,commandbar名
On Error Resume Next
Dim preMenuKey
Dim curMenuName
Dim curMenuCaption
Application.CommandBars(cbarName).Delete '重设菜单前删除commandbar
Set cbar = Application.CommandBars.Add(Name:=cbarName, position:=msoBarPopup) '创建弹出式菜单
'创建字典,并指定key和相应的item,item为commandbar对象
Set zd = CreateObject("Scripting.Dictionary") '目录树存储每个菜单
zd.Add cbarName, cbar
For i = 2 To nrows
preMenuKey = cbarName
For j = 1 To ncols
' preMenuKey = preMenuKey
If data(i, j) <> "" Then
curMenuKey = preMenuKey & "\" & data(i, j)
curMenuCaption = data(i, j)
End If
If Not zd.exists(curMenuKey) Then
If j = ncols Then
Call AddControl(zd, preMenuKey, curMenuKey, curMenuCaption, i, 1) '1为msocontrolbutton
ElseIf data(i, j + 1) = "" Then
Call AddControl(zd, preMenuKey, curMenuKey, curMenuCaption, i, 1) '1为msocontrolbutton
Else
Call AddControl(zd, preMenuKey, curMenuKey, curMenuCaption, i, 2) '1为msocontrolbutton
End If
End If
preMenuKey = curMenuKey
Next j
Next i
Set cbar = Nothing
End Sub
'添加菜单命令
Sub AddControl(ByVal zd, ByVal preMenuKey$, ByVal curMenuKey$, ByVal curMenuCaption$, ByVal i&, ByVal menuType$)
Dim bar
Select Case menuType
Case 1 'msoControlButton
Set bar = zd(preMenuKey).Controls.Add(Type:=msoControlButton)
bar.OnAction = "'WriteToRng " & i & "'" '最后一级选择触发事件,完成输入
Case 2 'msoControlPopup
Set bar = zd(preMenuKey).Controls.Add(Type:=msoControlPopup)
End Select
bar.caption = curMenuCaption '菜单按钮名称
zd.Add curMenuKey, bar '加入字典以供下级菜单索引节点
Set bar = Nothing
End Sub |
|