Excel VBA UserForm Контекстное меню Код класса

Question

Создание контекстного меню внутри Excel формы пользователя, которая применяется к изображениям ...

Я пытаюсь написать кусок кода VBA, чтобы позволить мне использовать контекстное меню, сгенерированный из щелкнув правой кнопкой мыши Image в форме пользователя Excel.

Andy Pope любезно предоставил миру отличный код для добавления простого контекстного меню, которое применяется к текстовым полям в форме пользователя Excel, но не Userform.Image.

http://www.andypope.info/vba/uf_contextualmenu.htm

я когда-либо слегка отредактированный свой код, чтобы предотвратить контекстное использование Locked = True текстовых полей.

'Copyright ©2007-2014 Andy Pope 
Option Explicit 

Private Const mEDIT_CONTEXTMENU_NAME = "ajpiEditContextMenu" 
Private Const mCUT_TAG = "CUT" 
Private Const mCOPY_TAG = "COPY" 
Private Const mPASTE_TAG = "PASTE" 

Private m_cbrContextMenu As CommandBar 
Private WithEvents m_txtTBox As MSForms.TextBox 
Private WithEvents m_cbtCut As CommandBarButton 
Private WithEvents m_cbtCopy As CommandBarButton 
Private WithEvents m_cbtPaste As CommandBarButton 
Private m_objDataObject As DataObject 
Private m_objParent As Object 
Private Function m_CreateEditContextMenu() As CommandBar 
' 
' Build Context menu controls. 
' 
    Dim cbrTemp As CommandBar 
    Const CUT_MENUID = 21 
    Const COPY_MENUID = 19 
    Const PASTE_MENUID = 22 

    Set cbrTemp = Application.CommandBars.Add(mEDIT_CONTEXTMENU_NAME, Position:=msoBarPopup) 
    With cbrTemp 
     With .Controls.Add(msoControlButton) 
      .Caption = "Cu&t" 
      .FaceId = CUT_MENUID 
      .Tag = mCUT_TAG 
     End With 
     With .Controls.Add(msoControlButton) 
      .Caption = "&Copy" 
      .FaceId = COPY_MENUID 
      .Tag = mCOPY_TAG 
     End With 
     With .Controls.Add(msoControlButton) 
      .Caption = "&Paste" 
      .FaceId = PASTE_MENUID 
      .Tag = mPASTE_TAG 
     End With 
    End With 

    Set m_CreateEditContextMenu = cbrTemp 

End Function 
Private Sub m_DestroyEditContextMenu() 
    On Error Resume Next 
    Application.CommandBars(mEDIT_CONTEXTMENU_NAME).Delete 
    Exit Sub 
End Sub 
Private Function m_GetEditContextMenu() As CommandBar 

    On Error Resume Next 

    Set m_GetEditContextMenu = Application.CommandBars(mEDIT_CONTEXTMENU_NAME) 
    If m_GetEditContextMenu Is Nothing Then 
     Set m_GetEditContextMenu = m_CreateEditContextMenu 
    End If 

    Exit Function 

End Function 
Private Function m_ActiveTextbox() As Boolean 
' 
' Make sure this instance is connected to active control 
' May need to drill down through container controls to 
' reach ActiveControl object 
' 
    Dim objCtl As Object 

    Set objCtl = m_objParent.ActiveControl 
    Do While UCase(TypeName(objCtl)) <> "TEXTBOX" 
     If UCase(TypeName(objCtl)) = "MULTIPAGE" Then 
      Set objCtl = objCtl.Pages(objCtl.Value).ActiveControl 
     Else 
      Set objCtl = objCtl.ActiveControl 
     End If 
    Loop 
    m_ActiveTextbox = (StrComp(objCtl.Name, m_txtTBox.Name, vbTextCompare) = 0) 

ErrActivetextbox: 
    Exit Function 

End Function 
Public Property Set Parent(RHS As Object) 
    Set m_objParent = RHS 
End Property 
Private Sub m_UseMenu() 

    Dim lngIndex As Long 

    For lngIndex = 1 To m_cbrContextMenu.Controls.Count 
     Select Case m_cbrContextMenu.Controls(lngIndex).Tag 
     Case mCUT_TAG 
      Set m_cbtCut = m_cbrContextMenu.Controls(lngIndex) 
     Case mCOPY_TAG 
      Set m_cbtCopy = m_cbrContextMenu.Controls(lngIndex) 
     Case mPASTE_TAG 
      Set m_cbtPaste = m_cbrContextMenu.Controls(lngIndex) 
     End Select 
    Next 

End Sub 
Public Property Set TBox(RHS As MSForms.TextBox) 
    Set m_txtTBox = RHS 
End Property 
Private Sub Class_Initialize() 

    Set m_objDataObject = New DataObject 
    Set m_cbrContextMenu = m_GetEditContextMenu 

    If Not m_cbrContextMenu Is Nothing Then 
     m_UseMenu 
    End If 

End Sub 
Private Sub Class_Terminate() 

    Set m_objDataObject = Nothing 
    m_DestroyEditContextMenu 

End Sub 
Private Sub m_cbtCopy_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean) 

    ' check active textbox is this instance of CTextBox_ContextMenu 
    If m_ActiveTextbox() Then 
     With m_objDataObject 
      .Clear 
      .SetText m_txtTBox.SelText 
      .PutInClipboard 
     End With 
    End If 

End Sub 
Private Sub m_cbtCut_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean) 
If m_txtTBox.Locked = True Then 
Exit Sub 
End If 

    ' check active textbox is this instance of CTextBox_ContextMenu 
    If m_ActiveTextbox() Then 
     With m_objDataObject 
      .Clear 
      .SetText m_txtTBox.SelText 
      .PutInClipboard 
      m_txtTBox.SelText = vbNullString 
     End With 
    End If 

