├── .gitattributes ├── ContextMenu.png ├── LICENSE ├── README.md ├── UF_ContextualMenu.xlsm └── scripts ├── CTextBox_ContextMenu.cls ├── Module1.bas └── UserForm1.frm /.gitattributes: -------------------------------------------------------------------------------- 1 | # Auto detect text files and perform LF normalization 2 | * text=auto 3 | -------------------------------------------------------------------------------- /ContextMenu.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vbatools/UserForms-VBA-Context-Menu/7532291b14738b6745a9ce5faf11c50b39c50516/ContextMenu.png -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2021 VBATools 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # UserForms VBA Context Menu 2 | Add Context Menu For User Forms Text Box VBA 3 | https://youtu.be/mSKAK-qxskY 4 | [![Use Tools Macro Tools VBA](https://github.com/vbatools/UserForms-VBA-Context-Menu/blob/main/ContextMenu.png)](https://youtu.be/mSKAK-qxskY) 5 | -------------------------------------------------------------------------------- /UF_ContextualMenu.xlsm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vbatools/UserForms-VBA-Context-Menu/7532291b14738b6745a9ce5faf11c50b39c50516/UF_ContextualMenu.xlsm -------------------------------------------------------------------------------- /scripts/CTextBox_ContextMenu.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "CTextBox_ContextMenu" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = False 10 | '* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 11 | '* Module : CTextBox_ContextMenu 12 | '* Created : 11-04-2021 11:00 13 | '* Author : VBATools 14 | '* Contacts : http://vbatools.ru/ https://vk.com/vbatools 15 | '* Copyright : VBATools.ru 16 | '* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 17 | Option Explicit 18 | 19 | Private Const mEDIT_CONTEXTMENU_NAME = "ajpiEditContextMenu" 20 | Private Const mCUT_TAG = "CUT" 21 | Private Const mCOPY_TAG = "COPY" 22 | Private Const mPASTE_TAG = "PASTE" 23 | 24 | Private m_cbrContextMenu As CommandBar 25 | Private WithEvents m_txtTBox As msforms.TextBox 26 | Attribute m_txtTBox.VB_VarHelpID = -1 27 | Private WithEvents m_cbtCut As CommandBarButton 28 | Attribute m_cbtCut.VB_VarHelpID = -1 29 | Private WithEvents m_cbtCopy As CommandBarButton 30 | Attribute m_cbtCopy.VB_VarHelpID = -1 31 | Private WithEvents m_cbtPaste As CommandBarButton 32 | Attribute m_cbtPaste.VB_VarHelpID = -1 33 | Private m_objDataObject As DataObject 34 | Private m_objParent As Object 35 | 36 | 37 | 38 | Private Function m_CreateEditContextMenu() As CommandBar 39 | ' 40 | ' Build Context menu controls. 41 | ' 42 | Dim cbrTemp As CommandBar 43 | Const CUT_MENUID = 21 44 | Const COPY_MENUID = 19 45 | Const PASTE_MENUID = 22 46 | 47 | Set cbrTemp = Application.CommandBars.Add(mEDIT_CONTEXTMENU_NAME, Position:=msoBarPopup) 48 | With cbrTemp 49 | With .Controls.Add(msoControlButton) 50 | .Caption = "Cu&t" 51 | .FaceId = CUT_MENUID 52 | .Tag = mCUT_TAG 53 | End With 54 | With .Controls.Add(msoControlButton) 55 | .Caption = "&Copy" 56 | .FaceId = COPY_MENUID 57 | .Tag = mCOPY_TAG 58 | End With 59 | With .Controls.Add(msoControlButton) 60 | .Caption = "&Paste" 61 | .FaceId = PASTE_MENUID 62 | .Tag = mPASTE_TAG 63 | End With 64 | End With 65 | 66 | Set m_CreateEditContextMenu = cbrTemp 67 | 68 | End Function 69 | Private Sub m_DestroyEditContextMenu() 70 | On Error Resume Next 71 | Application.CommandBars(mEDIT_CONTEXTMENU_NAME).Delete 72 | Exit Sub 73 | End Sub 74 | Private Function m_GetEditContextMenu() As CommandBar 75 | 76 | On Error Resume Next 77 | 78 | Set m_GetEditContextMenu = Application.CommandBars(mEDIT_CONTEXTMENU_NAME) 79 | If m_GetEditContextMenu Is Nothing Then 80 | Set m_GetEditContextMenu = m_CreateEditContextMenu 81 | End If 82 | 83 | Exit Function 84 | 85 | End Function 86 | 87 | Private Function m_ActiveTextbox() As Boolean 88 | ' 89 | ' Make sure this instance is connected to active control 90 | ' May need to drill down through container controls to 91 | ' reach ActiveControl object 92 | ' 93 | Dim objCtl As Object 94 | 95 | Set objCtl = m_objParent.ActiveControl 96 | Do While UCase(TypeName(objCtl)) <> "TEXTBOX" 97 | If UCase(TypeName(objCtl)) = "MULTIPAGE" Then 98 | Set objCtl = objCtl.Pages(objCtl.Value).ActiveControl 99 | Else 100 | Set objCtl = objCtl.ActiveControl 101 | End If 102 | Loop 103 | m_ActiveTextbox = (StrComp(objCtl.Name, m_txtTBox.Name, vbTextCompare) = 0) 104 | 105 | ErrActivetextbox: 106 | Exit Function 107 | 108 | End Function 109 | 110 | Public Property Set Parent(RHS As Object) 111 | Set m_objParent = RHS 112 | End Property 113 | 114 | Private Sub m_UseMenu() 115 | 116 | Dim lngIndex As Long 117 | 118 | For lngIndex = 1 To m_cbrContextMenu.Controls.Count 119 | Select Case m_cbrContextMenu.Controls(lngIndex).Tag 120 | Case mCUT_TAG 121 | Set m_cbtCut = m_cbrContextMenu.Controls(lngIndex) 122 | Case mCOPY_TAG 123 | Set m_cbtCopy = m_cbrContextMenu.Controls(lngIndex) 124 | Case mPASTE_TAG 125 | Set m_cbtPaste = m_cbrContextMenu.Controls(lngIndex) 126 | End Select 127 | Next 128 | 129 | End Sub 130 | Public Property Set TBox(RHS As msforms.TextBox) 131 | Set m_txtTBox = RHS 132 | End Property 133 | 134 | 135 | Private Sub Class_Initialize() 136 | 137 | Set m_objDataObject = New DataObject 138 | Set m_cbrContextMenu = m_GetEditContextMenu 139 | 140 | If Not m_cbrContextMenu Is Nothing Then 141 | m_UseMenu 142 | End If 143 | 144 | End Sub 145 | 146 | Private Sub Class_Terminate() 147 | 148 | Set m_objDataObject = Nothing 149 | m_DestroyEditContextMenu 150 | 151 | End Sub 152 | 153 | 154 | Private Sub m_cbtCopy_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean) 155 | 156 | ' check active textbox is this instance of CTextBox_ContextMenu 157 | If m_ActiveTextbox() Then 158 | With m_objDataObject 159 | .Clear 160 | .SetText m_txtTBox.SelText 161 | .PutInClipboard 162 | End With 163 | End If 164 | 165 | End Sub 166 | 167 | Private Sub m_cbtCut_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean) 168 | 169 | ' check active textbox is this instance of CTextBox_ContextMenu 170 | If m_ActiveTextbox() Then 171 | With m_objDataObject 172 | .Clear 173 | .SetText m_txtTBox.SelText 174 | .PutInClipboard 175 | m_txtTBox.SelText = vbNullString 176 | End With 177 | End If 178 | 179 | End Sub 180 | 181 | 182 | Private Sub m_cbtPaste_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean) 183 | 184 | ' check active textbox is this instance of CTextBox_ContextMenu 185 | On Error GoTo ErrPaste 186 | 187 | If m_ActiveTextbox() Then 188 | With m_objDataObject 189 | .GetFromClipboard 190 | m_txtTBox.SelText = .GetText 191 | End With 192 | End If 193 | 194 | ErrPaste: 195 | Exit Sub 196 | End Sub 197 | 198 | 199 | Private Sub m_txtTBox_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) 200 | 201 | If Button = 2 Then 202 | ' right click 203 | m_cbrContextMenu.ShowPopup 204 | End If 205 | 206 | End Sub 207 | 208 | 209 | -------------------------------------------------------------------------------- /scripts/Module1.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "Module1" 2 | '* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 3 | '* Module : Module1 4 | '* Created : 11-04-2021 11:00 5 | '* Author : VBATools 6 | '* Contacts : http://vbatools.ru/ https://vk.com/vbatools 7 | '* Copyright : VBATools.ru 8 | '* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 9 | Option Explicit 10 | 11 | Sub Main() 12 | 13 | UserForm1.Show 14 | 15 | End Sub 16 | -------------------------------------------------------------------------------- /scripts/UserForm1.frm: -------------------------------------------------------------------------------- 1 | VERSION 5.00 2 | Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} UserForm1 3 | Caption = "Textbox Contextual Menus" 4 | ClientHeight = 6180 5 | ClientLeft = 45 6 | ClientTop = 390 7 | ClientWidth = 5790 8 | OleObjectBlob = "UserForm1.frx":0000 9 | ShowModal = 0 'False 10 | StartUpPosition = 1 'CenterOwner 11 | End 12 | Attribute VB_Name = "UserForm1" 13 | Attribute VB_GlobalNameSpace = False 14 | Attribute VB_Creatable = False 15 | Attribute VB_PredeclaredId = True 16 | Attribute VB_Exposed = False 17 | '* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 18 | '* Module : UserForm1 19 | '* Created : 11-04-2021 11:00 20 | '* Author : VBATools 21 | '* Contacts : http://vbatools.ru/ https://vk.com/vbatools 22 | '* Copyright : VBATools.ru 23 | '* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 24 | Option Explicit 25 | 26 | Private m_colContextMenus As Collection 27 | 28 | Private Sub CommandButton1_Click() 29 | Unload Me 30 | End Sub 31 | 32 | Private Sub UserForm_Initialize() 33 | 34 | Dim clsContextMenu As CTextBox_ContextMenu 35 | 36 | Set m_colContextMenus = New Collection 37 | 38 | Set clsContextMenu = New CTextBox_ContextMenu 39 | With clsContextMenu 40 | Set .TBox = UserForm1.TextBox1 41 | Set .Parent = Me 42 | End With 43 | m_colContextMenus.Add clsContextMenu, CStr(m_colContextMenus.Count + 1) 44 | 45 | Set clsContextMenu = New CTextBox_ContextMenu 46 | With clsContextMenu 47 | Set .TBox = UserForm1.TextBox2 48 | Set .Parent = Me 49 | End With 50 | m_colContextMenus.Add clsContextMenu, CStr(m_colContextMenus.Count + 1) 51 | 52 | Set clsContextMenu = New CTextBox_ContextMenu 53 | With clsContextMenu 54 | Set .TBox = UserForm1.TextBox3 55 | Set .Parent = Me 56 | End With 57 | m_colContextMenus.Add clsContextMenu, CStr(m_colContextMenus.Count + 1) 58 | 59 | Set clsContextMenu = New CTextBox_ContextMenu 60 | With clsContextMenu 61 | Set .TBox = UserForm1.TextBox4 62 | Set .Parent = Me 63 | End With 64 | m_colContextMenus.Add clsContextMenu, CStr(m_colContextMenus.Count + 1) 65 | 66 | Set clsContextMenu = New CTextBox_ContextMenu 67 | With clsContextMenu 68 | Set .TBox = UserForm1.TextBox5 69 | Set .Parent = Me 70 | End With 71 | m_colContextMenus.Add clsContextMenu, CStr(m_colContextMenus.Count + 1) 72 | 73 | End Sub 74 | 75 | Private Sub UserForm_Terminate() 76 | 77 | Do While m_colContextMenus.Count > 0 78 | m_colContextMenus.Remove m_colContextMenus.Count 79 | Loop 80 | Set m_colContextMenus = Nothing 81 | 82 | End Sub 83 | 84 | 85 | --------------------------------------------------------------------------------