Экземпляр контекстного меню Excel VBA

Создание контекстного меню в форме Excel, которая применяется к изображениям …

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

Энди Пауп любезно предоставил миру отличный код для добавления простого контекстного меню, которое применяется к текстовым Userform.Image форме пользователя 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 

Каждому параметру контекстного меню необходимо изменить, чтобы включить возможность щелчка правой кнопкой мыши на изображении …

 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 ting и Paste ing из пользовательской формы не потребуются (или стабильные в этом отношении!).

И, наконец, мне нужно будет воссоздать триггер …

 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 

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

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

Г-н J.

Если я правильно понял ваш вопрос, вы просто хотите отреагировать на все изображения, щелкнув один под. Вот как я это делаю. Сначала создайте класс под названием 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 
  • Элемент UserSelection для MultiSelection
  • Userform.Show на кнопке формы не распознает пользовательскую форму, получив ошибку 424
  • XL VBA Как запретить игнорировать свойства UserTorm и .Left при первом .Show?
  • Excel только показывать пользовательскую форму, никогда не показывать книгу
  • Как использовать значение переменной Userform Global Variable в разных книгах с помощью VBA
  • Как добавить объекты управления в пользовательскую форму в коллекцию, а затем прокрутить коллекцию и получить доступ к их свойствам?
  • Excel VBA Userform IIf (IsDate) не сохраняет пробел
  • Возврат ответа с помощью VBA в TextBox
  • Выход VBA в отношении кнопок выбора
  • VBA Excel: аргумент не является необязательным
  • Добавление прослушивателя событий к нескольким спискам
  • Давайте будем гением компьютера.