Copy and Paste to a user form

Option Explicit

Private HoldReferences As Collection

Private Sub UserForm_Initialize()
 Dim c As Control, Rccm As RightClickContextMenu
 
 Set HoldReferences = New Collection

 For Each c In Me.Controls
 If TypeName(c) = "TextBox" Then
 Set Rccm = New RightClickContextMenu
 Call Rccm.SetUp(Me, c)
 HoldReferences.Add Rccm
 End If
 Next
End Sub

Option Explicit

'http://word.mvps.org/FAQS/Userforms/AddRightClickMenu.htm

' Required API declarations
Private Declare Function CreatePopupMenu Lib "user32" () As Long
Private Declare Function InsertMenuItem Lib "user32" Alias "InsertMenuItemA" (ByVal hMenu As Long, ByVal un As Long, ByVal bool As Boolean, ByRef lpcMenuItemInfo As MENUITEMINFO) As Long
Private Declare Function TrackPopupMenu Lib "user32" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal X As Long, ByVal Y As Long, ByVal nReserved As Long, ByVal hwnd As Long, lprc As RECT) As Long
Private Declare Function DestroyMenu Lib "user32" (ByVal hMenu As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long

' Type required by TrackPopupMenu although this is ignored !!
Private Type RECT
 Left As Long
 Top As Long
 Right As Long
 Bottom As Long
End Type

' Type required by InsertMenuItem
Private Type MENUITEMINFO
 cbSize As Long
 fMask As Long
 fType As Long
 fState As Long
 wID As Long
 hSubMenu As Long
 hbmpChecked As Long
 hbmpUnchecked As Long
 dwItemData As Long
 dwTypeData As String
 cch As Long
End Type

' Type required by GetCursorPos
Private Type POINTAPI
 X As Long
 Y As Long
End Type

' Constants required by TrackPopupMenu
Private Const TPM_LEFTALIGN = &H0&
Private Const TPM_TOPALIGN = &H0
Private Const TPM_RETURNCMD = &H100
Private Const TPM_RIGHTBUTTON = &H2&

' Constants required by MENUITEMINFO type
Private Const MIIM_STATE = &H1
Private Const MIIM_ID = &H2
Private Const MIIM_TYPE = &H10
Private Const MFT_STRING = &H0
Private Const MFT_SEPARATOR = &H800
Private Const MFS_DEFAULT = &H1000
Private Const MFS_ENABLED = &H0
Private Const MFS_GRAYED = &H1

' Contants defined by me for menu item IDs
Private Const ID_Cut = 101
Private Const ID_Copy = 102
Private Const ID_Paste = 103
Private Const ID_Delete = 104
Private Const ID_SelectAll = 105


' Variables declared at module level
Private FormCaption As String
Private Cut_Enabled As Long
Private Copy_Enabled As Long
Private Paste_Enabled As Long
Private Delete_Enabled As Long
Private SelectAll_Enabled As Long



Public Sub ShowPopup(oControl As msforms.TextBox, oForm As UserForm, strCaption As String, X As Single, Y As Single)

 Static click_flag As Long

 ' The following is required because the MouseDown event
 ' fires twice when right-clicked !!
 click_flag = click_flag + 1

 ' Do nothing on first firing of MouseDown event
 If (click_flag Mod 2 <> 0) Then Exit Sub

 ' Set object reference to the textboxthat was clicked
 'Set oControl = oForm.ActiveControl

 ' If click is outside the textbox, do nothing
 If X > oControl.Width Or Y > oControl.Height Or X < 0 Or Y < 0 Then Exit Sub

 ' Retrieve caption of UserForm for use in FindWindow API
 FormCaption = strCaption

 ' Call routine that sets menu items as enabled/disabled
 Call EnableMenuItems(oControl, oForm)

 ' Call function that shows the menu and return the ID
 ' of the selected menu item. Subsequent action depends
 ' on the returned ID.
 Select Case GetSelection()
 Case ID_Cut
 oControl.Cut
 Case ID_Copy
 oControl.Copy
 Case ID_Paste
 oControl.Paste
 Case ID_Delete
 oControl.SelText = ""
 Case ID_SelectAll
 With oControl
 .SelStart = 0
 .SelLength = Len(oControl.Text)
 End With
 End Select

End Sub

Private Sub EnableMenuItems(oControl As msforms.TextBox, oForm As UserForm)

 Dim oData As DataObject
 Dim testClipBoard As String

 On Error Resume Next

 ' Set object variable to clicked textbox
 'Set oControl = oForm.ActiveControl

 ' Create DataObject to access the clipboard
 Set oData = New DataObject

 ' Enable Cut/Copy/Delete menu items if text selected
 ' in textbox
 If oControl.SelLength > 0 Then
 Cut_Enabled = MFS_ENABLED
 Copy_Enabled = MFS_ENABLED
 Delete_Enabled = MFS_ENABLED
 Else
 Cut_Enabled = MFS_GRAYED
 Copy_Enabled = MFS_GRAYED
 Delete_Enabled = MFS_GRAYED
 End If

 ' Enable SelectAll menu item if there is any text in textbox
 If Len(oControl.Text) > 0 Then
 SelectAll_Enabled = MFS_ENABLED
 Else
 SelectAll_Enabled = MFS_GRAYED
 End If

 ' Get data from clipbaord
 oData.GetFromClipboard

 ' Following line generates an error if there
 ' is no text in clipboard
 testClipBoard = oData.GetText

 ' If NO error (ie there is text in clipboard) then
 ' enable Paste menu item. Otherwise, diable it.
 If Err.Number = 0 Then
 Paste_Enabled = MFS_ENABLED
 Else
 Paste_Enabled = MFS_GRAYED
 End If

 ' Clear the error object
 Err.Clear

 ' Clean up object references
 'Set oControl = Nothing
 Set oData = Nothing

End Sub

Private Function GetSelection() As Long

 Dim menu_hwnd As Long
 Dim form_hwnd As Long
 Dim oMenuItemInfo1 As MENUITEMINFO
 Dim oMenuItemInfo2 As MENUITEMINFO
 Dim oMenuItemInfo3 As MENUITEMINFO
 Dim oMenuItemInfo4 As MENUITEMINFO
 Dim oMenuItemInfo5 As MENUITEMINFO
 Dim oMenuItemInfo6 As MENUITEMINFO
 Dim oRect As RECT
 Dim oPointAPI As POINTAPI

 ' Find hwnd of UserForm - note different classname
 ' Word 97 vs Word2000
 #If VBA6 Then
 form_hwnd = FindWindow("ThunderDFrame", FormCaption)
 #Else
 form_hwnd = FindWindow("ThunderXFrame", FormCaption)
 #End If

 ' Get current cursor position
 ' Menu will be drawn at this location
 GetCursorPos oPointAPI

 ' Create new popup menu
 menu_hwnd = CreatePopupMenu

 ' Intitialize MenuItemInfo structures for the 6
 ' menu items to be added

 ' Cut
 With oMenuItemInfo1
 .cbSize = Len(oMenuItemInfo1)
 .fMask = MIIM_STATE Or MIIM_ID Or MIIM_TYPE
 .fType = MFT_STRING
 .fState = Cut_Enabled
 .wID = ID_Cut
 .dwTypeData = "Cut"
 .cch = Len(.dwTypeData)
 End With

 ' Copy
 With oMenuItemInfo2
 .cbSize = Len(oMenuItemInfo2)
 .fMask = MIIM_STATE Or MIIM_ID Or MIIM_TYPE
 .fType = MFT_STRING
 .fState = Copy_Enabled
 .wID = ID_Copy
 .dwTypeData = "Copy"
 .cch = Len(.dwTypeData)
 End With

 ' Paste
 With oMenuItemInfo3
 .cbSize = Len(oMenuItemInfo3)
 .fMask = MIIM_STATE Or MIIM_ID Or MIIM_TYPE
 .fType = MFT_STRING
 .fState = Paste_Enabled
 .wID = ID_Paste
 .dwTypeData = "Paste"
 .cch = Len(.dwTypeData)
 End With

 ' Separator
 With oMenuItemInfo4
 .cbSize = Len(oMenuItemInfo4)
 .fMask = MIIM_TYPE
 .fType = MFT_SEPARATOR
 End With

 ' Delete
 With oMenuItemInfo5
 .cbSize = Len(oMenuItemInfo5)
 .fMask = MIIM_STATE Or MIIM_ID Or MIIM_TYPE
 .fType = MFT_STRING
 .fState = Delete_Enabled
 .wID = ID_Delete
 .dwTypeData = "Delete"
 .cch = Len(.dwTypeData)
 End With

 ' SelectAll
 With oMenuItemInfo6
 .cbSize = Len(oMenuItemInfo6)
 .fMask = MIIM_STATE Or MIIM_ID Or MIIM_TYPE
 .fType = MFT_STRING
 .fState = SelectAll_Enabled
 .wID = ID_SelectAll
 .dwTypeData = "Select All"
 .cch = Len(.dwTypeData)
 End With

 ' Add the 6 menu items
 InsertMenuItem menu_hwnd, 1, True, oMenuItemInfo1
 InsertMenuItem menu_hwnd, 2, True, oMenuItemInfo2
 InsertMenuItem menu_hwnd, 3, True, oMenuItemInfo3
 InsertMenuItem menu_hwnd, 4, True, oMenuItemInfo4
 InsertMenuItem menu_hwnd, 5, True, oMenuItemInfo5
 InsertMenuItem menu_hwnd, 6, True, oMenuItemInfo6

 ' Return the ID of the item selected by the user
 ' and set it the return value of the function
 GetSelection = TrackPopupMenu _
 (menu_hwnd, _
 TPM_LEFTALIGN Or TPM_TOPALIGN Or TPM_RETURNCMD Or TPM_RIGHTBUTTON, _
 oPointAPI.X, oPointAPI.Y, _
 0, form_hwnd, oRect)

 ' Destroy the menu
 DestroyMenu menu_hwnd

End Function

Option Explicit

Private WithEvents pTextBox As msforms.TextBox
Private pUserFormReference As UserForm

Private Sub pTextBox_MouseDown(ByVal Button As Integer, _
 ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
 Debug.Print "Clicked"
 If Button = 2 Then
 Debug.Print pTextBox.Text
 Call ShowPopup(pTextBox, pUserFormReference, pUserFormReference.Caption, X, Y)
 End If
End Sub

Public Sub SetUp(UserFormReference As UserForm, TextboxReference As msforms.TextBox)
 Set pUserFormReference = UserFormReference
 Set pTextBox = TextboxReference
End Sub

Option Explicit

Private WithEvents CopyCtl As CommandBarButton
Private WithEvents CutCtl As CommandBarButton
Private WithEvents PasteCtl As CommandBarButton
Public WithEvents TxtBox  As msforms.TextBox

Private Sub CopyCtl_Click _
(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
    SendKeys ("^{C}")
End Sub

Private Sub CutCtl_Click _
(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
    SendKeys ("^{X}")
End Sub

Private Sub PasteCtl_Click _
(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
    SendKeys ("^{V}")
End Sub


Private Sub TxtBox_MouseUp _
(ByVal Button As Integer, ByVal Shift As Integer, _
ByVal X As Single, ByVal Y As Single)

    Dim oCmbar As CommandBar
    
    If Button = 2 Then
        Set oCmbar = Application.CommandBars.Add _
        (Position:=msoBarPopup, temporary:=True)
        Set CopyCtl = oCmbar.Controls.Add(msoControlButton)
        Set CutCtl = oCmbar.Controls.Add(msoControlButton)
        Set PasteCtl = oCmbar.Controls.Add(msoControlButton)
        
        With CopyCtl
            .Style = msoButtonIconAndCaption
            .FaceId = 19
            .Caption = "Copy"
        End With
        With CutCtl
            .Style = msoButtonIconAndCaption
            .FaceId = 21
            .Caption = "Cut"
        End With
        With PasteCtl
            .Style = msoButtonIconAndCaption
            .FaceId = 22
            .Caption = "Paste"
        End With
        
        oCmbar.ShowPopup
        oCmbar.Delete
    End If

End Sub

Option Explicit

Private oCol As Collection

Private Sub UserForm_Initialize()

    Dim oCCPClass As ClssCutCopyPaste
    
    Set oCol = New Collection
    
    Dim oCtl As Control
        For Each oCtl In Me.Controls
            If TypeOf oCtl Is msforms.TextBox Then
                Set oCCPClass = New ClssCutCopyPaste
               Set oCCPClass.TxtBox = oCtl
                oCol.Add oCCPClass
            End If
        Next
    
End Sub


Private Sub UserForm_Terminate()

    Set oCol = Nothing

End Sub