Go Back  Xtreme Visual Basic Talk > Legacy Visual Basic (VB 4/5/6) > VBA / Office Integration > Excel > Excel VBA Right Click Context Menu


Reply
 
Thread Tools Display Modes
  #1  
Old 05-24-2009, 11:51 AM
Josh Hazel Josh Hazel is offline
Senior Contributor
 
Join Date: May 2008
Posts: 805
Default Excel VBA Right Click Context Menu


Anyone know how to create a context menu appear on a textbox, I would like to have the user be able to Cut/Copy/Paste text from this context menu.
__________________
Josh

If Google = NoHelp Then PostHere = True
Reply With Quote
  #2  
Old 05-25-2009, 10:08 AM
JSTKwan JSTKwan is offline
Centurion
 
Join Date: Mar 2007
Posts: 122
Default

This is what I have, taylor it as you like:
Code:
Option Explicit
'This code would add a menu in the right click popup menu and adds sub menus
Sub AddMenu()
    Dim cbcCalc As CommandBarControl
    Dim cbar As CommandBar
    ResetMenu

    For Each cbar In Application.CommandBars
        Select Case cbar.Controls.Parent.Name
            Case "Cell", "Row", "Column": GoTo AddSpreadsheetMenu
            Case Else: GoTo NoMenu1
        End Select
AddSpreadsheetMenu:
        With cbar.Controls.Add(Type:=msoControlPopup)
            .Caption = "Spread Sheet"
            .BeginGroup = True
            With .Controls.Add(Type:=msoControlButton)
                .Caption = "Sort Sheet Tabs"
                .FaceId = 1826
                .OnAction = "SpreadSheet.SortSheets"
            End With
            With .Controls.Add(Type:=msoControlButton)
                .Caption = "Convert to Numbers"
                .FaceId = 4026
                .OnAction = "SpreadSheet.ConvertToNumbers"
            End With
            With .Controls.Add(Type:=msoControlButton)
                .Caption = "Convert to Date"
                .FaceId = 1096
                .OnAction = "SpreadSheet.ConvertToDate"
                .style = msoButtonIconAndCaption
            End With
            With .Controls.Add(Type:=msoControlButton)
                .Caption = "Delete Spaces"
                .FaceId = 303
                .OnAction = "SpreadSheet.DeleteSpaces"
            End With
            With .Controls.Add(Type:=msoControlButton)
                .Caption = "Reverse Copy"
                .FaceId = 38
                .OnAction = "SpreadSheet.ReverseCopy"
            End With
            With .Controls.Add(Type:=msoControlButton)
                .Caption = "Export Selection To File"
                .FaceId = 565
                .OnAction = "SpreadSheet.ExportSelectionToFile"
            End With
            With .Controls.Add(Type:=msoControlButton)
                .Caption = "Show Hide Column Menu"
                .FaceId = 640
                .OnAction = "SpreadSheet.ShowHide"
            End With
            With .Controls.Add(Type:=msoControlButton)
                .Caption = "Sheet Tab Navigator"
                .FaceId = 366
                .OnAction = "SpreadSheet.BuildSheetNavigator"
            End With
            With .Controls.Add(Type:=msoControlButton)
                .Caption = "Add Work Sheet"
                .FaceId = 8
                .OnAction = "SpreadSheet.AddWorkSheet"
            End With
            With .Controls.Add(Type:=msoControlButton)
                .Caption = "Delete Empty Rows"
                .FaceId = 478
                .OnAction = "SpreadSheet.DeleteEmptyRows"
            End With
            With .Controls.Add(Type:=msoControlButton)
                .Caption = "Create Hyperlink Files"
                .FaceId = 2093
                .OnAction = "SpreadSheet.HyperlinkFileList"
            End With
            
            ' "Work With Duplicates" right click menu
            With cbar.Controls.Add(Type:=msoControlPopup)
                .Caption = "Work With Duplicates"
                .BeginGroup = True
                With .Controls.Add(Type:=msoControlButton)
                    .Caption = "HiLite Duplicates Using One Column"
                    .FaceId = 1670
                    .OnAction = "SpreadSheet.HiLiteDuplicates"
                End With
                With .Controls.Add(Type:=msoControlButton)
                    .Caption = "HiLite Duplicates Using One Column with Input"
                    .FaceId = 1670
                    .OnAction = "SpreadSheet.HiLiteDuplicates1"
                End With
                With .Controls.Add(Type:=msoControlButton)
                    .Caption = "HiLite Duplicates Using Two Columns (A and B)"
                    .FaceId = 1670
                    .OnAction = "SpreadSheet.HiLiteDuplicates2"
                End With
                With .Controls.Add(Type:=msoControlButton)
                    .Caption = "HiLite Duplicates Using Selection"
                    .FaceId = 1670
                    .OnAction = "SpreadSheet.HiLiteDuplicatesUsingSelection"
                End With
                With .Controls.Add(Type:=msoControlButton)
                    .Caption = "List Unique Values in a list"
                    .FaceId = 1670
                    .OnAction = "modDistinct.ListUniqueValues"
                End With
            End With
        End With

        ' PPOA right click menu
        With cbar.Controls.Add(Type:=msoControlPopup)
            .Caption = "PPOA"
            .BeginGroup = True
            With .Controls.Add(Type:=msoControlButton)
                .Caption = "PPOA Actual Prices"
                .FaceId = 346
                .OnAction = "PPOA.PPOAActualPrices"
                .style = msoButtonIconAndCaption
            End With
            With .Controls.Add(Type:=msoControlButton)
                .Caption = "PPOA Daily Average Prices"
                .FaceId = 346
                .OnAction = "PPOA.PPOADailyAveragePrices"
                .style = msoButtonIconAndCaption
            End With
            With .Controls.Add(Type:=msoControlButton)
                .Caption = "PPOA SMP Prices"
                .FaceId = 346
                .OnAction = "PPOA.PPOASMPPrices"
                .style = msoButtonIconAndCaption
            End With
            With .Controls.Add(Type:=msoControlButton)
                .Caption = "PPOA Weekly Averages"
                .FaceId = 346
                .OnAction = "PPOA.PPOAWeeklyAverages"
                .style = msoButtonIconAndCaption
            End With
        End With

        ' Utilities right click menu
        With cbar.Controls.Add(Type:=msoControlPopup)
            .Caption = "Utilities"
            .BeginGroup = True
            With .Controls.Add(Type:=msoControlButton)
                .Caption = "Search VBA Codes"
                .FaceId = 583
                .OnAction = "modUtil.SearchVBA"
                .style = msoButtonIconAndCaption
            End With
            With .Controls.Add(Type:=msoControlButton)
                .Caption = "List Directories and Files"
                .FaceId = 620
                .OnAction = "modUtil.ListDirectories"
                .style = msoButtonIconAndCaption
            End With
        End With