End Sub 
Private Sub m_cbtPaste_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean) 
If m_txtTBox.Locked = True Then 
Exit Sub 
End If 

    ' check active textbox is this instance of CTextBox_ContextMenu 
    On Error GoTo ErrPaste 

    If m_ActiveTextbox() Then 
     With m_objDataObject 
      .GetFromClipboard 
      m_txtTBox.SelText = .GetText 
     End With 
    End If 

ErrPaste: 
    Exit Sub 
End Sub 
Private Sub m_txtTBox_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single) 

    If Button = 2 Then 
     ' right click 
     m_cbrContextMenu.ShowPopup 
    End If 

End Sub 

Что я могу добавить в этот код для того же контекстного меню, которое применяется к изображениям? Что-то вдоль линий ...

Добавление Private WithEvents m_imgImage As MSForms.Image

Private m_cbrContextMenu As CommandBar 
Private WithEvents m_txtTBox As MSForms.TextBox 

Private WithEvents m_imgImage As MSForms.Image 

Private WithEvents m_cbtCut As CommandBarButton 
Private WithEvents m_cbtCopy As CommandBarButton 
Private WithEvents m_cbtPaste As CommandBarButton 
Private m_objDataObject As DataObject 
Private m_objParent As Object 
Private Function m_CreateEditContextMenu() As CommandBar 

Объявление New Private Function

Private Function m_ActiveImage() As Boolean 
' 
' Make sure this instance is connected to active control 
' May need to drill down through container controls to 
' reach ActiveControl object 
' 
    Dim objCtl As Object 

    Set objCtl = m_objParent.ActiveControl 
    Do While UCase(TypeName(objCtl)) <> "IMAGE" 
     If UCase(TypeName(objCtl)) = "MULTIPAGE" Then 
      Set objCtl = objCtl.Pages(objCtl.Value).ActiveControl 
     Else 
      Set objCtl = objCtl.ActiveControl 
     End If 
    Loop 
    m_ActiveImage = (StrComp(objCtl.Name, m_imgImage.Name, vbTextCompare) = 0) 

ErrActiveimage: 
    Exit Function 

End Function 

я должен был бы объявить новый Public Property Set

Public Property Set Img(RHS As MSForms.Image) 
    Set m_imgImage = RHS 
End Property 

Каждое контекстное меню опция wou л.д. необходимость изменения, чтобы включить возможность пользователя правой кнопкой мыши на изображение ...

Private Sub m_cbtCopy_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean) 

    ' check active image is this instance of CTextBox_ContextMenu 
    If m_ActiveTextbox() Then 
     With m_objDataObject 
      .Clear 
      .SetText m_txtTBox.SelText 
      .PutInClipboard 
     End With 
    End If 

    ' check active image is this instance of CImage_ContextMenu 
    If m_ActiveImage() Then 
     With m_objDataObject 
      .Clear 
      'What would be the image alternative for this next line of code? 
      '.SetText m_imgImage.SelText 
      .PutInClipboard 
     End With 
    End If 

End Sub 

* Вы заметите, что я только с помощью Copy функции контекстного меню, как Cut тин и Paste ИНГ изнутри Форма пользователя не требуется (или стабильная, если на то пошло!).

И, наконец, я должен был бы воссоздать на спусковой крючок ...

Private Sub m_imgImage_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single) 

    If Button = 2 Then 
     ' right click 
     m_cbrContextMenu.ShowPopup 
    End If 

End Sub 

Это кажется ужасно много ненужной работы, должно быть проще.

Любая помощь или совет очень ценится, и еще раз благодарим вас за ваше время.

г-н Дж

Answer 1

Если я понял ваш вопрос правильно, вы просто хотите, чтобы ответить на все изображения нажмите в одном суб. Вот как я это делаю. Сначала нужно создать класс с именем ImageClickResponder (для этого примера) и добавьте следующие строки:

Option Explicit 

Private Type Properties 
    Obj As Object 
    Procedure As String 
    CallType As VbCallType 
End Type 

Private this As Properties 

Private WithEvents img As MSForms.Image 

Public Sub Initialize(ByRef imgRef As MSForms.Image, ByRef Obj As Object, ByVal procedureName As String, ByVal CallType As VbCallType) 
    Set img = imgRef 
    With this 
     Set .Obj = Obj 
     .Procedure = procedureName 
     .CallType = CallType 
     Debug.Print imgRef.Name 
    End With 
End Sub 

Private Sub img_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) 
    VBA.CallByName this.Obj, this.Procedure, this.CallType, Button, Shift, X, Y 
End Sub 

Затем в пользовательской форме поставить это:

Option Explicit 

Private micrs() As ImageClickResponder 

Private Sub UserForm_Initialize() 
    micrs = LoadImageClickResponders(Me) 
End Sub 

Public Sub AllImgs_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) 
    Debug.Print "Your context menu code here" 
End Sub 

Private Function LoadImageClickResponders(ByRef frm As MSForms.UserForm) As ImageClickResponder() 
    Dim rtnVal() As ImageClickResponder 
    Dim ctrl As MSForms.Control 
    Dim i As Long 

    For Each ctrl In frm.Controls 
     If TypeOf ctrl Is MSForms.Image Then 
      ReDim Preserve rtnVal(i) As ImageClickResponder 
      Set rtnVal(i) = New ImageClickResponder 
      rtnVal(i).Initialize ctrl, Me, "AllImgs_MouseDown", VbMethod 
      i = i + 1 
     End If 
    Next 
    LoadImageClickResponders = rtnVal 
End Function