工具栏→下拉菜单的工作方法

ningyong58 · 发表于 2010-9-30 07:11

http://club.excelhome.net/thread-631687-1-1.html
小结了一下其要点为：
1 Set 工具列 = Application.CommandBars.Add(Name:=工具列名稱, Position:=msoBarTop, Temporary:=True)
2 Set 按鈕 = 工具列.Controls.Add(Type:=msoControlButton, Temporary:=True)
3 Set 新功能表按鈕 = 工具列.Controls.Add(Type:=msoControlPopup, Temporary:=True)

调试了几次总是有问题。
目标需求，将附件示例再简化一下，工具栏中三个按钮→1按钮，这个按钮有下拉菜单。

ningyong58 · 发表于 2010-9-30 12:42

Position:=msoBarTop, Temporary:=True→好理解。
Type:=msoControlButton, Temporary:=True→基本理解
Type:=msoControlPopup, Temporary:=True→这个弯转不过来

如何定义msoControlButton赋值→msoControlPopup的赋值关系。

请各位大侠解决的问题见图

看原程序没问题，自己重做一遍，一个小弯老是拐不过来。

Book1.rar (7.27 KB, 下载次数: 30)

[ 本帖最后由 ningyong58 于 2010-9-30 15:57 编辑 ]

fsyyyy · 发表于 2010-9-30 12:53

弹出式控件

lb_bn · 发表于 2010-9-30 20:19

没有2003的excel，调试不了，给楼主一个4级菜单的，看有没有帮助。

lb_bn · 发表于 2010-9-30 20:21

我的理解就是msoControlPopup型的包含msoControlButton型的，前者是后者的父级。

ningyong58 · 发表于 2010-9-30 21:18

原帖由 lb_bn 于 2010-9-30 20:21 发表
我的理解就是msoControlPopup型的包含msoControlButton型的，前者是后者的父级。