NoMenu1:
    Next cbar


    ' Adding Workbook is needed because that State is not set until there is
    ' a Workbook.
    Workbooks.Add
    Set cbcCalc = Application.CommandBars("Data").Controls.Add(Type:=msoControlButton)
    With cbcCalc
        .OnAction = "CalcMode"
        .Caption = "Calculation Automatic"
        .BeginGroup = True
        .State = (Application.Calculation = xlCalculationAutomatic)
    End With
End Sub
'This code would Reset the right click popup menu
Sub ResetMenu()
    Dim PopupControl As Long
    Dim PopupText As String
    Dim PopupMenu As Long
    
'   This will reset the whole menu
'   Application.CommandBars("Cell").Reset

    ' I know that I need to delete 2 Popup Menus
    On Error Resume Next
'    For PopupMenu = 1 To 2
'        For PopupControl = 1 To Application.CommandBars("cell").Controls.Count
'            PopupText = Application.CommandBars("cell").Controls.Item(PopupControl).Caption
'            Select Case PopupText
'                Case "PPOA", "Spread Sheet"
'                    Application.CommandBars("cell").Controls.Item(PopupControl).Delete
'            End Select
'        Next PopupControl
'    Next PopupMenu

    ResetMenu1
    
    ' Delete Calclation from the Data menu
    For PopupControl = 1 To Application.CommandBars("Data").Controls.Count
        PopupText = Application.CommandBars("Data").Controls.Item(PopupControl).Caption
        Select Case PopupText
        Case "Calculation Automatic"
            Application.CommandBars("Data").Controls.Item(PopupControl).Delete
        End Select
    Next PopupControl
