I'm setting up an Excel worksheet where I need to dynamically generate Active-X buttons and set up a different action for each one.
I get
run time error 459 "Object or class does not support the class of events"
when I launch it.
I've seen similar questions but the solutions have been given for userforms.
My current solution.
I have a custom class module WoExp_FSelect_Btn:
Public WithEvents btn As OLEObject
Public id As Integer
Dim iCount As Long
' Action to handle button click
Private Sub btn_Click()
'*** just for debug: show msgbox with id
MsgBox ("ID: " & id) 'Debug
End Sub
A collection is created with global scope to fit this kind of objects:
Public WoExp_DFileSel_Buttons As New Collection
Then I dynamically create the buttons running the following function inside a loop, i being the loop iteration:
Private Sub WoExp_AddFileSel_Btn(i As Integer)
Dim cmdbtn As OLEObject
Dim FselBtnWithEvents As WoExp_FSelect_Btn
Set cmdbtn = Worksheets("Word Report Gen").OLEObjects.Add(ClassType:="Forms.CommandButton.1", _
Link:=False, DisplayAsIcon:=False, Left:=50, Top:=80, Width:=75, _
Height:=30)
cmdbtn.Left = Worksheets("Word Report Gen").Cells(13 + i, 3).Left
cmdbtn.Top = Worksheets("Word Report Gen").Cells(13 + i, 3).Top
cmdbtn.Name = "WoExpDFileSel_Btn_" + CStr(i)
Set FselBtnWithEvents = New WoExp_FSelect_Btn
Set FselBtnWithEvents.btn = cmdbtn
FselBtnWithEvents.id = i
WoExp_DFileSel_Buttons.Add FselBtnWithEvents
End Sub
All buttons are properly shown if I comment the Set FselBtnWithEvents.btn = cmdbtn line, so I think that the problem is that OLEobject class and WithEvents don't go along.
As the error states, the OLEObject object does not support the Click event. If you go to your class module, select btn from the Object dropdown menu, and then click on the Procedure dropdown menu, you'll see that it only supports GotFocus and LostFocus.
However, when I replaced the Click event with either GotFocus or LostFocus, the same error occurred. So maybe there's some sort of bug.
Related
I have an excel sheet that makes a custom toolbar. Within this toolbar, I have several buttons that use faceIDs, which are no problem. I have a few buttons where I wanted to use custom icons. When I use the custom icons, sometimes the PasteFace works, sometimes it does not, and I get an error. I added an On Error Resume next statement, to see what was happening. Sometimes both buttons paste ok, sometimes just one button, sometimes neither button. I can find no pattern to it working or not working.
My toolbar consists of approximately 24 buttons, and one drop down box. Eleven of the buttons use a custom icon, the remainder use a FaceID. Some buttons are toggled to display or not display based on user needs. The example below shows 2 buttons that will toggle to turn a meal penalty on or off. I only picked these 2 buttons because these are first buttons to use a custom icon.
Sub Make_PayBar()
Dim PayBar As CommandBar
Dim NewButton As CommandBarButton
'Delete existing PayBar toolbar if it exists
Call Kill_PayBar
ThisWorkbook.Activate
On Error Resume Next
'Create New PayBar
Set PayBar = Application.CommandBars.Add(Name:="Payroll Bar", Temporary:=True)
PayBar.Visible = True
PayBar.Position = msoBarTop
... Missing Code, More buttons ...
'Meal Penalty Off Button
Set NewButton = PayBar.Controls.Add(Type:=msoControlButton, Parameter:="Meal_Off")
NewButton.Caption = "Meal Penalty Off"
NewButton.OnAction = "ToggleMeal"
'NewButton.FaceId = 1254 'Backup if pasteface fails
Sheets("Pics").Shapes("Meal_Off").Copy
NewButton.PasteFace
'Meal Penalty On Button
Set NewButton = PayBar.Controls.Add(Type:=msoControlButton, Parameter:="Meal_On")
NewButton.Caption = "Meal Penalty On"
NewButton.OnAction = "ToggleMeal"
'NewButton.FaceId = 1253 'Backup if pasteface fails
Sheets("Pics").Shapes("Meal_On").Copy
NewButton.PasteFace
NewButton.Visible = False
... Missing Code, More buttons ...
End sub
If the Resume Next is not used, the error may occurs on either of the two pasteface statements.
Is there something in my code making PastFace unreliable?
If PasteFace is inherently unreliable, is there a way to check for a successful paste, and repeat if it wasn't?
Is there a better way to do this?
Worksheets have hidden collections that hold pictures and ActiveX controls. The VBA also has a hidden Picture type. Pictures have a CopyPicture method that is more consistent then `Shape.Copy.
Press F2 to open the Object Browser, right click and choose Show Hidden Members
Function picMeal_Off() As Picture: Set picMeal_Off = ThisWorkbook.Worksheets("Pics").Pictures("Meal_Off"): End Function
Function picMeal_on() As Picture: Set picMeal_on = ThisWorkbook.Worksheets("Pics").Pictures("Meal_on"): End Function
Sub Make_PayBar()
Dim PayBar As CommandBar
Dim NewButton As CommandBarButton
Set PayBar = Application.CommandBars.Add(Name:="Payroll Bar", Temporary:=True)
PayBar.Visible = True
PayBar.Position = msoBarTop
Set NewButton = PayBar.Controls.Add(Type:=msoControlButton, Parameter:="Meal_Off")
NewButton.Caption = "Meal Penalty Off"
NewButton.OnAction = "ToggleMeal"
picMeal_Off.CopyPicture
NewButton.PasteFace
End Sub
I created functions to refer to the Pictures by using this macro:
Sub PrintPitureDefs(ws As Worksheet)
Const BaseCode As String = "Function picCodeName() As Picture:Set picCodeName = ThisWorkbook.Worksheets(""WorksheetName"").Pictures(""PictureName""):End Function"
Dim Code As String
Dim Img As Picture
For Each Img In ws.Pictures
Code = Replace(BaseCode, "WorksheetName", ws.Name)
Code = Replace(Code, "PictureName", Img.Name)
Code = Replace(Code, "CodeName", Replace(Img.Name, " ", "_"))
Debug.Print Code
Next
End Sub
I have created a tool using Excel to gather inputs from a user and use it to do some processing of data. I have created a UI on a worksheet with a bunch of ActiveX controls (TextBox, ListBox, ComboBox).
Part of the ActiveX controls are dynamic - they are added at run time based on "metadata" that the tool admin creates on a second worksheet. Metadata contains the field name, type of ActiveX control, position of the control, ListRange to populate values, Multi-Text/Multi-Select flag, etc.
I am able to successfully add the ActiveX controls to the UI worksheet. However, now I want to add functionality for ActiveX TextBox controls to show a default text, when the control gets focus - default text gets removed, when the control loses focus - if user has entered any data it remains otherwise the default text shows up again.
Public Sub df_segment_GotFocus()
Dim wb As Workbook
Set wb = ThisWorkbook
Set form_sheet = Worksheets(Sheet1.Name)
If form_sheet.OLEObjects("df_segment") Is Nothing Then
Else
'When user begins to type, remove the help text and remove Italics
Dim seg_val As String
seg_val = form_sheet.OLEObjects("df_segment").Object.Value
If seg_val = "e.g. Desktop-Mac,Desktop-Win,Mobile-OSX" Then
form_sheet.OLEObjects("df_segment").Object.Font.Italic = False
form_sheet.OLEObjects("df_segment").Object.Value = ""
Else
form_sheet.OLEObjects("df_segment").Object.Value = seg_val
End If
End If
End Sub
Public Sub df_segment_LostFocus()
Dim wb As Workbook
Set wb = ThisWorkbook
Set form_sheet = Worksheets(Sheet1.Name)
If form_sheet.OLEObjects("df_segment") Is Nothing Then
Else
'Incase user doesn't enter any values, show the help text again
Dim seg_val As String
seg_val = form_sheet.OLEObjects("df_segment").Object.Value
If seg_val = "" Then
form_sheet.OLEObjects("df_segment").Object.Font.Italic = True
form_sheet.OLEObjects("df_segment").Object.Value = "e.g. Desktop-Mac,Desktop-Win,Mobile-OSX"
Else
form_sheet.OLEObjects("df_segment").Object.Value = seg_val
End If
End If
End Sub
In the sample code above, you can see that I am using the exact name of the control to setup the GotFocus and LostFocus event handlers. However, since my UI is metadata driven, the controls will be added/removed dynamically and I wouldn't know the name of the controls to explicitly add the event handlers.
I looked up the forums and implemented this:
a.) Implemented a Class Module
Public WithEvents df_TextBox As MSForms.TextBox
Public df_TextBox_Name As String
Private Sub df_TextBox_Change()
Dim wb As Workbook
Set wb = ThisWorkbook
Set form_sheet = Worksheets(Sheet1.Name)
Set metadata_sheet = Worksheets(Sheet2.Name)
Dim obj_name As String
obj_name = df_TextBox_Name
obj_val = form_sheet.OLEObjects(obj_name).Object.Value
MsgBox "Change in TextBox" & obj_val
End Sub
b.) Created objects for the Class where I instantiate the control objects
ElseIf d_Type = "TextBox" Then
df_obj.Object.Value = d_def_val
df_obj.Object.Font.Italic = True
If d_Multi = 1 Then
df_obj.Object.MultiLine = True
End If
'--------------------------------------------------------------
'part where we add the custom events for GotFocus and LostFocus
'--------------------------------------------------------------
ReDim Preserve TextBox_Event_Array(1 To i)
Set TextBox_Event_Array(i).df_TextBox = df_obj.Object
TextBox_Event_Array(i).df_TextBox_Name = df_obj.Name
Problem Statements
1.) When I create the class module, I don't see the GotFocus and LostFocus events available. Only Change, KeyDown/Press/Up, MouseDown/Move/Up
2.) I created a Change event handler just to test the Class Module but I do not see it getting triggered.
Any suggestions on how can I fix the problem or any alternate solutions?
I have a VBA application with a lot of controls.
I would like accessing the controls with an order of reading during For-Next loop.
' Parcours des contrôles de l'userform
For Each cCont In Me.Controls
' TypeName(cCont)
MsgBox (cCont.Name)
Next cCont
Actually, I think I am accessing with creation date...
Do you know if I could configure the order of reading ?
Thanks
One way to do this is to sort them by the TabIndex property. Set the tab indices to the desired order, then use this:
Private Sub test()
Dim cCont As Control
Dim i As Integer
Dim maxIndex As Integer
Dim controls As Object
Dim key As Variant
Set controls = CreateObject("Scripting.Dictionary")
'Add controls to dictionary, key by tabindex property
For Each cCont In Me.controls
maxIndex = IIf(maxIndex < cCont.TabIndex, cCont.TabIndex, maxIndex)
controls.Add cCont.TabIndex, cCont
Next cCont
'Get controls in order
For i = 0 To maxIndex
If controls.exists(i) Then
MsgBox controls(i).Name
End If
Next i
End Sub
The posted code is a great solution, which I made workable for me with this minor change. I passed the user form, because I used the code in a module. I excluded Label, CommandButton, and Image in order to make Valon Miller's code work for me, otherwise the depicted runtime error wouldruntime error '-2147352573 (800 200037': Member not found show.
Private Sub test(frm As UserForm)
Dim cCont As Control
Dim i As Integer
Dim maxIndex As Integer
Dim controls As Object
Dim key As Variant
Set controls = CreateObject("Scripting.Dictionary")
'Add controls to dictionary, key by tabindex property
For Each cCont In frm.controls
If TypeName(cCont) <> "Label" And _
TypeName(cCont) <> "Image" And _
TypeName(cCont) <> "CommandButton" Then
maxIndex = IIf(maxIndex < cCont.TabIndex, cCont.TabIndex, maxIndex)
controls.Add cCont.TabIndex, cCont
End If
Next cCont
'Get controls in order
For i = 0 To maxIndex
If controls.exists(i) Then
Debug.Print controls(i).Name & vbTab & i
MsgBox controls(i).Name
End If
Next i
End Sub
--------------------------------------------
Originally I needed a solution to get the order of sql statements synced with the order of my form controls. I wanted to do this:
fld1 = recordset1.value
fld2 = recordset2.value
fld3 = recordset3.value
was looking for a solution to get my controls and my SQL statement in order like field1 -> recordset.value1.
So instead of ordering my controls using the taborder, I created control arrays. i.e.
sub useControlArray()
dim a as variant, rs as new recordset, strSQL as string
strSQL = "select fld1, fld2, fld3 from table"
rs.open strSQL, connection
a = array("fld1", "fld2", "fld3")
'This array would help like this:
for i = lbound(a) to ubound(a)
frm.controls(a(i)) = rs(i)
debug.print frm.controls(a(i)) ' Form is a user form
next i
end sub
This would restrict the controls to the number of controls needed to fill them using the same order as in my SQL statement and I did not need to pay attention to whether or not a control would exist.
I hope this is helpful.
I can't figure out what I'm doing wrong here. I added a button to an Excel Sheet programmatically. I am trying to assign an accelerator key, but it does not get assigned. The relevant code is:
Sub addPrint(sht, Optional fromLeft, Optional fromTop)
If IsMissing(fromLeft) Then fromLeft = 180
If IsMissing(fromTop) Then fromTop = 10
Set printbut = sht.Buttons.Add(fromLeft, fromTop, 50, 20)
printbut.Name = "PrintButton"
printbut.OnAction = "Sheet4.printButton"
printbut.Characters.Text = "Print/PDF"
printbut.Accelerator = "P"
End Sub
The 'P' does not get underlined and Alt-P does nothing.
This is the way to add an ActiveX-Button:
Sub addActiveXCommandButton(sht As Worksheet, Optional left As Single = 100, Optional top As Single = 100)
Dim btn As OLEObject
'
'create Button
'
Set btn = ActiveSheet.OLEObjects.Add(ClassType:="Forms.CommandButton.1", Link:=False, _
DisplayAsIcon:=False, left:=left, top:=top, _
Width:=105.75, Height:=36)
Debug.Print TypeName(btn) ' this returns OLEObject as a wrapper of the CommandButton
Debug.Print TypeName(btn.Object) ' this returns CommandButton - the activeX-Object
'
' access the CommandButton-Object and set the Accelerator value
'
btn.Object.Accelerator = "B"
End Sub
However, I am not certain, that the Accelerator Button may be accessed. On testing, the Accelerator Button could bot be accessed using the Alt-key.
I use a solution with a button and an application.onKey-definition that both access the same procedure.
I am trying to create a context menu item to add a row on a sheet at the position of the selected cell and do some more stuff as well. This is done using a custom object of the class clsMyControls to handle all of my custom controls. The controls created, call a macro in a standard module, which forewards the command to the custom object MyControls. MyControls will foreward the command to another object using CallByName.
This way all of my custom Objects can use MyControls to create controls and to route the commands to their own methods.
The routing works fine. I can read the Address of the selected cell, alter the Value etc. However, when I try to insert or delete a row, nothing happens, not even an error.
Below is the code to reproduce the issue. It implements two ways to create the control and to call the Insert Method. The one I have issues with, and the simple way that works.
The second way does not use MyControls and creates its own control. This way it is possible to insert a row.
Both ways call the same Insert method of the same object.
EDIT: [
The difference is the parameters that are passed to the macro. As soon as a Parameter is built into the .onAction-String of the control, the insert method fails. WHY?
]
First, the (simplified) Class clsMyControls which is supposed to handle all my custom controls
Option Explicit
Option Base 1
Private myItems As Collection 'the collection to carry all controls created here
Private myObjects As Collection 'the collection of objects that create controls by means of this object
'____________________________
Private Sub Class_Initialize()
Set myItems = New Collection
Set myObjects = New Collection
End Sub
'____________________________
Public Sub ReturnFromMacro(Optional args As Variant)
Debug.Print "ReturnFromMacro " & Selection.Address
'Selection.EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove 'It does not work here
CallByName myObjects(args(1)), args(2), VbMethod 'forewarding
End Sub
'____________________________
Public Sub CreateEntry(ObjectReference As Object, ProcedureName As String, Caption As String)
Dim control As Object
With Application.CommandBars("Cell").Controls
Set control = .Add(Type:=msoControlButton, Before:=1, Temporary:=True)
End With
With control
.Caption = Caption
.onAction = ThisWorkbook.name & "!myControlsMacro(" & Chr(34) & "InsertTest" & Chr(34) & "," & Chr(34) & "Insert" & Chr(34) & ")"
.Tag = Application.ThisWorkbook.name & "_clsMyControls"
.beginGroup = True
End With
myItems.Add control, Caption 'storing the newly created Control in a collection
myObjects.Add ObjectReference, ObjectReference.name 'storing the object in a collection to later call it
End Sub
Next, the Class clsInsertTest that uses myControls to create a custom control and owns the Insert method that is called.
In addition it creates an own custom control that bypasses the Object MyControls
Option Explicit
Dim control As Object 'the object to carry the Control that is created in this class
'____________________________
Property Get name() As String
name = "InsertTest"
End Property
'____________________________
Private Sub Class_Initialize()
'asking myControls to create a control, passing Reference THIS object, The method to be called, the name of teh control
MyControls.CreateEntry Me, "Insert", "InsertTest"
createOwnControl 'the simple way
End Sub
'____________________________
Public Sub Insert()
Debug.Print "Insert Called at " & Selection.Address
Selection.Value = "clsInsertTest was here"
Selection.EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
End Sub
'____________________________
Private Sub createOwnControl()
With Application.CommandBars("Cell").Controls
Set control = .Add(Type:=msoControlButton, Before:=1, Temporary:=True)
End With
With control
.Caption = "InsertTest2"
.onAction = ThisWorkbook.name & "!InserTest2Macro"
.Tag = Application.ThisWorkbook.name & "_clsMyControls"
.beginGroup = True
End With
End Sub
and last, the module containing initialization, cleanup and the Subs that are called by the custom controls and foreward to the objects
MyControlsMacro is called by the control built by MyControls
InsertTest2Macro is called by the control built by the InserTest Object directly
Option Base 1
Public InsertTest As clsInsertTest 'test object
Public MyControls As clsMyControls 'the Object to handle my controls
'____________________________
Sub CleanUp() 'what it says
Set InsertTest = Nothing
Set MyControls = Nothing
Dim control As Object
For Each control In Application.CommandBars("Cell").Controls
If control.Tag = Application.ThisWorkbook.name & "_clsMyControls" Then
control.Delete
End If
Next control
'Application.CommandBars("Cell").Reset 'just in case...
End Sub
'____________________________
Sub CreateTestObject() 'create my objects (calld at wb open)
Set MyControls = New clsMyControls
Set InsertTest = New clsInsertTest
End Sub
'____________________________
Public Sub myControlsMacro(ParamArray args() As Variant) 'the Sub to foreward the commands to my Controls handler
Dim handover() As String
Dim wert As Variant
Debug.Print "myControlsMacro called at " & Selection.Address
'Selection.EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove 'does not work
'transforming the ParamArray "args" into an Array of strings to be able to pass it to the next method
For Each wert In args
If Not (Not handover) Then
ReDim Preserve handover(UBound(handover) + 1)
Else
ReDim handover(1)
End If
handover(UBound(handover)) = wert
Next
'calling the object to handle my Controls
MyControls.ReturnFromMacro handover
End Sub
'____________________________
Public Sub InserTest2Macro() ' the simple way
Debug.Print "InserTest2Macro called at " & Selection.Address
CallByName InsertTest, "Insert", VbMethod
End Sub
I have found a solution here:
Excel VBA CommandBar.OnAction with params is difficult / does not perform as expected
The single quotes in the .onAction and removing brackets made it work.
.onAction = ThisWorkbook.name & "!'myControlsMacro " & Chr(34) & "InsertTest" &_
Chr(34) & "," & Chr(34) & "Insert" & Chr(34) & "'"