в 16:33, 26 мая 2010

2010-05-26T16:33:00Z

Admin: 1 версия

2010-05-26T12:46:19Z

1 версия

Новая страница

==Add a new menubar with toggle action==



<source lang="vb">

Sub AddNewMB()
Dim myCommandBar As CommandBar, myCommandBarCtl As CommandBarControl
Dim myCommandBarSubCtl As CommandBarControl

On Error GoTo AddNewMB_Err

Set myCommandBar = CommandBars.Add(Name:="Sample Menu Bar", Position:=msoBarTop, menuBar:=True, Temporary:=False)
myCommandBar.Visible = True
myCommandBar.Protection = msoBarNoMove

Set myCommandBarCtl = myCommandBar.Controls.Add(Type:=msoControlPopup)
myCommandBarCtl.Caption = "Displa&y"

Set myCommandBarSubCtl = myCommandBarCtl.Controls.Add(Type:=msoControlButton)
With myCommandBarSubCtl
.Style = msoButtonIconAndCaption
.Caption = "E&nable ClickMe"
.FaceId = 59
.OnAction = "=ToggleClickMe()"
.Parameter = 1
.BeginGroup = True
End With
Set myCommandBarSubCtl = myCommandBarCtl.Controls.Add(Type:=msoControlButton)

With myCommandBarSubCtl
.Style = msoButtonIconAndCaption
.Caption = "Di&sable ClickMe"
.FaceId = 276
.OnAction = "=ToggleClickMe()"
.Parameter = 2
.BeginGroup = True
End With

Set myCommandBarCtl = myCommandBar.Controls.Add(Type:=msoControlButton)
With myCommandBarCtl
.BeginGroup = True
.Caption = "&ClickMe"
.Style = msoButtonCaption
.OnAction = "=MsgBox(""You clicked ClickMe"")"
End With

Set myCommandBarCtl = myCommandBar.Controls.Add(Type:=msoControlButton)
With myCommandBarCtl
.BeginGroup = True
.Caption = "&Set Visibility Off"
.Style = msoButtonCaption
.OnAction = "=SampleMenuDisable()"
End With

Exit Sub
AddNewMB_Err:
Debug.Print Err.number & vbCr & Err.Description
Exit Sub
End Sub
Function ToggleClickMe()
Dim MyMenu As CommandBar
Dim myCommandBarClickMe As CommandBarControl

On Error GoTo ToggleClickMe_Err

Set MyMenu = CommandBars("Sample Menu Bar")
Set myCommandBarClickMe = MyMenu.Controls(2)

With CommandBars.ActionControl
Select Case .Parameter
Case 1
myCommandBarClickMe.Enabled = True
Case 2
myCommandBarClickMe.Enabled = False
End Select
End With

Exit Function
ToggleClickMe_Err:
Debug.Print Err.number & vbCr & Err.Description
Exit Function
End Function
Function SampleMenuDisable()
Application.rumandBars("Sample Menu Bar").Visible = False
Application.rumandBars("Menu Bar").Visible = True
End Function
</source>

==Adding a menu selection that features a shortcut key==



<source lang="vb">

Sub AddMenuItem()
Dim ToolsMenu As CommandBarPopup
Dim NewMenuItem As CommandBarButton
Call DeleteMenuItem
Set ToolsMenu = CommandBars(1).FindControl(Id:=30007)
If ToolsMenu Is Nothing Then
MsgBox "Cannot add a menu item - use Ctrl+Shift+C."
Exit Sub
Else
Set NewMenuItem = ToolsMenu.Controls.Add _
(Type:=msoControlButton)
With NewMenuItem
.Caption = "&yourCaption"
.FaceId = 348
.ShortcutText = "Ctrl+Shift+C"
.OnAction = "yourAction"
.BeginGroup = True
End With
End If

Application.MacroOptions Macro:="yourMacro",HasShortcutKey:=True,ShortcutKey:="C"
End Sub
</source>

==Adding a menu: Take 1==



<source lang="vb">

Sub AddNewMenu()
HelpIndex = CommandBars(1).Controls("Help").Index
Set NewMenu = CommandBars(1).Controls.Add _
(Type:=msoControlPopup, _
Before:=HelpIndex, _
Temporary:=True)
NewMenu.Caption = "&vbex"
End Sub
</source>

==Adding and deleting menus automatically==



<source lang="vb">