End Sub
Sub ResetMenu1()
    On Error Resume Next
    Application.CommandBars("Cell").Controls("Spread Sheet").Delete
    Application.CommandBars("Row").Controls("Spread Sheet").Delete
    Application.CommandBars("Column").Controls("Spread Sheet").Delete
    
    Application.CommandBars("Cell").Controls("Work With Duplicates").Delete
    Application.CommandBars("Row").Controls("Work With Duplicates").Delete
    Application.CommandBars("Column").Controls("Work With Duplicates").Delete
    
    Application.CommandBars("Cell").Controls("PPOA").Delete
    Application.CommandBars("Row").Controls("PPOA").Delete
    Application.CommandBars("Column").Controls("PPOA").Delete

    Application.CommandBars("Cell").Controls("Utilities").Delete
    Application.CommandBars("Row").Controls("Utilities").Delete
    Application.CommandBars("Column").Controls("Utilities").Delete
End Sub
Sub CalcMode()
'
' Toggle Calculation mode between Auto and Manual
'
    With Application.CommandBars.ActionControl
        If Application.Calculation = xlCalculationAutomatic Then
            .State = msoButtonUp
            Application.Calculation = xlCalculationManual
        ElseIf Application.Calculation = xlCalculationManual Then
            .State = msoButtonDown
            Application.Calculation = xlCalculationAutomatic
        End If
    End With
End Sub
Reply With Quote
  #3  
Old 05-26-2009, 06:28 PM
Josh Hazel Josh Hazel is offline
Senior Contributor
 
Join Date: May 2008
Posts: 805
Default

That seems to create a context menu in the spreadsheet, I need one on a userform textbox. When I right click on a userform textbox i want cut/copy/paste/ options
__________________
Josh

If Google = NoHelp Then PostHere = True
Reply With Quote
  #4  
Old 05-27-2009, 08:09 AM
JSTKwan JSTKwan is offline
Centurion
 
Join Date: Mar 2007
Posts: 122
Default

OK, try this. I cannot take credit for this, found it on WWW and modified it to use with a userform
form code
Code:
Private Sub TextBox1_GotFocus()
    Set ctl = TextBox1
End Sub

Private Sub TextBox1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If Button = vbKeyRButton Then Call ShowTextMenu
End Sub


Sub ShowTextMenu()
    Call MakeMenu
    Application.CommandBars("TextBox Bar").ShowPopup
End Sub

Sub MakeMenu()

    On Error Resume Next
    CommandBars("TextBox Bar").Delete
    On Error GoTo 0

    Dim cbTextBox As CommandBar
    Dim cmdTest As CommandBarButton

    Set cbTextBox = Application.CommandBars.Add(Name:="TextBox Bar", Position:=msoBarPopup, Temporary:=True)

    With cbTextBox
        For b = 1 To 5
            Set cmdTest = .Controls.Add(Type:=msoControlButton, Temporary:=True)
            With cmdTest
                .Style = msoButtonIconAndCaption
                .Parameter = b
                Select Case b
                    Case 1
                        .FaceId = 21
                        .Caption = "Cut"
                    Case 2
                        .FaceId = 19
                        .Caption = "Copy"
                    Case 3
                        .FaceId = 22
                        .Caption = "Paste"
                    Case 4
                        .Caption = "Delete"
                    Case 5
                        .Caption = "Select All"
                End Select
                .OnAction = "TextMenu"
            End With
        Next b
    End With

End Sub
module code
Code:
Public txtData As DataObject
Public ctl As Object

