Using the designer I created several ListBoxes on a worksheet and instead of writing a sub for each listbox for handling a click (etc.) I want to handle this in one sub.
I've read that this should be possible using a class and assigning existing listboxes to the eventhandler of that class.
But I can't get it working.
a) creating a class ~~~~ CListBoxEventHandler ~~~~ containing on the class module sheet
Public WithEvents CmdEvents As MSForms.ListBox
Private Sub CmdEvents_Click()
MsgBox "Click Event"
End Sub
b) on the worksheet
Private lisHandlers() As CListBoxEventHandler
sub worksheet_activate()
Dim numObjects As Long: numObjects = Me.OLEObjects.count
ReDim lisHandlers(1 To numObjects) As CListBoxEventHandler
dim i as integer: i = 0
Dim ctrl As OLEObject
For Each ctrl In Me.OLEObjects
Dim progID As String: progID = ctrl.progID
If (progID = "Forms.ListBox.1") Then
i = i + 1
Dim myListBox As MSForms.ListBox: Set myListBox = ctrl.Object
myListBox.LinkedCell = ""
Set lisHandlers(i).CmdEvents = myListBox
End If
Next ctrl
Redim Preserve lisHandlers(1 to i) as CListBoxEventHandler
end sub
How should I do it and can I do the same with TextBoxes?
Also: cab I use ~~~~ myListBox.OnAction = "ListBox_Change" ~~~~ for each of the listboxes and distinguish between the listboxes by Application.Caller?
You have not created any instances CListBoxEventHandler
Creating an array of that type just gives you a set of references to Nothing, not an array of instantiated objects.
Untested:
Private colHandlers As Collection 'easier than an array...
Sub worksheet_activate()
Dim ctrl As OLEObject, obj As CListBoxEventHandler
Dim myListBox As MSForms.ListBox
Set colHandlers = New Collection
For Each ctrl In Me.OLEObjects
If (ctrl.progID = "Forms.ListBox.1") Then
Set myListBox = ctrl.Object
myListBox.LinkedCell = ""
Set obj = New CListBoxEventHandler
Set obj.CmdEvents = myListBox
colHandlers.Add obj
End If
Next ctrl
End Sub
Related
I wrote some code in a class module and userform_initialize_event. All are okay. But when I Dim the new class module and applies in the initialize event it says that variable not defined. Here is my code -
Dim Buttons() As New BtnClass
Private Sub UserForm_Initialize()
Dim ButtonCount As Integer
Dim ctl As Control
' Create the Button objects
ButtonCount = 0
For Each ctl In fmHover.Controls
If TypeName(ctl) = "Label" Then
ButtonCount = ButtonCount + 1
ReDim Preserve Buttons(1 To ButtonCount)
Set Buttons(ButtonCount).ButtonGroup = ctl
End If
Next ctl
End Sub
If I Dim the Buttons inside the event it does not throws any error and the code also don't works. I searched in a lot of place. Every one Dim the new class before the Initialize event. So, why my one doesn't work? Kindly suggest where is my mistake.
Here is my class module code -
Public WithEvents ButtonGroup As MSForms.Label
Private Sub ButtonGroup_Click()
Msg = "You clicked " & ButtonGroup.Name
MsgBox Msg
ButtonGroup.Name
End Sub
Thanks in advance.
Each label on your form should have it's own instance of the class. The form needs a way to remember each instance - stored in a collection at the form level.
Not sure what the ButtonCount is doing, so have removed it.
Your form code:
Option Explicit '!!!Add option explicit to the top of each module!!!
'It helps avoid so many errors that I don't think three
'exclamations marks is enough!!!!
'>Tools>Options>tick Require variable declaration
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'Each instance of the class is stored here.
Private colLabels As Collection
Private Sub UserForm_Initialize()
Dim BtnEvents As BtnClass
'Initialise the collection to hold the class instances.
Set colLabels = New Collection
Dim ctrl As Control
For Each ctrl In Me.fmHover.Controls
If TypeName(ctrl) = "Label" Then
Set BtnEvents = New BtnClass 'New instance of the class.
Set BtnEvents.AssignButton = ctrl 'Assign the label to it.
colLabels.Add BtnEvents 'Add it to the collection so it's remembered.
End If
Next ctrl
End Sub
Your class module will look like:
Option Explicit 'More exclamation marks!!!!!!!!!
Public WithEvents ButtonGroup As MSForms.Label
'Let the class know what control it's assigned to.
Public Property Set AssignButton(ctrl As Control)
Set ButtonGroup = ctrl
End Property
Private Sub ButtonGroup_Click()
Dim Msg As String
Msg = "You clicked " & ButtonGroup.Name
MsgBox Msg
End Sub
Trying to Accomplish: There are a few TextBoxes and ComboBoxes (ActiveX Controls) arranged in order on an Excel worksheet (Sheet1) like a UserForm. I would like to navigate between these controls by tabbing (pressing TAB key).
Partial Success: I am able to navigate between TextBoxes using the method and codes shown below. However I have no idea how to go about it when ComboBoxes are also involved.
PLEASE NOTE: All these controls are grouped and it has to remain so.
How I was able to navigate between TextBoxes:
Inserted a Class Module by name ClsEventTxtBx and added the following codes
Public WithEvents CTxtBx As MSForms.TextBox
Private Sub CTxtBx_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If KeyCode = vbKeyTab Then
JumpingToNextTextBox CTxtBx
End If
End Sub
Inserted a Standard Module and added the Subroutine JumpingToNextTextBox
Sub JumpingToNextTextBox(ActiveCtl As MSForms.TextBox)
Dim shp As Shape, oleshp As Shape, i As Integer, ctlArr()
For Each shp In Sheet1.Shapes
If shp.Type = msoGroup Then
For Each oleshp In shp.GroupItems
If TypeName(oleshp.OLEFormat.Object.Object) = "TextBox" Then
i = i + 1
ReDim Preserve ctlArr(1 To i)
ctlArr(i) = oleshp.OLEFormat.Object.Name
End If
Next oleshp
End If
Next shp
i = 0
For i = LBound(ctlArr) To UBound(ctlArr)
If ActiveCtl.Name = ctlArr(i) Then
If Not i = UBound(ctlArr) Then
Sheet1.OLEObjects(ctlArr(i + 1)).Activate
Else
Sheet1.OLEObjects(ctlArr(1)).Activate
End If
End If
Next I
End Sub
Added the following codes in ThisWorkBook
Dim ctlArr() As New ClsEventTxtBx
Private Sub Workbook_Open()
Dim i As Integer, shp As Shape, oleshp As Shape, oleArr(), oleObject As oleObject
Dim oleColl As New Collection
For Each shp In Sheet1.Shapes
If shp.Type = msoGroup Then
For Each oleshp In shp.GroupItems
If oleshp.Type = msoOLEControlObject Then
If TypeName(oleshp.OLEFormat.Object.Object) = "TextBox" Then
i = i + 1
ReDim Preserve ctlArr(1 To i)
Set ctlArr(i).CTxtBx = oleshp.OLEFormat.Object.Object
End If
End If
Next oleshp
End If
Next shp
End Sub
I have a custom created class btnClass based on CommandButton class.
Public WithEvents ButtonEvent As MsForms.CommandButton
Private Sub ButtonEvent_Click()
End sub
I have a UserForm1 that have one ListBox, one Label, and hundreds of dynamically created CommandButtons. I assigned btnClass to Buttons. When clicked on buttons, I want the Click event has the following result:
If number of buttons selected (selQty) less than the Label.Caption (totalQty), and this button hasn't been selected before, add value to listBox and change BackColor.
if this button selected previously, change color and decrease number of buttons selected (selQty) by 1.
I tried creating Public variables, but cannot get the result I want. Is this doable?
P.S. when the UserForm1 is activated, it means no button selected; as I click button I change the color of the button and accept it as selected.
Seems like you want to do something like this
clsButtonClick:
Option Explicit
Public WithEvents ButtonEvent As MSForms.CommandButton
Private Sub ButtonEvent_Click()
'pass the button to the procedure in the userform
ButtonEvent.Parent.HandleClick ButtonEvent
End Sub
Userform code:
Option Explicit
Const CLR_SEL As Long = vbRed 'selected color
Const CLR_NOT_SEL As Long = vbGreen 'unselected color
Dim btnCol As Collection
Dim maxQty As Long 'max number selectable
Dim currQty As Long 'number currently selected
'perform some setup
Private Sub UserForm_Activate()
Const NUM_BUTTONS As Long = 10
Dim i As Long, btn As MSForms.CommandButton
Dim o As clsButtonClick
currQty = 0 'number selected
maxQty = 5 'max selectable
Set btnCol = New Collection
'add some buttons
For i = 1 To NUM_BUTTONS
Set btn = Me.Controls.Add("Forms.CommandButton.1", "btn" & i, True)
btn.BackColor = CLR_NOT_SEL
btn.Height = 18
btn.Left = 20
btn.Top = 20 * i
btn.Caption = "Button " & i
Set o = New clsButtonClick
Set o.ButtonEvent = btn
btnCol.Add o
Next i
End Sub
'handle a button click event (button is passed in)
Sub HandleClick(btn As MSForms.CommandButton)
If btn.BackColor = CLR_SEL Then
btn.BackColor = CLR_NOT_SEL
currQty = currQty - 1
Else
If currQty = maxQty Then
MsgBox "no more selections available"
Else
btn.BackColor = CLR_SEL
currQty = currQty + 1
End If
End If
End Sub
Here's something to get you started.
Create a wrapper class which wraps each button and handles its click event. Then when the form loads, loop through the controls and wrap the buttons.
A module level collection is required to hold the references of wrapped buttons (wrapper classes).
The ButtonWrapper class:
Option Explicit
Private WithEvents objButton As MsForms.CommandButton
'Wrap button
Public Function WrapCommandButton(btn As MsForms.CommandButton) As ButtonWrapper
Set objButton = btn
Set WrapCommandButton = Me
End Function
'Button's event handler
Private Sub objButton_Click()
MsgBox objButton.Caption & " was clicked."
End Sub
'Clean up
Private Sub Class_Terminate()
Set objButton = Nothing
End Sub
The code behind the Form:
Option Explicit
Private m_handlers As Collection
'Initialize
Private Sub UserForm_Initialize()
Set m_handlers = New Collection
Dim ctl As Control
For Each ctl In Me.Controls
If TypeName(ctl) = "CommandButton" Then
With New ButtonWrapper
m_handlers.Add .WrapCommandButton(ctl)
End With
End If
Next ctl
End Sub
'Clean up
Private Sub UserForm_Terminate()
Set m_handlers = Nothing
End Sub
Hope this helps.
I have a spreadsheet and create ListBox controls in every cell of a column. I'm trying to capture their selected contents but the examples of capturing events on runtime generated controls all involve using a user form and I'm not using one. I'm new to VBA so how can I reproduce the code below from
How to add events to Controls created at runtime in Excel with VBA
Option Explicit
Dim ButArray() As New Class2
Private Sub UserForm_Initialize()
Dim ctlbut As MSForms.CommandButton
Dim butTop As Long, i As Long
'~~> Decide on the .Top for the 1st TextBox
butTop = 30
For i = 1 To 10
Set ctlbut = Me.Controls.Add("Forms.CommandButton.1", "butTest" & i)
'~~> Define the TextBox .Top and the .Left property here
ctlbut.Top = butTop: ctlbut.Left = 50
ctlbut.Caption = Cells(i, 7).Value
'~~> Increment the .Top for the next TextBox
butTop = butTop + 20
ReDim Preserve ButArray(1 To i)
Set ButArray(i).butEvents = ctlbut
Next
End Sub
My code for generating my controls is
Public Sub CreateListbox()
Dim rCell As Range
Dim rRng As Range
Set rRng = ActiveSheet.Range("AA3:AA45")
For Each rCell In rRng.Cells
Set oLISTBOX = ActiveSheet.OLEObjects.Add(classtype:="Forms.ListBox.1")
With oLISTBOX
.Object.IntegralHeight = False
.Object.Font.Size = 11
.Top = rCell.Top
.Left = rCell.Left
.Width = rCell.Width
.Height = rCell.Height
.LinkedCell = rCell.Address
.ListFillRange = "ValSocDeterm."
.Object.ColumnCount = 3
.MultiSelect = 1
End With
Next rCell
End Sub
I basically want to take the example code for creating buttons on a form to creating ListBoxes on a Sheet.
Something like a class module, called clsCustomListBox containing the following code
Option Explicit
Private WithEvents custom As MSForms.ListBox
Public Function initialise(cbConvert As MSForms.ListBox) As Boolean
Set custom = cbConvert
End Function
Private Sub custom_Click()
MsgBox "Clicked"
End Sub
and then a standard module to go through the sheet and get all the listboxes, or you could just add to the collection, when your code adds them.
Option Explicit
Private cls_CustomListBox As clsCustomListbox
Public colCustomListboxCollection As Collection
Public Sub GetListBoxes()
Dim c As OLEObject
Set colCustomListboxCollection = New Collection
For Each c In Worksheets("Sheet1").OLEObjects
If TypeOf c.Object Is MSForms.ListBox Then
Set cls_CustomListBox = New clsCustomListbox
cls_CustomCombo.initialise c.Object
colCustomListboxCollection.Add c
End If
Next c
End Sub
I havent fully tested as at work, but that's where id start.
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