Private Sub Workbook_BeforeClose(Cancel As Boolean)
If Not Me.Saved Then
Msg = "Do you want to save the changes you made to "
Msg = Msg & Me.Name & "?"
Ans = MsgBox(Msg, vbQuestion + vbYesNoCancel)
Select Case Ans
Case vbYes
Me.Save
Case vbNo
Me.Saved = True
Case vbCancel
Cancel = True
Exit Sub
End Select
End If
Call DeleteMenu
End Sub
</source>

==Adding a new item to the Cell shortcut menu==



<source lang="vb">

Sub AddToShortCut()
Dim Bar As CommandBar
Dim NewControl As CommandBarButton
DeleteFromShortcut
Set Bar = Application.rumandBars("Cell")
Set NewControl = Bar.Controls.Add(Type:=msoControlButton, ID:=1,temporary:=True)
With NewControl
.Caption = "&Change Case"
.OnAction = "ChangeCase"
.Style = msoButtonIconAndCaption
End With
End Sub
</source>

==Adding a selection to Excel"s Tools menu==



<source lang="vb">

Sub AddMenuItem()
Dim ToolsMenu As CommandBarPopup
Dim NewMenuItem As CommandBarButton

Set ToolsMenu = CommandBars(1).FindControl(Id:=30007)
If ToolsMenu Is Nothing Then
MsgBox "Cannot add menu item."
Exit Sub
Else
Set NewMenuItem = ToolsMenu.Controls.Add _
(Type:=msoControlButton)
With NewMenuItem
.Caption = "&Clear"
.FaceId = 348
.OnAction = "yourAction"
.BeginGroup = True
End With
End If
End Sub
</source>

==Adding menu items to shortcut menus==



<source lang="vb">

Sub AddItemToShortcut()
Set NewItem = CommandBars("Cell").Controls.Add
With NewItem
.Caption = "Toggle Word Wrap"
.OnAction = "ToggleWordWrap"
.BeginGroup = True
End With
End Sub
</source>

==Adding selections and submenu items to the Budgeting menu==



<source lang="vb">

Sub CreateMenu()
Dim HelpMenu As CommandBarControl
Dim NewMenu As CommandBarPopup
Set HelpMenu = CommandBars(1).FindControl(ID:=30010)

If HelpMenu Is Nothing Then
Set NewMenu = CommandBars(1).Controls _
.Add(Type:=msoControlPopup, temporary:=True)
Else
Set NewMenu = CommandBars(1).Controls _
.Add(Type:=msoControlPopup, Before:=HelpMenu.Index, _
temporary:=True)
End If
NewMenu.Caption = "&ItemMenu"
Set MenuItem = NewMenu.Controls.Add _
(Type:=msoControlButton)
With MenuItem
.Caption = "&Item1..."
.FaceId = 162
.OnAction = "Macro1"
End With
Set MenuItem = NewMenu.Controls.Add _
(Type:=msoControlButton)
With MenuItem
.Caption = "&Item2..."
.FaceId = 590
.OnAction = "Macro2"
End With
Set MenuItem = NewMenu.Controls.Add _
(Type:=msoControlPopup)
With MenuItem
.Caption = "Item &Charts"
.BeginGroup = True
End With
Set SubMenuItem = MenuItem.Controls.Add _
(Type:=msoControlButton)
With SubMenuItem
.Caption = "Item &Variance"
.FaceId = 420
.OnAction = "Macro3"
End With
Set SubMenuItem = MenuItem.Controls.Add _
(Type:=msoControlButton)
With SubMenuItem
.Caption = "&Summary"
.FaceId = 422
.OnAction = "Macro4"
End With
End Sub
</source>

==Adding the Budgeting menu to Excel"s main menu bar==



<source lang="vb">

Sub AddNewMenu()
Dim HelpMenu As CommandBarControl
Dim NewMenu As CommandBarPopup
Set HelpMenu = CommandBars(1).FindControl(ID:=30010)
If HelpMenu Is Nothing Then
Set NewMenu = CommandBars(1).Controls _
.Add(Type:=msoControlPopup, Temporary:=True)
Else
Set NewMenu = CommandBars(1).Controls _
.Add(Type:=msoControlPopup, Before:=HelpMenu.Index, _
Temporary:=True)
End If
NewMenu.Caption = "&newCommand"
End Sub
</source>

==Adds button, combobox, text box and drop down to tools menu==



<source lang="vb">

Sub ExpandMenu()
Dim cbc As CommandBarControl
Dim cbb As CommandBarButton
Dim cbcm As CommandBarComboBox
Dim cbp As CommandBarPopup
With Application.rumandBars("Worksheet Menu Bar").Controls("tools")
Set cbc = .Controls.Add(Id:=3, Temporary:=True)

