Programmatically adding a commandbutton to a userform - vba

In excel vba I have added a commandbutton to userform... like below
Set ctrl = Me.Controls.Add( _
bstrProgID:="Forms.CommandButton.1", _
Name:="CommandButton1", Visible:=True)
Now I wanted to know how would I tell it what to do when it is clicked?

This is one of those techniques that vba will let you do, but you probably shouldn't. For all the same reasons you shouldn't use code that alters your code.
That said, here is how to do what you want. First insert a class module and name it DynBtn, then paste this code into it:
Private WithEvents mobjBtn As MSForms.CommandButton
Private msOnAction As String
''// This has to be generic or call by name won't be able to find the methods
''// in your form.
Private mobjParent As Object
Public Property Get Object() As MSForms.CommandButton
Set Object = mobjBtn
End Property
Public Function Load(ByVal parentFormName As Object, ByVal btn As MSForms.CommandButton, ByVal procedure As String) As DynBtn
Set mobjParent = parentFormName
Set mobjBtn = btn
msOnAction = procedure
Set Load = Me
End Function
Private Sub Class_Terminate()
Set mobjParent = Nothing
Set mobjBtn = Nothing
End Sub
Private Sub mobjBtn_Click()
CallByName mobjParent, msOnAction, VbMethod
End Sub
Now to use this in your form, create a blank user form and paste this code into it:
Private Const mcsCmdBtn As String = "Forms.CommandButton.1"
Private mBtn() As DynBtn
Private Sub UserForm_Initialize()
Dim i As Long
ReDim mBtn(1) As DynBtn
For i = 0 To UBound(mBtn)
Set mBtn(i) = New DynBtn
Next
''// One Liner
mBtn(0).Load(Me, Me.Controls.Add(mcsCmdBtn, "Btn1", True), "DoSomething").Object.Caption = "Test 1"
''// Or using with block.
With mBtn(1).Load(Me, Me.Controls.Add(mcsCmdBtn, "Btn2", True), "DoSomethingElse").Object
.Caption = "Test 2"
.Top = .Height + 10
End With
End Sub
Public Sub DoSomething()
MsgBox "It Worked!"
End Sub
Public Sub DoSomethingElse()
MsgBox "Yay!"
End Sub
Private Sub UserForm_Terminate()
Erase mBtn
End Sub

Related

How to set properties of userform inside function

On the UserForm_Activate() code, I want to call a function (which has not been created yet) that will set scroll properties of the Userform. See code below.
Private Sub UserForm_Activate()
MakeFormResizable
End Sub
On the Modules4 sheet, I have the following code:
Public Sub MakeFormResizable()
Me.ScrollHeight = .Height
Me.ScrollWidth = .Width
End Sub
When I run the code that I have pasted, I get the error "Compile error: Invalid or unqualified reference."
It will not work as Me is local ….
Perhaps you want to pass the Userform object to a Public sub, as follows:
Public Sub MakeFormResizable(ByRef aUserform As MSForms.UserForm)
With aUserform
'Do your stuff
End With
End Sub
Got it!
Private Sub UserForm_Activate()
Dim MyObject
Set MyObject = Me
MakeFormResizable MyObject
End Sub
Public Sub MakeFormResizable(MyObject)
With MyObject
.ScrollHeight = .Height
End If
End With
End Sub

VBA CommandBarButton does not run code OnAction

Once the button is pressed it does not perform the subroutine defined OnAction method.
I have checked all the Security options in Access are enabled and have written the same code in different ways.
I have tried to run a function with the OnAction method instead.
Private Sub Check_Status_Click()
Dim cmdBAR As CommandBar
Dim cmdButton1 As CommandBarButton
Set cmdBAR = CommandBars.Add(, msoBarPopup, False, True)
Set cmdButton1 = cmdBAR.Controls.Add(msoControlButton)
cmdButton1.Caption = "Dale"
cmdButton1.OnAction = "Dale"
cmdBAR.ShowPopup
'Clean
Set cmdBAR = Nothing
Set cmdButton1 = Nothing
End Sub
Public Sub Dale()
MsgBox "hola"
End Sub
I dont get any error, just it is not doing anything even the menu shows up.
Actually OnAction subroutine needs to be
public sub
in public module
So you should change your code to something like this:
...
cmdButton1.Caption = "Dale"
cmdButton1.OnAction = "Dale"
cmdBAR.ShowPopup
...
And place your sub into some public module:
Public Sub Dale()
MsgBox "hola"
End Sub

Handling custom events using modeless form & user defined classes

