How do I make one of the menu items open a hyperlink?
For example say Button 1 when selected in the menu opens "www.google.com" and Button 2 opens "www.yahoo.com" instead of test Macro. I tried changing the .OnAction to .FollowHyperlink.
I even tried just entering the hyperlink in the .OnAction section with no luck.
Any advice?
Option Explicit
Public Const Mname As String = "MyPopUpMenu"
Sub DeletePopUpMenu()
' Delete the popup menu if it already exists.
On Error Resume Next
Application.CommandBars(Mname).Delete
On Error GoTo 0
End Sub
Sub CreateDisplayPopUpMenu()
' Delete any existing popup menu.
Call DeletePopUpMenu
' Create the popup menu.
Call Custom_PopUpMenu_1
' Display the popup menu.
On Error Resume Next
Application.CommandBars(Mname).ShowPopup
On Error GoTo 0
End Sub
Sub Custom_PopUpMenu_1()
Dim MenuItem As CommandBarPopup
' Add the popup menu.
With Application.CommandBars.Add(Name:=Mname, Position:=msoBarPopup, _
MenuBar:=False, Temporary:=True)
' First, add two buttons to the menu.
With .Controls.Add(Type:=msoControlButton)
.Caption = "Button 1"
.FaceId = 71
.OnAction = "'" & ThisWorkbook.Name & "'!" & "TestMacro"
End With
With .Controls.Add(Type:=msoControlButton)
.Caption = "Button 2"
.FaceId = 72
.OnAction = "'" & ThisWorkbook.Name & "'!" & "TestMacro"
End With
' Next, add a menu that contains two buttons.
Set MenuItem = .Controls.Add(Type:=msoControlPopup)
With MenuItem
.Caption = "My Special Menu"
With .Controls.Add(Type:=msoControlButton)
.Caption = "Button 1 in menu"
.FaceId = 71
.OnAction = "'" & ThisWorkbook.Name & "'!" & "TestMacro"
End With
With .Controls.Add(Type:=msoControlButton)
.Caption = "Button 2 in menu"
.FaceId = 72
.OnAction = "'" & ThisWorkbook.Name & "'!" & "TestMacro"
End With
End With
' Finally, add a single button.
With .Controls.Add(Type:=msoControlButton)
.Caption = "Button 3"
.FaceId = 73
.OnAction = "'" & ThisWorkbook.Name & "'!" & "TestMacro"
End With
End With
End Sub
Sub TestMacro()
MsgBox "Hi there!"
End Sub
You can put
ThisWorkbook.FollowHyperlink "http://......"
In your TestMacro
If you are going to use this as a method of launching hyperlinks, add a parameter to the Testmacro sub procedure.
.OnAction = "'" & ThisWorkbook.Name & "'!" & "TestMacro(1)"
...
.OnAction = "'" & ThisWorkbook.Name & "'!" & "TestMacro(2)"
...
.OnAction = "'" & ThisWorkbook.Name & "'!" & "TestMacro(3)"
The actual TestMacro sub would institute a Select Case statement to handle all of the menu commands.
Sub TestMacro(Optional iTYP As Long = 1)
Select Case iTYP
Case 1
MsgBox "option 1"
ActiveWorkbook.FollowHyperlink "http://www.google.com"
Case 2
MsgBox "option 2"
ActiveWorkbook.FollowHyperlink "http://www.yahoo.com"
Case 3
MsgBox "option 3"
ActiveWorkbook.FollowHyperlink "http://www.bing.com"
Case Else
ActiveWorkbook.FollowHyperlink "http://stackoverflow.com"
End Select
End Sub
as with Bas answer you can set your TestMacro to have an input string for the url and then pass that when calling it
' Finally, add a single button.
With .Controls.Add(Type:=msoControlButton)
.Caption = "Button 3"
.FaceId = 73
.OnAction = "'" & ThisWorkbook.Name & "'!" & "TestMacro(" & Chr(34) & "http://www.google.com" & Chr(34) & ")"
End With
Sub TestMacro(url As String)
ThisWorkbook.FollowHyperlink url
End Sub
Related
I have menu with submenu made of control buttons:
Set MenuItem = .Controls.Add(Type:=msoControlPopup)
With MenuItem
.caption = "Code Type"
With .Controls.Add(Type:=msoControlButton)
.caption = "Lists"
.OnAction = "'" & ThisWorkbook.Name & "'!" & "setCaption"
End With
End With
Sub setCaption()
MsgBox Application.caller
End Sub
When I try with the above example, I get Type mismatch error.
There seems to be very little online around this, so some input here would be very useful.
I have used the below code to add an option to a right-click menu:
Private Sub Workbook_Open()
Dim MyMenu As Object
Set MyMenu = Application.ShortcutMenus(xlWorksheetCell) _
.MenuItems.AddMenu("Opportunities", 1)
With MyMenu.MenuItems
.Add "Open", "openOpportunity", , 1, , ""
.Add "Edit", "editOpportunity", , 2, , ""
End With
Set MyMenu = Nothing
End Sub
This adds an option to the right-click menu when I right-click in a cell, but when I right-click a cell in an Excel table, it doesn't appear.
Any ideas where I go next?
You also must add your options to 'List Range Popup'. I am not familiar with the way you do that and I don't know how to obtain the necessary Command bar index, so I will show you my way to do exactly what you need, in the next code:
Sub AddButContextMenu()
Dim CMenu_Cell As CommandBar, MySubMCell As CommandBarControl
Dim CMenu_Table As CommandBar, MySubMTable As CommandBarControl
'Delete the controls first, in order to avoid duplicates
Call DeleteFromCellMenu
'Set ContextMenu to the Cell menu and List Range Popup
Set CMenu_Cell = Application.CommandBars(35) 'Cell menu
Set CMenu_Table = Application.CommandBars(71) 'List Range Popup
Set MySubMCell = CMenu_Cell.Controls.Add(Type:=msoControlPopup, Before:=3)
Set MySubMTable = CMenu_Table.Controls.Add(Type:=msoControlPopup, Before:=3)
With MySubMCell
.Caption = "Opportunities"
.Tag = "My_Tag"
With .Controls.Add(Type:=msoControlButton)
.OnAction = "'" & ThisWorkbook.Name & "'!" & "openOpportunity"
.Caption = "Open"
End With
With .Controls.Add(Type:=msoControlButton)
.OnAction = "'" & ThisWorkbook.Name & "'!" & "editOpportunity"
.Caption = "Edit"
End With
End With
With MySubMTable
.Caption = "Opportunities"
.Tag = "My_Tag"
With .Controls.Add(Type:=msoControlButton)
.OnAction = "'" & ThisWorkbook.Name & "'!" & "openOpportunity"
.Caption = "Open"
End With
With .Controls.Add(Type:=msoControlButton)
.OnAction = "'" & ThisWorkbook.Name & "'!" & "editOpportunity"
.Caption = "Edit"
End With
End With
CMenu_Cell.Controls(4).BeginGroup = True 'add separator
CMenu_Table.Controls(4).BeginGroup = True 'add separator
End Sub
Sub DeleteFromCellMenu()
Dim ContextMCell As CommandBar, ContextMTable As CommandBar
Dim ctrl As CommandBarControl
Set ContextMCell = Application.CommandBars(35) 'Cell
Set ContextMTable = Application.CommandBars(71) 'List Range Popup
For Each ctrl In ContextMCell.Controls
If ctrl.Tag = "My_Tag" Then
ctrl.Delete
End If
Next ctrl
For Each ctrl In ContextMTable.Controls
If ctrl.Tag = "My_Tag" Then
ctrl.Delete
End If
Next ctrl
End Sub
If interested, I can show you a method to identify all shortcut menus...
I have the following code that works fine for normal worksheets, but when I try to right click over a table the macro does not appear.
I have tried the below but getting "Object Required" error message on the first line:
With ContextMenuListRange.Controls.Add(Type:=msoControlButton, before:=2)
.OnAction = "'" & ThisWorkbook.Name & "'!" & "macro"
.Caption = "macro"
.Tag = "My_Cell_Control_Tag"
End With
The below works fine with a normal worksheet.
With ContextMenu.Controls.Add(Type:=msoControlButton, before:=2)
.OnAction = "'" & ThisWorkbook.Name & "'!" & "macro"
.Caption = "macro"
.Tag = "My_Cell_Control_Tag"
End With
How do I get to appear when right clicking over a table?
Try adding your button to the List Range Popup shortcut menu...
With Application.CommandBars("List Range Popup").Controls.Add(Type:=msoControlButton, before:=2)
.OnAction = "'" & ThisWorkbook.Name & "'!" & "macro"
.Caption = "macro"
.Tag = "My_Cell_Control_Tag"
End With
You can use the following macro to generate a list of all shortcut menus...
Sub ShowShortcutMenuNames()
Dim Row As Long
Dim cbar As CommandBar
Row = 1
For Each cbar In Application.CommandBars
If cbar.Type = 2 Then 'msoBarTypePopUp
Cells(Row, 1) = cbar.Index
Cells(Row, 2) = cbar.Name
Row = Row + 1
End If
Next cbar
End Sub
Hope this helps!
I have created an AddIn that utilizes an extensive menu system to call code based on the worksheet name the user is working in. Some of these worksheets are in different workbooks. All of the individual subs work, but I am having difficulty in figuring out why the menu (a button in the Ribbon triggers the menu code) only works once, then gives me a
Run-time error '5': Invalid procedure call or argument
The button triggers this code to run:
Sub CreateMasterMenu()
'
Select Case ActiveSheet.name
Case "BCM Hourly Comparison an": Call Extract_Initial_Save
Case "Daily Impacts Verification Step": Call Verification_Initial_Save
Case "Extract": Call Extract_Menu
Case "Swivel": Call Swivel_Menu
Case "Disputed": Call Disputed_Menu
Case "Verification": Call Verification_Menu
Case Else: MsgBox "There are no menu options available for this worksheet."
End Select
On Error Resume Next
Application.CommandBars(Menuname).ShowPopup
On Error GoTo 0
End Sub
This will call a popup menu based on the name of the active worksheet. When I first open the workbook and make a choice, it works as expected. But when I click on the button a second time to make another choice, I receive the RT error.
Sub Swivel_Menu()
'
Dim MenuItem As CommandBarPopup
With Application.CommandBars.Add(name:=Menuname, Position:=msoBarPopup, _
MenuBar:=False, Temporary:=True) 'This is where the debugger says the error is
With .Controls.Add(Type:=msoControlButton)
.Caption = "Hide Columns"
.FaceId = 1649
.OnAction = "'" & ThisWorkbook.name & "'!" & "Swivel_Hide_Columns"
End With
With .Controls.Add(Type:=msoControlButton)
.Caption = "Highlight & Copy Disputed"
.FaceId = 3881
.OnAction = "'" & ThisWorkbook.name & "'!" & "Swivel_HandC_Disputed"
End With
With .Controls.Add(Type:=msoControlButton)
.Caption = "Swivel Sheet Sort"
.FaceId = 706
.OnAction = "'" & ThisWorkbook.name & "'!" & "Swivel_Sheet_sort"
End With
With .Controls.Add(Type:=msoControlButton)
.Caption = "Unhide Columns"
.FaceId = 1650
.OnAction = "'" & ThisWorkbook.name & "'!" & "Swivel_Unhide_Columns"
End With
Set MenuItem = .Controls.Add(Type:=msoControlPopup)
With MenuItem
.Caption = "Swivel Tools"
With .Controls.Add(Type:=msoControlButton)
.Caption = "Remove Duplicates"
.FaceId = 2165
.OnAction = "'" & ThisWorkbook.name & "'!" & "Swivel_Remove_Duplicates"
End With
With .Controls.Add(Type:=msoControlButton)
.Caption = "Copy To Validate"
.FaceId = 731
.OnAction = "'" & ThisWorkbook.name & "'!" & "Swivel_Copy_To_Validate"
End With
With .Controls.Add(Type:=msoControlButton)
.Caption = "Not Available"
.FaceId = 463
.OnAction = "'" & ThisWorkbook.name & "'!" & "Menu_Construct_Msg"
End With
End With
End With
End Sub
I had this code running from a workbook and did not have this issue. It is pretty much copied into the add-in (with extra menu options added), but the code is the same.
Am I getting this error because I am running it from an add-in as opposed to running it from the workbook as before?
I have made a context menu in Excel which works great. I am just unsure how to add another menu after .Caption = "My Special Menu"
So I would like the context menu to appear like this.
My Special Menu > IT > Microsoft Office (then the 2 buttons)
Is this possible in a context menu?
Also is it possible to have another menu under Microsoft Office when you press IT to say Google Docs with buttons in those also?
Option Explicit
Public Const Mname As String = "MyPopUpMenu"
Sub DeletePopUpMenu()
' Delete the popup menu if it already exists.
On Error Resume Next
Application.CommandBars(Mname).Delete
On Error GoTo 0
End Sub
Sub CreateDisplayPopUpMenu()
' Delete any existing popup menu.
Call DeletePopUpMenu
' Create the popup menu.
Call Custom_PopUpMenu_1
' Display the popup menu.
On Error Resume Next
Application.CommandBars(Mname).ShowPopup
On Error GoTo 0
End Sub
Sub Custom_PopUpMenu_1()
Dim MenuItem As CommandBarPopup
' Add the popup menu.
With Application.CommandBars.Add(Name:=Mname, Position:=msoBarPopup, _
MenuBar:=False, Temporary:=True)
' add a menu that contains two buttons.
Set MenuItem = .Controls.Add(Type:=msoControlPopup)
With MenuItem
.Caption = "My Special Menu"
With .Controls.Add(Type:=msoControlButton)
.Caption = "Button 1 in menu"
.FaceId = 71
.OnAction = "'" & ThisWorkbook.Name & "'!" & ""
End With
With .Controls.Add(Type:=msoControlButton)
.Caption = "Button 2 in menu"
.FaceId = 72
.OnAction = "'" & ThisWorkbook.Name & "'!" & "T"
End With
End With
Try this
With MenuItem
.Caption = "My Special Menu"
With .Controls.Add(Type:=msoControlPopup, before:=1)
.Tag = "submenu1"
.Caption = "IT"
With .Controls.Add(Type:=msoControlPopup, before:=1)
.Tag = "Submenu2"
.Caption = "Microsoft Office!"
With .Controls.Add(Type:=msoControlButton, before:=1)
.Tag = "btn1"
.Caption = "Button 1 in menu"
.FaceId = 71
.OnAction = "'" & ThisWorkbook.Name & "'!" & ""
End With
With .Controls.Add(Type:=msoControlButton)
.Tag = "btn2"
.Caption = "Button 2 in menu"
.FaceId = 72
.OnAction = "'" & ThisWorkbook.Name & "'!" & "T"
End With
End With
End With
End With