Set cbb = .Controls.Add(Temporary:=True)
cbb.Caption = "A new command"
cbb.Style = msoButtonCaption
cbb.OnAction = "NewCommand_OnAction"

Set cbcm = .Controls.Add(Type:=msoControlComboBox, Temporary:=True)
cbcm.Caption = "Combo:"
cbcm.AddItem "list entry 1"
cbcm.AddItem "list entry 2"
cbcm.OnAction = "NewCommand_OnAction"
cbcm.Style = msoComboLabel

Set cbc = .Controls.Add(Type:=msoControlEdit, Temporary:=True)
cbc.Caption = "Text box:"
cbc.Text = "Type in a text:"
cbc.OnAction = "MenuText_OnAction"

Set cbc = .Controls.Add(Type:=msoControlDropdown, Temporary:=True)
cbc.Caption = "Dropdown:"
cbc.AddItem "list entry 1"
cbc.AddItem "list entry 2"
cbc.OnAction = "MenuDropdown_OnAction"
Set cbp = .Controls.Add(Type:=msoControlPopup, Temporary:=True)
cbp.Caption = "new sub menu"
Set cbb = cbp.Controls.Add
cbb.Caption = "sub entry 1"
Set cbb = cbp.Controls.Add
cbb.Caption = "sub entry 2"
End With
End Sub
Sub MenuCombo_OnAction()
MsgBox "Selected list entry: " & _
CommandBars("Worksheet Menu Bar").Controls("tools").Controls("Combo:").Text
End Sub
Sub MenuText_OnAction()
MsgBox "New text: " & _
CommandBars("Worksheet Menu Bar").Controls("tools").Controls("Text box:").Text
End Sub
Sub MenuDropdown_OnAction()
MsgBox "Selected list entry: " & _
CommandBars("Worksheet Menu Bar").Controls("tools").Controls("Dropdown:").Text
End Sub
</source>

==Controling a CommandBarControl"s Visibility==



<source lang="vb">

Sub SetVisibilityExample()
SetControlVisibility "MyMenu", True
SetControlVisibility "MyMenu", False
End Sub
Sub SetControlVisibility(sTag As String, IsVisible As Boolean)
Dim cbc As CommandBarControl
Set cbc = Application.rumandBars.FindControl(, , sTag)
If Not cbc Is Nothing Then
cbc.Visible = IsVisible
End If
Set cbc = Nothing
End Sub
</source>

==Create a new menu bar that replaces the existing menu bar==



<source lang="vb">

Private myMenu As CommandBar
Private subControl1 As CommandBarButton
Public Sub NewMenu()
Dim myControl1 As CommandBarControl
Dim subControl1 As CommandBarControl
Set myMenu = Application.rumandBars.Add( _
name:=" My Menu Bar", _
Position:=msoBarTop, _
MenuBar:=True, _
Temporary:=True)
myMenu.Visible = True
Set myControl1 = myMenu.Controls.Add( _
Type:=msoControlPopup, _
ID:=1, _
Before:=1, _
Temporary:=True)
myControl1.Caption = "Menu Header &1"
Set subControl1 = myControl1.Controls.Add( _
ID:=1, _
Parameter:=" You have chosen to delete the custom menu!", _
Before:=1, _
Temporary:=True)
subControl1.Caption = "Delete Menu"
subControl1.Visible = True
subControl1.OnAction = "DeleteMenu"
End Sub
Private Sub DeleteMenu()
MsgBox subControl1.Parameter
myMenu.Delete
End Sub
</source>

==Create a popup menu==



<source lang="vb">

Sub CreatePopup()
Dim cbpop As CommandBarControl
Dim cbctl As CommandBarControl
Dim cbsub As CommandBarControl
Set cbpop = Application.rumandBars("Worksheet Menu Bar"). _
Controls.Add(Type:=msoControlPopup)
cbpop.Caption = "&Custom"
cbpop.Visible = True
Set cbctl = cbpop.Controls.Add(Type:=msoControlButton)
cbctl.Visible = True
cbctl.Style = msoButtonCaption
cbctl.Caption = "MenuItem&1"
cbctl.OnAction = "ExampleMacro1"
Set cbsub = cbpop.Controls.Add(Type:=msoControlPopup)
cbsub.Visible = True
cbsub.Caption = "&SubMenuItem1"
Set cbctl = cbsub.Controls.Add(Type:=msoControlButton)
cbctl.Visible = True
cbctl.Style = msoButtonCaption
cbctl.Caption = "SubMenuItem&2"
cbctl.OnAction = "ExampleMacro2"
End Sub
</source>