Public Sub TextMenu()

    Dim ctlCBarControl As CommandBarControl
    Dim i As Integer
    Dim s As Long

    Set ctlCBarControl = CommandBars.ActionControl
    If ctlCBarControl Is Nothing Then Exit Sub
    i = CInt(ctlCBarControl.Parameter)

    With UserForm1
        Select Case i
            Case 1, 2
                Set txtData = New DataObject
                txtData.SetText .TextBox1.SelText
                txtData.PutInClipboard
                If i = 1 Then
                    s = .TextBox1.SelStart
                    .TextBox1 = Left(.TextBox1, .TextBox1.SelStart) & _
                                Mid(.TextBox1, .TextBox1.SelStart + _
                                .TextBox1.SelLength + 1)
                    .TextBox1.SelStart = s
                End If
            Case 3
                .TextBox1.Paste
            Case 4
                s = .TextBox1.SelStart
                .TextBox1 = Left(.TextBox1, .TextBox1.SelStart) & _
                            Mid(.TextBox1, .TextBox1.SelStart + _
                            .TextBox1.SelLength + 1)
                .TextBox1.SelStart = s
            Case 5
                .TextBox1.SelStart = 0
                .TextBox1.SelLength = Len(.TextBox1)
        End Select
    End With
End Sub
Reply With Quote
  #5  
Old 05-28-2009, 01:45 AM
Josh Hazel Josh Hazel is offline
Senior Contributor
 
Join Date: May 2008
Posts: 805
Default

That is brilliant, thanks for finding the code!
__________________
Josh

If Google = NoHelp Then PostHere = True
Reply With Quote
  #6  
Old 08-19-2010, 04:17 PM
Josh Hazel Josh Hazel is offline
Senior Contributor
 
Join Date: May 2008
Posts: 805
Default

New question!!

I am wondering, i am trying to modify this so that I can specify WHAT textbox to display the menu on... right now its Userform1 and Textbox1, but I am wondering how can I modify this to pass a variable with the reference to the actual textbox?

What I am trying to achieve is not to have to copy and paste this code a hundred times for a hundred different textboxes, instead just specify at the function level the textbox to use ...
__________________
Josh

If Google = NoHelp Then PostHere = True
Reply With Quote
  #7  
Old 08-19-2010, 05:31 PM
Josh Hazel Josh Hazel is offline
Senior Contributor
 
Join Date: May 2008
Posts: 805
Default

I got it to work by creating a public object, setting the object then running the code and the code references instead of Userform1 and Textbox1 it references the public object - if someone has a better solution let me know
__________________
Josh

If Google = NoHelp Then PostHere = True
Reply With Quote
  #8  
Old 08-27-2010, 04:43 AM
danik danik is offline
Newcomer
 
Join Date: Aug 2010
Posts: 1
Default

Hi josh

I noticed this thread as i needed to add a copy and paste feature into my vba forms. However as i am pretty new to vba i am not quite sure how you have implemented this code without having to have copy and paste this code hundereds of time for each text box. Could you please explain how you achieved this with a public object etc?

Cheers

Nick
Reply With Quote
  #9  
Old 08-27-2010, 08:00 PM
Josh Hazel Josh Hazel is offline
Senior Contributor
 
Join Date: May 2008
Posts: 805
Default

I will add some comments for you...

Code:
'I deleted all this here:   
'Private Sub TextBox1_GotFocus()
'    Set ctl = TextBox1
'End Sub

Private Sub TextBox1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If Button = vbKeyRButton Then 
          Set RightClickObj = Form1.TextBox1 'I just added this line to set which object I wanted to refer to, also include the FORM name!!! 
          'I changed this:  Call ShowTextMenu
          Call MakeMenu 'To this since no reason to have so many subs
         Application.CommandBars("TextBox Bar").ShowPopup 'I also moved this from the ShowTextMenu to here:
    End If
End Sub

'Don need this anymore
'Sub ShowTextMenu()
'    Call MakeMenu
'    Application.CommandBars("TextBox Bar").ShowPopup
'End Sub

