Excel VBA Userform上下文菜单类代码
在适用于图像的Excel用户表单中创build上下文菜单…
我正在尝试编写一段VBA代码，以允许使用右键单击Excel用户窗体上的Image生成的上下文菜单。
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 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
*您将注意到，我只使用上下文菜单中的“ Copyfunction，因为“ Cut和“从用户窗体中Paste将不是必需的（或者对于这种情况稳定！）。
最后，我需要重新创build触发器…
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
这似乎是一个非常多的不必要的工作，必须有一个更简单的方法。
任何帮助或build议非常感谢，再次感谢您的时间。
J.先生
如果我已经理解了你的问题，你只需要响应所有的图像点击一个子。 这是我如何做到的。 首先创build一个名为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