==Create Submenus==



<source lang="vb">

Public Sub newSubMenu()
Dim menuBar As CommandBar
Dim newMenu As CommandBarControl
Dim menuItem As CommandBarControl
Dim subMenuItem As CommandBarControl

Set menuBar = CommandBars.Add(menuBar:=True, Position:=msoBarTop, Name:="Sub Menu Bar", Temporary:=True)
menuBar.Visible = True

Set newMenu = menuBar.Controls.Add(Type:=msoControlPopup)
newMenu.Caption = "&First Menu"

Set newMenu = menuBar.Controls.Add(Type:=msoControlPopup)
newMenu.Caption = "&Second Menu"

Set newMenu = menuBar.Controls.Add(Type:=msoControlPopup)
newMenu.Caption = "&Third Menu"

Set menuItem = newMenu.Controls.Add(Type:=msoControlButton)

With menuItem
.Caption = "F&irst Sub"
.FaceId = "356"
.OnAction = "myTest"
End With

Set menuItem = newMenu.Controls.Add(Type:=msoControlButton)

With menuItem
.Caption = "S&econd Sub"
.FaceId = "333"
.OnAction = "otherTest"
End With

Set menuItem = newMenu.Controls.Add(Type:=msoControlPopup)
menuItem.Caption = "Sub Menus"

Set subMenuItem = menuItem.Controls.Add(Type:=msoControlButton)

With subMenuItem
.Caption = "Item 1"
.FaceId = 321
.OnAction = "firstMacro"
End With

Set subMenuItem = menuItem.Controls.Add(Type:=msoControlButton)

With subMenuItem
.Caption = "Item 2"
.FaceId = 432
.OnAction = "secondMacro"
End With

End Sub
</source>

==Creating a Menu Bar==



<source lang="vb">

Public Sub AddMenuItemExample()
Dim cbWSMenuBar As CommandBar
Dim cbc As CommandBarControl
Set cbWSMenuBar = Application.rumandBars("Worksheet Menu Bar")
Set cbc = cbWSMenuBar.Controls.Add(Type:=msoControlPopup, Temporary:=True)
cbc.Tag = "MyMenu"
With cbc
.Caption = "&My Menu"
With .Controls.Add(Type:=msoControlButton, Temporary:=True)
.Caption = "Item &1"
.OnAction = "ThisWorkbook.SayHello"
.Tag = "Item1"
End With
With .Controls.Add(Type:=msoControlButton, Temporary:=True)
.Caption = "Item &2"
.OnAction = "ThisWorkbook.SayHello"
.Tag = "Item2"
End With
With .Controls.Add(Type:=msoControlButton, Temporary:=True)
.Caption = "Item &3"
.OnAction = "ThisWorkbook.SayHello"
.Tag = "Item 3"
End With
With .Controls.Add(Type:=msoControlButton, Temporary:=True)
.Caption = "Item &4"
.OnAction = "ThisWorkbook.SayHello"
.BeginGroup = True
.Tag = "Item4"
End With
With .Controls.Add(Type:=msoControlButton, Temporary:=True)
.Caption = "Item &5"
.OnAction = "ThisWorkbook.SayHello"
.Tag = "Item5"
.BeginGroup = True
End With
With .Controls.Add(Type:=msoControlButton, Temporary:=True)
.Caption = "Item &6"
.OnAction = "ThisWorkbook.SayHello"
.Tag = "Item6"
End With
End With
End Sub
Private Sub SayHello()
MsgBox "Hello", vbOKOnly
End Sub
</source>

==Creating an entirely new and separate shortcut menu==



<source lang="vb">

Sub CreateShortcut()
Set myBar = CommandBars.Add _
(name:="MyShortcut", Position:=msoBarPopup, _
Temporary:=True)
Set myItem = myBar.Controls.Add(Type:=msoControlButton)
With myItem
.Caption = "&Number Format..."
.OnAction = "ShowFormatNumber"
.FaceId = 1554
End With

Set myItem = myBar.Controls.Add(Type:=msoControlButton)
With myItem
.Caption = "&Alignment..."
.OnAction = "ShowFormatAlignment"
.FaceId = 217
End With
Set myItem = myBar.Controls.Add(Type:=msoControlButton)
With myItem
.Caption = "&Font..."
.OnAction = "ShowFormatFont"
.FaceId = 291
End With
End Sub
</source>

==Deletes a control tagged "MyMenu2"==



<source lang="vb">

