Having a procedure c1(), that looks like this:
Sub c1(control As IRibbonControl)
Debug.Print "foo"
End Sub
it is being called successfully from the ribbon, with the correct code onAction="c1"/>
Question:
How to call the same procedure from the immediate window (for debugging purposes)? It is asking for a parameter, which I do not know how to provide:
If your code in c1 does not rely on the control you can use
c1 nothing
in the immediate window.
What you can do for example:
Private lobjRibbon As IRibbonUI
Public Declare PtrSafe Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" ( _
ByRef Destination As Any, ByRef source As Any, ByVal length As Long)
Public Sub Ribbon_CallbackOnLoad(ByRef probjRibbon As IRibbonUI)
Set lobjRibbon = probjRibbon
Range("A1").Value = CStr(ObjPtr(lobjRibbon)) 'write the pointer to a cell to save it even if VBA stops
End Sub
with Ribbon_CallbackOnLoad you set the ribbon on load to the variable lobjRibbon or save it's pointer (in case VBA completely ends).
You can use
Function GetRibbon(ByVal lRibbonPointer As LongPtr) As Object
Dim objRibbon As Object
Call CopyMemory(objRibbon, lRibbonPointer, LenB(lRibbonPointer))
Set GetRibbon = objRibbon
Set objRibbon = Nothing
End Function
to get the ribbob object back from its saved pointer for example like in
Sub RefreshRibbon(Optional ControlID As String = vbNullString)
If lobjRibbon Is Nothing Then
Set lobjRibbon = GetRibbon(CLngPtr(Range("A1").Value))
If ControlID = vbNullString Then
lobjRibbon.Invalidate
Else
lobjRibbon.InvalidateControl ControlID
End If
Else
If ControlID = vbNullString Then
lobjRibbon.Invalidate
Else
lobjRibbon.InvalidateControl ControlID
End If
End If
End Sub
Try this workaround
Sub c1(control As IRibbonControl)
call c1_subroutine
End Sub
Sub c1_subroutine()
Debug.Print "foo"
End Sub
And in the immediate window call c1_subroutine
Related
I raised a query which now works as per David Zemens' instructions and BrakNicku guidance.
Problem is one of the events I want to use is Enter. Within the class, I don't get the option for this event. Is there is a way to add this to the class or trigger an Enter event for the control somehow?
I tried most of the events available within the class but none of them behave the way I need them to.
A quick background: I use Enter event to set help text for the field in focus. So every time a user enters a field, I have a help textbox that gets populated with help text.
I am unable to share the workbook.
Let's say your userform (Userform1) looks like this
I am going to demonstrate the Enter Event for 2 controls. TextBox and ComboBox.
Ensure that you place the CommandButton1 first on the userform. Or alternatively, set it's TabIndex to 0. This is so that the command button takes focus first when the userform loads and you can test the Entering of TextBox and ComboBox.
Paste this in a class module. My Class module name is Class1
Option Explicit
Public WithEvents Usrfrm As UserForm1
Const MyMsg As String = "Hiya there. Did you just try to sneak into the "
Private Sub Usrfrm_OnEnter(ctrl As msforms.Control)
Select Case True
Case TypeName(ctrl) Like "ComboBox"
'Call Usrfrm.Combobox_List(ctrl)
MsgBox MyMsg & "combobox?", vbCritical, "Aha!"
Case TypeName(ctrl) Like "TextBox"
MsgBox MyMsg & "textbox?", vbCritical, "Aha!"
End Select
End Sub
Paste this in the userform code area
Option Explicit
Public Event OnEnter(ctrl As msforms.Control)
Private prevCtl As msforms.Control
Private mycls As Class1
Private IsfrmUnloaded As Boolean
Private Sub CommandButton1_Click()
Unload Me
End Sub
Private Sub UserForm_Layout()
Call spyWhatsGoingOn
End Sub
Private Sub spyWhatsGoingOn()
Set mycls = New Class1
Set mycls.Usrfrm = Me
IsfrmUnloaded = False
Set prevCtl = Me.ActiveControl
RaiseEvent OnEnter(Me.ActiveControl)
Do While IsfrmUnloaded = False
If Not prevCtl Is Nothing Then
If Not prevCtl Is Me.ActiveControl Then
RaiseEvent OnEnter(Me.ActiveControl)
Me.ActiveControl.SetFocus
End If
End If
Set prevCtl = Me.ActiveControl
DoEvents
Loop
End Sub
Demo
Here another solution, (doesnot work on a MAC)
Open Notepad and copy code below and paste it in a new txt-file
save it als CatchEvents.cls
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "CatchEvents"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
#If VBA7 And Win64 Then
Private Declare PtrSafe Function ConnectToConnectionPoint Lib "shlwapi" Alias "#168" (ByVal punk As stdole.IUnknown, _
ByRef riidEvent As GUID, ByVal fConnect As Long, ByVal punkTarget As stdole.IUnknown, ByRef pdwCookie As Long, _
Optional ByVal ppcpOut As LongPtr) As Long
#Else
Private Declare Function ConnectToConnectionPoint Lib "shlwapi" Alias "#168" (ByVal punk As stdole.IUnknown, ByRef riidEvent As GUID, _
ByVal fConnect As Long, ByVal punkTarget As stdole.IUnknown, ByRef pdwCookie As Long, Optional ByVal ppcpOut As Long) As Long
#End If
Private EventGuide As GUID
Private Ck As Long
Private ctl As Object
'All Other Control-Events also possible
Public Sub MyEnter()
Attribute MyEnter.VB_UserMemId = -2147384830
Select Case TypeName(ctl)
Case "TextBox": MsgBox "Your code for " & ctl.Name & " here!"
Case Else: MsgBox "You entered no TextBox but another control (" & ctl.Name & ")!"
End Select
End Sub
Public Sub ConnectAllEvents(ByVal Connect As Boolean)
With EventGuide
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With
ConnectToConnectionPoint Me, EventGuide, Connect, ctl, Ck, 0&
End Sub
Public Property Let Item(Ctrl As Object)
Set ctl = Ctrl
Call ConnectAllEvents(True)
End Property
Public Sub Clear()
If (Ck <> 0) Then Call ConnectAllEvents(False)
Set ctl = Nothing
End Sub
In your VBA editor you import this File
In your Userform code you add:(when you have already an Initialize-event you combine those)
Private AllControls() As New CatchEvents 'on top
Private Sub UserForm_Initialize()
ReDim AllControls(Controls.Count - 1)
For j = 0 To Controls.Count - 1
AllControls(j).Item = Controls(j)
Next
End Sub
Now every Enter-event of any control will be catched, so you have to act accordingly.
Every event on a Userform can be catched this way.
So the approach I went with was: I already had Class Module that was trapping Change event (can be seen here). As i didnt have access to Enter event in my class, I used the KeyUp and MouseDown events in this class to set help for each control. This way user can get to a field by clicking on it or tabbing to it: help is displayed for the selected control
Let me preface my question with the fact that I am self taught, so please provide as much detail as possible and bear with me if I need you to explain differently or multiple times.
I created a notation/email generating tool for my team using Microsoft Visual Basic 7.0. The only complaint that I received on it was that many of them are not used to hot keys so they depend on using the mouse but right click didn't work. I was able to find code that creates a pop-up for copy and paste when they use right click, and it works great on the few textboxes that are on the main form itself, however it does not work on the majority of the textboxes as they are in a Multipage.
Does anyone know how to alter the below code to work for textboxes on a Multipage? Also, before it is suggested, I did toy with the idea of moving everything out of the Multipage, however that format is the easiest as there are multiple stages and types of notes/emails that they would need to send at any time, so having tabs available for them to simply click is the most user friendly that I was able to create and that they all agreed on.
Thank you all so much in advance!
Code in the form:
Dim cBar As clsBar
Private Sub UserForm_Initialize()
On Error GoTo Whoa
Application.EnableEvents = False
Set cBar = New clsBar
cBar.Initialize Me
Letscontinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume Letscontinue
End Sub
Code in a Class Module:
Option Explicit
'Popup objects
Private cmdBar As CommandBar
Private WithEvents cmdCopyButton As CommandBarButton
Private WithEvents cmdPasteButton As CommandBarButton
'Useform to use
Private fmUserform As Object
'Control array of textbox
Private colControls As Collection
'Textbox Control
Private WithEvents tbControl As MSForms.TextBox
'Adds all the textbox in the userform to use the popup bar
Sub Initialize(ByVal UF As Object)
Dim Ctl As MSForms.Control
Dim cBar As clsBar
For Each Ctl In UF.Controls
If TypeName(Ctl) = "TextBox" Then
'Check if we have initialized the control array
If colControls Is Nothing Then
Set colControls = New Collection
Set fmUserform = UF
'Create the popup
CreateBar
End If
'Create a new instance of this class for each textbox
Set cBar = New clsBar
cBar.AssignControl Ctl, cmdBar
'Add it to the control array
colControls.Add cBar
End If
Next Ctl
End Sub
Private Sub Class_Terminate()
'Delete the commandbar when the class is destroyed
On Error Resume Next
cmdBar.Delete
End Sub
'Click event of the copy button
Private Sub cmdCopyButton_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
fmUserform.ActiveControl.Copy
CancelDefault = True
End Sub
'Click event of the paste button
Private Sub cmdPasteButton_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
fmUserform.ActiveControl.Paste
CancelDefault = True
End Sub
'Right click event of each textbox
Private Sub tbControl_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If Button = 2 And Shift = 0 Then
'Display the popup
cmdBar.ShowPopup
End If
End Sub
Private Sub CreateBar()
Set cmdBar = Application.CommandBars.Add(, msoBarPopup, False, True)
'We’ll use the builtin Copy and Paste controls
Set cmdCopyButton = cmdBar.Controls.Add(ID:=19)
Set cmdPasteButton = cmdBar.Controls.Add(ID:=22)
End Sub
'Assigns the Textbox and the CommandBar to this instance of the class
Sub AssignControl(TB As MSForms.TextBox, Bar As CommandBar)
Set tbControl = TB
Set cmdBar = Bar
End Sub
Get ActiveControl name on a Multipage control
It's necessary to know the multipage's selected Page via a helper function (ActiveControlName) using SelectedItem property and getting the control (its name) from there. Change your button click events as follows:
Relevant button click events in class module clsBar
'Click event of the copy button
Private Sub cmdCopyButton_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
Dim sACN As String
sACN = ActiveControlName(fmUserform) ' find control's name
' Debug.Print sACN & ".Copy"
fmUserform.Controls(sACN).Copy ' << instead of fmUserform.ActiveControl.Copy
CancelDefault = True
End Sub
'Click event of the paste button
Private Sub cmdPasteButton_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
Dim sACN As String
sACN = ActiveControlName(fmUserform)
' Debug.Print sACN & ".Paste"
fmUserform.Controls(sACN).Paste ' << instead of fmUserform.ActiveControl.Paste
CancelDefault = True
End Sub
Helper function called by above click events
Function ActiveControlName(form As UserForm) As String
'cf Site: https://stackoverflow.com/questions/47745663/get-activecontrol-inside-multipage
'Purpose: get ActiveControl
Dim MyMultiPage As MSForms.MultiPage, myPage As MSForms.Page
If form.ActiveControl Is Nothing Then
' do nothing
ElseIf TypeName(form.ActiveControl) = "MultiPage" Then
Set MyMultiPage = form.ActiveControl
Set myPage = MyMultiPage.SelectedItem
ActiveControlName = myPage.ActiveControl.Name
Else
ActiveControlName = form.ActiveControl.Name
End If
End Function
Side note
Suggest to check for the length of selected text strings in case of empty strings to prevent from unwanted results.
I want to fire the BeforeDoubleClick-event BEFORE the SelectionChange-event for an EXCEL work-sheet.
The order is normally the other way round: SelectionChange-event first, and later BeforeDoubleClick-event.
My goal is to either run MyDoubleClickCode, if there a double-click, or if NOT, run MyChangeSelectionCode.
The problem relies in the order of event-triggering!
My best solution comes here:
' This Event is **MAYBE** fired secondly and runs the MyDoubleClickCode
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
dblFlag = true
...
MyDoubleClickCode
...
End Sub
' This event is always fired AND runs first
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
dblFlag = false
alertTime = Now + TimeValue("00:00:01")
Application.OnTime alertTime, "MyChangeSelectionSub"
End Sub
' Userdefined subroutine which will run one second after an event ( doubleclick or not).
public sub MyChangeSelectionSub()
If NOT dblFlag then
...
MyChangeSelectionCode
...
End if
End Sub
I use OnTime in my SelectionChange-event to call the MyChangeSelectionSub one second after a selection-change is triggered. This gives times to handle an BeforeDoubleClick-event and do the MyDoubleClickCode - if the cell was also double-clicked. My wanted logic is reached , BUT...
... it is of course very clumpsy and not satisfying: I have to wait one second before the MyChangeSelectionSub starts, instead of just after the BeforeDoubleClick-event has been dealed with.
Maybee there is a kind of logic to make this happend? Any idea?
EDIT: I've edited the code-exampel to be more clear about my problem! And I know now that I can't change the order of events, but how to not use the onTime solution??
This "works" for me, but it doesn't seem stable. Probably the timing of the OnTime method causes an "uncomfortable pause" in execution that we might need to accept. (or improve upon.)
'worksheet (Name) is "Sheet17" in the VBA Properties window
'worksheet Name is "Sheet1" as shown in the worksheet tab in the application Excel
Private double_click_detected As Boolean
Private SelectionChange_target As Range
' This Event is **MAYBE** fired secondly and runs the MyDoubleClickCode
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
double_click_detected = True
'...
MsgBox "MyDoubleClickCode"
'...
End Sub
' This event is always fired AND runs first
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Set SelectionChange_target = Target
alertTime = Now + TimeValue("00:00:01")
Application.OnTime alertTime, "Sheet17.MyChangeSelectionSub"
End Sub
' Userdefined subroutine which will run one second after an event ( doubleclick or not).
Public Sub MyChangeSelectionSub()
If Not double_click_detected Then
'...
MsgBox "MyChangeSelectionCode"
'...
End If
End Sub
I found a solution for a similar issue, to avoid Worksheet_SelectionChange before the event Worksheet_BeforeRightClick on https://www.herber.de/forum/archiv/1548to1552/1550413_Worksheet_BeforeRightClick.html (in german) and used it for my test sub.
The whole list of virtual key codes you find on https://learn.microsoft.com/en-us/windows/win32/inputdev/virtual-key-codes
Private Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)'just for sleep
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Const VK_LBUTTON = &H1 'Left mouse button
Const VK_RBUTTON = &H2 'Right mouse button
Const VK_SHIFT = &H10'Shiftkey just for fun to exit the sub
Sub TestGetAsyncKeyState()
Dim RMouseClick As Long, LMouseClick As Long
Dim RMouseClickpr As Long, LMouseClickpr As Long
Dim lShift As Long, iC As Integer
iC = 0
Do
DoEvents
lShift = GetAsyncKeyState(VK_SHIFT)
RMouseClickpr = RMouseClick
LMouseClickpr = LMouseClick
RMouseClick = GetAsyncKeyState(VK_RBUTTON)
LMouseClick = GetAsyncKeyState(VK_LBUTTON)
If RMouseClick <> RMouseClickpr Or LMouseClick <> LMouseClickpr Then Debug.Print vbLf; CStr(iC); ":"
If RMouseClick <> RMouseClickpr Then Debug.Print "Right: "; RMouseClick; "Previous: "; RMouseClickpr
If LMouseClick <> LMouseClickpr Then Debug.Print "Left : "; LMouseClick; "Previous: "; LMouseClickpr
' If RMouseClick <> RMouseClickpr Or LMouseClick <> LMouseClickpr Then Stop
Sleep (1000)
iC = iC + 1
If iC > 120 Then Stop '2
Loop While GetAsyncKeyState(VK_SHIFT) = 0 'End Loop by pressing any of the Shift-Keys
End Sub
It works for mouseclick (1), shortly held mousebutton (-32767) and longer held mousebutton (-32768). Unfortunately not for doubleclick.
Attention: https://learn.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-getasynckeystate says that it detects the physical mousebuttons. If someone changed the setting it will not detect the correct button. MS says you can correct that with GetSystemMetrics(SM_SWAPBUTTON).
Hope it helps.
Creating a contextual menu within an Excel User form that applies to Images...
I am trying to write a piece of VBA code to allow me to use a contextual menu generated from right clicking an Image on an Excel User form.
Andy Pope kindly gave the world a great bit of code to add a simple context menu that applies to textboxes within an Excel User form, but not Userform.Images.
http://www.andypope.info/vba/uf_contextualmenu.htm
I have edited his code ever so slightly to prevent the contextual usage of Locked = True textboxes.
'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
What can I add to this code for the same context menu to apply with Images?
Something along the lines of...
Adding 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
Declaring a 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
I would need to declare a new Public Property Set
Public Property Set Img(RHS As MSForms.Image)
Set m_imgImage = RHS
End Property
Each context menu option would need altering to include the possibility of a user right clicking on an image...
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
*You will note that I am only using the Copy feature of the context menu as Cutting and Pasteing from within an User form will not be required (or stable for that matter!).
And finally I would need to recreate the trigger...
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
It seems like an awful lot of unnecessary work, there must be an easier way.
Any help or advice is much appreciated, and once again thank you for your time.
Mr J.
If I have understood your question right, you just want to respond to all image click in one sub. This is how I do it. First create a class called ImageClickResponder (for this example) and add the following:
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
Then in your user form put this:
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
I'm working in Excel on a Userform. Essentially, I want a "Photoshop-esque" toolbar that floats over my spreadsheet while I work, allowing me to select and use various tools.
I've got a series of toggle buttons set up so that when one is clicked, any other toggle buttons go back to unclicked. It's a little more complicated because I have sub-buttons, if that makes sense, meaning that once I have a button clicked, I can click one of four other buttons to make my actual selection, and these four buttons are mutually exclusive from each other as well.
The weird thing: I haven't been able to get these buttons to work. Except. For some reason, when I right-click only, the buttons work like a charm. Left-click: nothing. Help please?
Sample button code:
Private Sub tMouse_MouseUp(ByVal button As Integer, _
ByVal shift As Integer, ByVal X As Single, ByVal Y As Single)
tMouse.Value = True
tActual.Value = False
tSched.Value = False
tX.Value = False
tDiam.Value = False
tCirc.Value = False
tTri.Value = False
tTrash.Value = False
tText.Value = False
End Sub
EDIT:
I tried what was suggested about printing the value of the toggle button. And my computer blew up with messageboxes. I had changed all the actions to Click() events. Apparently I was sending the computer through an infinite loop. Maybe the act of changing a button from true to false or vice versa acts like a click and triggers all the other click events?
You have events that are triggering other events. What you'll need to do is set a Boolean AllowEventsToRun variable (either at the module or public level) and set that to false at the start of your code. Run whatever you need to do, and then set it to true at the end.
The trick is to do an if statement to make sure that AllowEventsToRun is set to true before any other code is running. Be sure to initialize the Boolean to true when you load your userform (since the default value of a boolean is false. So something like this:
Option Explicit
Private AllowEventsToRun As Boolean
Private Sub ToggleButton1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If AllowEventsToRun Then
AllowEventsToRun = False
'whatever you're doing that's causing the events to chain fire
AllowEventsToRun = True
End If
End Sub
Private Sub ToggleButton2_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If AllowEventsToRun Then
AllowEventsToRun = False
'whatever you're doing that's causing the events to chain fire
AllowEventsToRun = True
End If
End Sub
Private Sub UserForm_Initialize()
AllowEventsToRun = True
End Sub
source: http://www.cpearson.com/excel/SuppressChangeInForms.htm
I would recommend using an "Option" Control instead of a "Toggle" Control.
If you stick 4 options in 1 frame then only 1 of those 4 options will allow itself to be true at a time automatically. You should use the "ToggleButton" control only if you want multiple instances of it to be true at the same time.
However if you refuse to do so and just really want to use ToggleButtons. Then you could write a procedure that is executed once pressing the button that sends it's name (or something else that identifies it uniquely) as a parameter to a procedure that sets all other togglebuttons false except it.
Cheers!
Private Sub ToggleButton1_Click()
Dim s As String
s = "ToggleButton1"
Evaluate_Options s
End Sub
Private Sub ToggleButton2_Click()
Dim s As String
s = "ToggleButton2"
Evaluate_Options s
End Sub
Private Sub ToggleButton3_Click()
Dim s As String
s = "ToggleButton3"
Evaluate_Options s
End Sub
Private Sub ToggleButton4_Click()
Dim s As String
s = "ToggleButton4"
Evaluate_Options s
End Sub
Private Sub ToggleButton5_Click()
Dim s As String
s = "ToggleButton5"
Evaluate_Options s
End Sub
Private Sub ToggleButton6_Click()
Dim s As String
s = "ToggleButton6"
Evaluate_Options s
End Sub
Private Sub ToggleButton7_Click()
Dim s As String
s = "ToggleButton7"
Evaluate_Options s
End Sub
Private Sub ToggleButton8_Click()
Dim s As String
s = "ToggleButton8"
Evaluate_Options s
End Sub
Private Sub Evaluate_Options(s As String)
Dim tgl As Control
For Each tgl In UserForm1.Frame1.Controls
If InStr(tgl.Name, s) Then Set_Toggles_1 tgl
Next
For Each tgl In UserForm1.Frame2.Controls
If InStr(tgl.Name, s) Then Set_Toggles_2 tgl
Next
End Sub
Private Sub Set_Toggles_1(tglTrue As Control)
Dim tglFalse As Control
For Each tglFalse In UserForm1.Frame1.Controls
If tglFalse.Name = tglTrue.Name Then tglFalse = True Else tglFalse = False
Next
End Sub
Private Sub Set_Toggles_2(tglTrue As Control)
Dim tglFalse As Control
For Each tglFalse In UserForm1.Frame2.Controls
If tglFalse.Name = tglTrue.Name Then tglFalse = True Else tglFalse = False
Next
End Sub
Try these basic mouse event capture subs and modify to suit your needs (tMouse = toggle button name):
Private Sub tMouse_Click()
'MsgBox "tb value = " & tMouse.Value
End Sub
Note: upper sub will not work, if lower sub called
Private Sub tMouse_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If Button = 1 Then MsgBox "Left"
If Button = 2 Then MsgBox "Right"
End Sub