Pages

Thursday, August 23, 2012

Add a new pop up button on mouse right click menu and assign macro to it.

If you want to add a new pop up button on mouse right click menu and as soon as you click on it . It shows you multiple buttons with macro assigned on each button.  Snapshot below - 


Here is the code- 

Add below code to workbook open module -

Private Sub Workbook_Open()
    On Error Resume Next
    'Delete the new button if already exists
    ' name of the new button is "New Button"
    Application.CommandBars("Cell").Controls("New Button").Delete
    'run a macro to add a new button on mouse right click
    Call add_new_button
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    On Error Resume Next
    ' delete the btton when workbook is closed.
    ' name of the new button is "New Button"
    Application.CommandBars("Cell").Controls("New Button").Delete
End Sub


Add below code to module1 or any new module
Option Explicit
Sub add_new_button()
    
    ' macro to add new button with name "New Button"
    Dim cBut        As CommandBarControl
    On Error Resume Next
    ' name of the new button "New Button"
    Application.CommandBars("Cell").Controls("New Button").Delete
    
    Set cBut = Application.CommandBars("Cell").Controls.Add(Type:=msoControlPopup, Temporary:=True)
    ' If you want to show the button at the top use
    'Set cBut = Application.CommandBars("Cell").Controls.Add(Type:=msoControlPopup, before:=1, Temporary:=True)
    
    
    ' name of the new button is "New Button"
    cBut.Caption = "New Button"
    ' name of macro which you want to run when u will click on it
    cBut.OnAction = "new_button_macro"
    
End Sub


Sub new_button_macro()

    Dim cbut2 As CommandBarControl
    Dim cmda As CommandBarControl
    Dim i As Integer
    Dim but_nms As Variant
    Dim but_macros As Variant
    Dim but_ids As Variant
    
    ' button names
    but_nms = Array("Button 1", "Button 2", "Button 3")
    ' macro names
    but_macros = Array("Button_m_1", "Button_m_2", "Button_m_3")
      ' macro names
    but_ids = Array(481, 483, 482)
    
    
    ' delete all exisitng buttons if any added on "New Button"
    For Each cmda In Application.CommandBars("Cell").Controls("New Button").Controls
        On Error Resume Next
        cmda.Delete
    Next
    
    ' run a loop and add new buttons further on  "New Button"
    For i = LBound(but_nms) To UBound(but_nms)
        Set cbut2 = Application.CommandBars("Cell").Controls("New Button").Controls.Add(Type:=msoControlButton)
        With cbut2
        'button name
        .Caption = but_nms(i)
        ' macro to be assigned on button
        .OnAction = but_macros(i)
        ' chnage the shape of face
        .FaceId = but_ids(i)
        End With
    Next
    
End Sub


Sub Button_m_1()
MsgBox "You have clicked " & Application.CommandBars.ActionControl.Caption
End Sub
Sub Button_m_2()
MsgBox "You have clicked " & Application.CommandBars.ActionControl.Caption
End Sub
Sub Button_m_3()
MsgBox "You have clicked " & Application.CommandBars.ActionControl.Caption
End Sub


Download working Macro   https://www.box.com/s/50e0d0f6943ef9b42698


No comments:

Post a Comment