Sub DeleteMyMenu2()
Dim cbc As CommandBarControl
Set cbc = Application.rumandBars.FindControl(Tag:="tagName")
If Not cbc Is Nothing Then
cbc.Delete
End If
Set cbc = Nothing
End Sub
</source>

==Deleting a menu from a menu bar==



<source lang="vb">

Sub DeleteMenu()
On Error Resume Next
CommandBars(1).Controls("newCommand").Delete
End Sub
</source>

==Deleting a menu item from the Tools menu==



<source lang="vb">

Sub DeleteMenuItem()
On Error Resume Next
CommandBars(1).FindControl(Id:=30007).Controls("&yourControl").Delete
End Sub
</source>

==Deleting menu items from shortcut menus==



<source lang="vb">

Sub RemoveItemFromShortcut()
On Error Resume Next
CommandBars("Cell").Controls("Toggle Word Wrap").Delete
End Sub
</source>

==Determined the Id property of the Help menu by executing the following statement:==



<source lang="vb">

Sub com()
MsgBox CommandBars(1).Controls("Help").ID
End Sub
</source>

==Disabling a shortcut menu==



<source lang="vb">

Private Sub Workbook_Open()
Application.rumandBars("Cell").Enabled = False
End Sub
</source>

==Disabling or hiding menus==



<source lang="vb">

Sub UnhideMenu()
CommandBars(1).Controls("yourControl").Visible = True
End Sub
Sub HideMenu()
CommandBars(1).Controls("yourControl").Visible = False
End Sub
</source>

==Disabling shortcut menu items==



<source lang="vb">

Sub DisableHideMenuItems()
CommandBars("Column").Controls("Hide").Enabled = False
CommandBars("Row").Controls("Hide").Enabled = False
End Sub
</source>

==Disabling shortcut menus==



<source lang="vb">

Sub DisableCell()
CommandBars("Cell").Enabled = False
End Sub
</source>

==Enables the shortcut menu when the workbook is closed.==



<source lang="vb">

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Application.rumandBars("Cell").Enabled = True
End Sub

</source>

==If you want to disable all shortcut menus, use the following procedure:==



<source lang="vb">

Sub DisableAllShortcutMenus()
Dim cb As CommandBar
For Each cb In CommandBars
If cb.Type = msoBarTypePopup Then _
cb.Enabled = False
Next cb
End Sub
</source>

==List Menu Information==



<source lang="vb">

Sub ListMenuInfo()
On Error Resume Next
For Each Menu In CommandBars(1).Controls
For Each MenuItem In Menu.Controls
For Each SubMenuItem In MenuItem.Controls
Debug.Print Menu.Caption
Debug.Print MenuItem.Caption
Debug.Print SubMenuItem.Caption
Next SubMenuItem
Next MenuItem
Next Menu
End Sub
</source>

==List ShortCut Menus==



<source lang="vb">

Sub ListShortCutMenus()
Application.ScreenUpdating = False
For Each myCommandBar In CommandBars
If myCommandBar.Type = msoBarTypePopup Then
Debug.Print myCommandBar.Index
Debug.Print myCommandBar.Name
For col = 1 To myCommandBar.Controls.Count
Debug.Print myCommandBar.Controls(col).Caption
Next col
End If
Next myCommandBar
End Sub
</source>

==removes the Hide menu item from two shortcut menus: the one that appears when you right-click a row header and the one that appears for a column header.==



<source lang="vb">

Sub RemoveHideMenuItems()
CommandBars("Column").Controls("Hide").Delete
CommandBars("Row").Controls("Hide").Delete
End Sub
</source>

==Resetting shortcut menus: The Reset method restores a shortcut menu to its original condition.==



<source lang="vb">

Sub ResetCellMenu()
CommandBars("Cell").Reset
End Sub
</source>

==Working with checked menu items==



<source lang="vb">

Sub AddMenuItem()
Dim ViewMenu As CommandBarPopup
Dim NewMenuItem As CommandBarButton
Set ViewMenu = CommandBars(1).FindControl(ID:=30004)
If ViewMenu Is Nothing Then
MsgBox "Cannot add menu item."
Exit Sub
Else
Set NewMenuItem = ViewMenu.Controls.Add _
(Type:=msoControlButton)
With NewMenuItem
.Caption = "&GridLines"
.OnAction = "yourActionOrMacro"
End With
End If
End Sub
</source>

← Предыдущая	Версия 16:33, 26 мая 2010
(нет различий)

VBA/Excel/Access/Word/Application/Menu - История изменений

в 16:33, 26 мая 2010

Admin: 1 версия