谢谢，使用的示例都是 as object.
看了这个帖子思路逐渐清晰。msoControlPopup型的包含msoControlButton型
''''

Dim myPop As CommandBarPopup
Dim myBtn As CommandBarButton
Dim Pop() As CommandBarPopup
Dim Pop1() As CommandBarPopup
Sub ls()
On Error Resume Next
Dim i As Long
CommandBars("tempBar").Delete
Dim oBar As CommandBar
Set oBar = Application.CommandBars.Add("tempBar", msoBarPopup, , True)
With oBar
.Height = 500
.Width = 400
.Visible = True
End With
''
Dim oPop As CommandBarPopup
Dim oBtn As CommandBarButton
Dim Pop() As CommandBarPopup
Dim Pop1() As CommandBarPopup
''
Set oPop = oBar.Controls.Add(msoControlPopup, , , , True) ' oBar.Controls.Add(msoControlPopup, , , , True)
With oPop
.Caption = "寺ffffffffff"
.Visible = True
End With
ReDim Pop(0)
Set Pop(0) = oPop.Controls.Add(msoControlPopup, , , , True)
With Pop(0)
.Caption = "fdafdaf"
.Visible = True
End With
'CommandBars("tempBar").ShowPopup
End Sub
''
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim oBar As CommandBarButton
CommandBars("tempBar").ShowPopup
End Sub

复制代码

Book1.rar (6.86 KB, 下载次数: 66)

[ 本帖最后由 ningyong58 于 2010-10-2 11:16 编辑 ]

ningyong58 · 发表于 2010-9-30 21:23

Set myPop = mybar.Controls.Add(msoControlPopup, , , , True)
myPop.Caption = .Cells(i, "A")

比这种写法理解起来容易点。
Set 新功能表按鈕 = 工具列.Controls.Add(Type:=msoControlPopup, Temporary:=True)

Sub Create_popup()
On Error Resume Next
'Dim i As Byte
Dim i As Long
CommandBars("myR").Delete
Dim mybar As CommandBar
Set mybar = Application.CommandBars.Add("myR", msoBarPopup, , True)
mybar.Height = 500
mybar.Width = 400
Dim myPop As CommandBarPopup
Dim myBtn As CommandBarButton
Dim Pop() As CommandBarPopup
Dim Pop1() As CommandBarPopup
Dim n As Integer
Dim n1 As Integer
n = 1
n1 = 1
Dim dc As Object
Dim dc1 As Object
Set dc = CreateObject("scripting.dictionary")
Set dc1 = CreateObject("scripting.dictionary")
With Sheets("商品名称数源")
For i = 1 To .[a65536].End(3).Row
'For i = 2 To .[a65536].End(3).Row
Next
For i = 1 To .[a65536].End(3).Row
'For i = 2 To .[a65536].End(3).Row
If .Cells(i, "A").Font.ColorIndex = 3 Then
Set myPop = mybar.Controls.Add(msoControlPopup, , , , True)
myPop.Caption = .Cells(i, "A")
bl = True
Else
If .Cells(i, "D") <> "" Then
If Not dc.exists(.Cells(i, "D").Value) Then
dc.Add .Cells(i, "D").Value, n
ReDim Preserve Pop(n) As CommandBarPopup
Set Pop(n) = myPop.Controls.Add(msoControlPopup, , , , True)
Pop(n).Caption = .Cells(i, "D")
n = n + 1
End If 'If Not dc.exists(.Cells(i, "D").Value)
If .Cells(i, "E") <> "" Then
If Not dc1.exists(.Cells(i, "E").Value) Then
dc1.Add .Cells(i, "E").Value, n1
ReDim Preserve Pop1(n1) As CommandBarPopup
Set Pop1(n1) = Pop(dc.Item(.Cells(i, "D").Value)).Controls.Add(msoControlPopup, , , , True)
Pop1(n1).Caption = .Cells(i, "E")
n1 = n1 + 1
End If
Set myBtn = Pop1(dc1.Item(.Cells(i, "E").Value)).Controls.Add(msoControlButton)
myBtn.Caption = .Cells(i, "A")
myBtn.HelpFile = .Cells(i, 2) & "," & .Cells(i, 3)
myBtn.Style = msoButtonCaption
myBtn.OnAction = "myBtn_click"
Else
Set myBtn = Pop(dc.Item(.Cells(i, "D").Value)).Controls.Add(msoControlButton)
myBtn.Caption = .Cells(i, "A")
myBtn.HelpFile = .Cells(i, 2) & "," & .Cells(i, 3) '2010年5月5日：将单价和单位信息保存到按钮的Helpfile属性中，然后在mybtn_click事件中取出。
myBtn.Style = msoButtonCaption
myBtn.OnAction = "myBtn_click"
End If
Else
Set myBtn = myPop.Controls.Add(msoControlButton)
myBtn.Caption = .Cells(i, "A")
myBtn.HelpFile = .Cells(i, 2) & "," & .Cells(i, 3) '2010年5月5日：将单价和单位信息保存到按钮的Helpfile属性中，然后在mybtn_click事件中取出。
myBtn.Style = msoButtonCaption
myBtn.OnAction = "myBtn_click"
End If 'If .Cells(i, "D") <> "" Then
End If 'If .Cells(i, "A").Font.ColorIndex = 3 Then
Next
End With
Set myBtn = Nothing
Set myPop = Nothing
Set mybar = Nothing
Set dc = Nothing
Set dc1 = Nothing
Erase Pop
Erase Pop1
End Sub

复制代码

[ 本帖最后由 ningyong58 于 2010-10-2 10:23 编辑 ]

linyancheng · 发表于 2010-10-2 18:55

Set 按鈕 = 新功能表按鈕.CommandBar.Controls.Add(Type:=msoControlButton, Temporary:=True)

我的代碼紅色部分不加不行，為什麼你們可以不用加？

是變數宣告類型不同的關係嗎？

[ 本帖最后由 linyancheng 于 2010-10-2 18:58 编辑 ]

ningyong58 · 发表于 2010-10-3 09:29

Sub aaa()
On Error Resume Next
Dim X As Long
Dim btnArr As Variant
Dim oBar As Object
Dim newBtn As Object
Dim Btn As Object
Dim toolName As String
'編輯區，其他部分不須編輯==================================================================================================
'◎表Btn置於oBar上，否則置於新功能表上
'★表新功能表銨鈕
'▲表Btn開始群組，可單獨使用，否則必須緊接在◎、★之後
'非◎者一定要置於★項目之後
'陣列元素名稱須為Sub名稱（★項目除外）
btnArr = Array("◎VBA1", "★VBA2", "VBA3", "▲VBA4", "◎▲VBA5", "★▲VBA6", "VBA7", "VBA8", "▲VBA9")
toolName = "myTool"
Application.CommandBars(toolName).Delete
'==================================================================================================
Set oBar = Application.CommandBars.Add(Name:=toolName, Position:=msoBarTop, Temporary:=True)
oBar.Visible = True
For X = 0 To UBound(btnArr)
If Left(btnArr(X), 1) = "◎" Then
Set Btn = oBar.Controls.Add(Type:=msoControlButton, Temporary:=True)
With Btn
.Caption = Replace(btnArr(X), "◎", "")
.Caption = Replace(.Caption, "▲", "")
.Caption = Replace(.Caption, "Show", "")
.Style = msoButtonCaption
.OnAction = Replace(btnArr(X), "◎", "")
.OnAction = Replace(.OnAction, "▲", "")
If Not InStr(Left(btnArr(X), 2), "▲") = 0 Then
.BeginGroup = True
End If
End With
ElseIf Left(btnArr(X), 1) = "★" Then
Set newBtn = oBar.Controls.Add(Type:=msoControlPopup, Temporary:=True)
With newBtn
.Caption = Replace(btnArr(X), "★", "")
.Caption = Replace(.Caption, "▲", "")
.Style = msoButtonCaption
If Not InStr(Left(btnArr(X), 2), "▲") = 0 Then
.BeginGroup = True
End If
End With
Else
Set Btn = newBtn.CommandBar.Controls.Add(Type:=msoControlButton, Temporary:=True)
With Btn
.Caption = Replace(btnArr(X), "▲", "")
.Caption = Replace(.Caption, "Show", "")
.Style = msoButtonCaption
.OnAction = Replace(btnArr(X), "▲", "")
If Not InStr(Left(btnArr(X), 2), "▲") = 0 Then
.BeginGroup = True
End If
End With
End If
Next X
End Sub

复制代码

[ 本帖最后由 ningyong58 于 2010-10-4 08:24 编辑 ]

		自动登录	找回密码
密码			免费注册