I'm trying to display the progress of various routines on a modeless form, by having those routines raise custom events detailing their progress. The form should handle those events to display appropriate information.
The problem is that although RaiseEvent is called, the event handlers don't then do anything.
The intended result of the following code is the two debug.prints would be called whenever an event is raised by triggerTest.
The only success I've had is with raising the error within the userform, by CommandButton1_Click in the following code. The form's event handler then kicks in (rather redundantly, but perhaps that means I'm on the right path).
Thanks
Event class clsChangeProgressTrigger
Option Explicit
Public Enum geProgressStatus
geProgressStatusComplete = -1
geProgressStatusRestart = -2
End Enum
Public Event ChangeProgress(dProgress As Double, sProcedure As String)
'
Public Sub Update(dProgress As Double, sProcedure As String)
RaiseEvent ChangeProgress(dProgress, sProcedure)
End Sub
Public Sub Complete(sProcedure As String)
RaiseEvent ChangeProgress(geProgressStatusComplete, sProcedure)
End Sub
Public Sub Restart(sProcedure As String)
RaiseEvent ChangeProgress(geProgressStatusRestart, sProcedure)
End Sub
User form frmOutput
Option Explicit
Private WithEvents mProgressTrigger As clsChangeProgressTrigger
'
Private Sub CommandButton1_Click()
Call mProgressTrigger.Update(12.34, "SomeValue")
End Sub
Private Sub CommandButton2_Click()
Call modZTest.triggerTest
End Sub
Private Sub UserForm_Initialize()
Set mProgressTrigger = New clsChangeProgressTrigger
End Sub
Private Sub mProgressTrigger_ChangeProgress(dProgress As Double, sProcedure As String)
Debug.Print "Form Event Handled"
End Sub
Event test class clsEventTest
Option Explicit
Private WithEvents mProgressTrigger As clsChangeProgressTrigger
'
Private Sub mProgressTrigger_ChangeProgress(dProgress As Double, sProcedure As String)
Debug.Print "Class Event Handled"
End Sub
Private Sub Class_Initialize()
Set mProgressTrigger = New clsChangeProgressTrigger
End Sub
Test wrapper in public module modZTest
Public Sub triggerTest()
Application.EnableEvents = True
' Instantiate Trigger class for this routine
' Dim cChangeProgressTrigger As clsChangeProgressTrigger
Set gChangeProgressTrigger = New clsChangeProgressTrigger
' Instantiate Event Test class, which should handle raised event
Dim cEventTest As clsEventTest
Set cEventTest = New clsEventTest
' Instantiate user form, which should handle raised event
Set gfrmOutput = New frmOutput ' Modeless form, gfrmOutput has global scope
gfrmOutput.Show
Stop
' Raise an event
Call gChangeProgressTrigger.Complete("SomeValue")
' Tidy Up
Set gfrmOutput = Nothing
Set gChangeProgressTrigger = Nothing
Set cEventTest = Nothing
End Sub
Thanks Dee, that helped me along to the solution.
With this declared as global scope:
Public gChangeProgressTrigger As clsChangeProgressTrigger
I had to change the class / form level initialisations as follows:
Private Sub UserForm_Initialize()
' Set mProgressTrigger = New clsChangeProgressTrigger ' Old
Set mProgressTrigger = gChangeProgressTrigger ' New
End Sub
and
Private Sub Class_Initialize()
' Set mProgressTrigger = New clsChangeProgressTrigger ' Old
Set mProgressTrigger = gChangeProgressTrigger ' New
End Sub
Then the event handlers fired as desired.

Creating A Custom Event With VBA

I'm trying struggling to understand how to create a custom event using class modules in VBA.
I've put together the simple following example. You put a value in A1 and B1 and then re activate the sheet to calculate the sum of the two and then I hoped an event would fire to warn of calculation, but nothing happens.
I'd be very grateful for any help solving this example.
Class module cCalc:
Dim m_wks As Worksheet
Public Event BeforeCalc()
Property Set Worksheet(wks As Worksheet)
Set m_wks = wks
End Property
Public Sub Calc()
Dim dVal1 As Double
Dim dVal2 As Double
With m_wks
dVal1 = .Range("A1").Value
dVal2 = .Range("B1").Value
RaiseEvent BeforeCalc
.Range("C1").Value = dVal1 + dVal2
End With
End Sub
In a module mGlobal:
Public gCalc As cCalc
In the code behind Sheet1:
Private WithEvents calcEvent As cCalc
Private Sub calcEvent_BeforeCalc()
MsgBox "About to Calc!", vbInformation
End Sub
Private Sub Worksheet_Activate()
Set gCalc = New cCalc
Set gCalc.Worksheet = ActiveSheet
gCalc.Calc
End Sub
You can't declare event-driven classes in modules. You'll need to set the cCalc reference in gModule equal to the object you declared WithEvents in Sheet1. Change your code in Sheet1 to what i wrote below and it will work:
Private WithEvents calcEvent As cCalc
Private Sub calcEvent_BeforeCalc()
MsgBox "About to Calc!", vbInformation
End Sub
Private Sub Worksheet_Activate()
Set calcEvent = New cCalc 'Instantiate the WithEvents object above
Set mGlobal.gCalc = calcEvent 'Set the object declared in gModule
Set mGlobal.gCalc.Worksheet = ActiveSheet
mGlobal.gCalc.Calc
End Sub
Note that this is using the variable you put in gModule... The event that is actually called is still calcEvent_BeforeCalc(), which is good as this way you can have n number of objects defined in gModule that would all fire off the same event code when the event is triggered.
To simplify the code, you could always just write:
Private Sub Worksheet_Activate()
Set calcEvent = New cCalc
Set calcEvent.Worksheet = ActiveSheet
calcEvent.Calc
End Sub

Tearing Down Circular References

The following code creates a circular reference for each element in the collection. Is the code in the UserForm_Terminate routine sufficient to tear down the relationships to allow the memory to be released? Or is there a requirement to use pointers and weak references?
If so/not what is the best method for testing whether the objects have been released?
Userform Code:
Option Explicit
Implements IBtnClick
Dim coll As Collection
Private Sub UserForm_Initialize()
Dim x As Long
Dim e As CBtnEvents
Set coll = New Collection
For x = 1 To 5
Set e = New CBtnEvents
Set e.btn = Me.Controls.Add("Forms.CommandButton.1")
e.ID = x
e.Register Me
With e.btn
.Height = 30
.Width = 30
.Top = 10
.Left = .Width * x
End With
coll.Add e
Next x
End Sub
Private Sub UserForm_Terminate()
Dim itm
For Each itm In coll
msgbox itm.ID
itm.Unregister
Next itm
End Sub
Private Sub IBtnClick_click(ID As Long)
MsgBox ID
End Sub
IBtnClick Code:
Public Sub click(ID As Long)
End Sub
CBtnEvents Code:
Private WithEvents p_btn As MSForms.CommandButton
Private p_ID As Long
Private click As IBtnClick
Public Property Set btn(value As MSForms.CommandButton)
Set p_btn = value
End Property
Public Property Get btn() As MSForms.CommandButton
Set btn = p_btn
End Property
Public Sub Register(value As IBtnClick)
Set click = value
End Sub
Public Sub Unregister()
Set click = Nothing
End Sub
Private Sub p_btn_Click()
click.click p_ID
End Sub
Public Property Get ID() As Long
ID = p_ID
End Property
Public Property Let ID(ByVal lID As Long)
p_ID = lID
End Property
Private Sub Class_Terminate()
MsgBox p_ID
End Sub
I have included the VB6 tag as I think the question applies equally, but I am using Excel VBA.
This is how we (manually) keep our instance book-keeping collection:
In every class/form/control we place something like this
Option Explicit
DefObj A-Z
Private Const MODULE_NAME As String = "cTransStub"
'=========================================================================
' Constants and member variables
'=========================================================================
' Consts here
' Vars here
#If DebugMode Then
Private m_sDebugID As String
#End If
' Props here
' Methods here
'=========================================================================
' Base class events
'=========================================================================
#If DebugMode Then
Private Sub Class_Initialize()
DebugInstanceInit MODULE_NAME, m_sDebugID, Me
End Sub
Private Sub Class_Terminate()
DebugInstanceTerm MODULE_NAME, m_sDebugID
End Sub
#End If
Sample implementation of helper DebugInstanceInit/Term subs that populate DebugIDs collection:
Public Sub DebugInstanceInit(sModuleName As String, sDebugID As String, oObj As Object)
Dim sCount As String
Dim lObjPtr As Long
Dim sObjCtx As String
On Error Resume Next
sDebugID = sDebugID & GetDebugID()
If DebugIDs Is Nothing Then
Else
...
lObjPtr = ObjPtr(oObj)
DebugIDs.Add sDebugID & " " & LIB_NAME & "." & sModuleName & "|&H" & Hex(lObjPtr) & "|" & Format$(time, "hh:mm:ss") & "|" & sObjCtx & "|", "#" & sDebugID
End If
...
If Not DebugConsole Is Nothing Then
DebugConsole.RefreshConsole
End If
On Error GoTo 0
End Sub
Public Sub DebugInstanceTerm(sModuleName As String, sDebugID As String)
On Error Resume Next
If DebugIDs Is Nothing Then
Else
DebugIDs.Remove "#" & sDebugID
End If
...
If Not DebugIDs Is Nothing Then
If DebugIDs.Count = 0 Then
Debug.Print "DebugIDs collection is empty"; Timer
End If
End If
If Not DebugConsole Is Nothing Then
DebugConsole.RefreshConsole
End If
On Error GoTo 0
End Sub
Upon program termination we warn for any object leaking in DebugIDs collection.