'I like to use Modules to separate code, so I moved this to Module1 and then in module 1 declare a public variable, so that any other form or module can access it, do like this:
Dim RightClickObj  as object 'This way i can use it for comboboxes etc too
Sub MakeMenu()

    On Error Resume Next
    CommandBars("TextBox Bar").Delete
    On Error GoTo 0

    Dim cbTextBox As CommandBar
    Dim cmdTest As CommandBarButton

    Set cbTextBox = Application.CommandBars.Add(Name:="TextBox Bar", Position:=msoBarPopup, Temporary:=True)

    With cbTextBox
        For b = 1 To 5
            Set cmdTest = .Controls.Add(Type:=msoControlButton, Temporary:=True)
            With cmdTest
                .Style = msoButtonIconAndCaption
                .Parameter = b
                Select Case b
                    Case 1
                        .FaceId = 21
                        .Caption = "Cut"
                    Case 2
                        .FaceId = 19
                        .Caption = "Copy"
                    Case 3
                        .FaceId = 22
                        .Caption = "Paste"
                    Case 4
                        .Caption = "Delete"
                    Case 5
                        .Caption = "Select All"
                End Select
                .OnAction = "TextMenu"
            End With
        Next b
    End With

End Sub
module code
Code:
'The code above i said I moved it right here:

Public txtData As DataObject
'Public ctl As Object This you dont need if we use the Public RightClickObj 

Public Sub TextMenu()

    Dim ctlCBarControl As CommandBarControl
    Dim i As Integer
    Dim s As Long

    Set ctlCBarControl = CommandBars.ActionControl
    If ctlCBarControl Is Nothing Then Exit Sub
    i = CInt(ctlCBarControl.Parameter)

'    With UserForm1  'You wont need this line anymore 
        Select Case i
            Case 1, 2
                Set txtData = New DataObject
                txtData.SetText .TextBox1.SelText
                txtData.PutInClipboard
                If i = 1 Then
                    s = .TextBox1.SelStart
                    'Starting from here, you just use the Ctrl-H to do a find and replace all, and replace all the references to ".TextBox1"  with RightClickObj 
                    .TextBox1 = Left(.TextBox1, .TextBox1.SelStart) & _
                                Mid(.TextBox1, .TextBox1.SelStart + _
                                .TextBox1.SelLength + 1)
                    .TextBox1.SelStart = s
                End If
            Case 3
                .TextBox1.Paste
            Case 4
                s = .TextBox1.SelStart
                .TextBox1 = Left(.TextBox1, .TextBox1.SelStart) & _
                            Mid(.TextBox1, .TextBox1.SelStart + _
                            .TextBox1.SelLength + 1)
                .TextBox1.SelStart = s
            Case 5
                .TextBox1.SelStart = 0
                .TextBox1.SelLength = Len(.TextBox1)
        End Select
    End With  'You wont need this line anymore 
End Sub
So All I did was created a Public <name> as Object, then when user right clicks on the control (in your case the textbox) it sets the Public Object as that control... then you run the Make Menu which creates what the menu is going to look like and also in the TextMenu update all the references to Userform1 and .Textbox1 with that of your object (Public <Name> Object, in our case RightClickObj) and that way it knows which textbox or control to use

This means the only thing you need to copy/paste from one textbox to the next is the _MouseUp() event, it will be the only one that you duplicate and they will all refer back to the code in the module, so they share the module code

Another quick note, I replaced all the .Parameters with .Tags so that I could actually reference them using names - makes it easier to code for me. Honestly dont know what .Parameters is for, I couldnt figure that out. But it works.
__________________
Josh

If Google = NoHelp Then PostHere = True
Reply With Quote
Reply


Currently Active Users Viewing This Thread: 1 (0 members and 1 guests)
 
Thread Tools
Display Modes

Posting Rules
You may not post new threads
You may not post replies
You may not post attachments
You may not edit your posts

BB code is On
Smilies are On
[IMG] code is Off
HTML code is Off

Forum Jump

Advertisement:





Free Publications
The ASP.NET 2.0 Anthology
101 Essential Tips, Tricks & Hacks - Free 156 Page Preview. Learn the most practical features and best approaches for ASP.NET.
subscribe
Programmers Heaven C# School Book -Free 338 Page eBook
The Programmers Heaven C# School book covers the .NET framework and the C# language.
subscribe
Build Your Own ASP.NET 3.5 Web Site Using C# & VB, 3rd Edition - Free 219 Page Preview!
This comprehensive step-by-step guide will help get your database-driven ASP.NET web site up and running in no time..
subscribe
 
 
-->