How do I link a button created with VBA with a procedure in another module?

[Glory]

Code creates button. How do I link the button with some code?

ThisWorkbook.ActiveSheet.OLEObjects.Add ClassType:="Forms.CommandButton.1", _
                                        Height:=32, _
                                        Object:="Update", _
                                        Left:=292, _
                                        Top:=34, _
                                        Width:=102

 

[Glory]

Your code entered break mode too, but it hooked the button.

So I'm wondering why the code I wrote doesn't hook the button.

 

[Jaafar Tribak]

Your code entered break mode too, but it hooked the button.

So I'm wondering why the code I wrote doesn't hook the button.

I am not sure about the internals of why the CopyMemory aproache preserves the variables.

It seems that the copymemory doesn't increase the reference counter of an object in this case the worksheet object. but as I said this is an obscure part of COM so I am not sure.

Can you live with the CopyMemory solution I posted ? If not you will have to use the OnTime method. I don't think you can find another solution.

 

[Glory]

Live with it? I could breed with it.

Thanks Jaafar.

Edit: You ever tried setting your avatar as a desktop background? Dunno if it works on Windows 7, know it didn't on Vista. But this PC's running XP and it's real trippy.

 

[Jaafar Tribak]

Ok Glory. I've digged deeper into this and I seem to have managed to keep the whole code for creating the runtime buttons inside the Class and still allow you to create as many buttons as you wish (at least when I tested it)- all you have to do is pass the Button Properties to the MakeTheButton Method when instantiating the Class.

The code is rather involved but I liked the challenge.


To add the runtime CommandButton use this :

Option Explicit

Private oCmbInstance As InventoryUpdater_Class

Sub AddButton()

    Set oCmbInstance = New InventoryUpdater_Class
    
    oCmbInstance.MakeTheButton _
    Sheet:=Sheets(1), ButtonName:="Glory", Caption:="Click me!!", _
    Left:=30, Top:=30, Width:=100, Height:=50

End Sub

here is the Class code :

Option Explicit

Private WithEvents oCmb As CommandButton

Private Declare Function SetTimer Lib "user32" _
(ByVal hWnd As Long, ByVal nIDEvent As Long, _
ByVal uElapse As Long, ByRef lpTimerFunc As Byte) As Long

Private Declare Function KillTimer Lib "user32" _
(ByVal hWnd As Long, ByVal nIDEvent As Long) As Long

Private Declare Sub CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" (Destination As Any, Source As Any, _
ByVal Length As Long)

Private sButtonName As String
Private VBS_FILE As String
Private lTimerID As Long
Private mlngInterval As Long
Private bytData(12) As Byte

    
'=======================================================
'WARNING !!!
'THE TimerProc MUST ALWAYS BE THE FIRST PROCEDURE IN THE CLASS !!!!  =
Public Sub TimerProc()

    On Error Resume Next
    
    If lTimerID <> 0 Then
        Call KillTimer(0, lTimerID)
        lTimerID = 0
    End If
    
    Set oCmb = ActiveSheet.OLEObjects(sButtonName).Object
    
    Kill VBS_FILE

End Sub
'=======================================================


Private Sub oCmb_Click()
 
    MsgBox "Hello " & "'" & oCmb.Name & "'"

End Sub


Public Sub MakeTheButton( _
Sheet As Worksheet, _
ButtonName As String, _
Optional Caption As String, _
Optional Left As Variant, _
Optional Top As Variant, _
Optional Width As Variant, _
Optional Height As Variant _
)

    On Error Resume Next
    
    'store the button name
    sButtonName = ButtonName
    
    'create a temp vbs file on the fly.
    VBS_FILE = Environ("Temp") & "\AddButtons.vbs"  '
    
    Open VBS_FILE For Output As #1
    
        Print #1, "set wb=Getobject(" & Chr(34) & _
        ThisWorkbook.FullName & Chr(34) & ")"
        Print #1, "On Error Resume Next"
        'add the Button control from the vbs file to preserve the variables.
        Print #1, "Set Cmb=Wb.Sheets(""" & Sheet.Name & """).OLEObjects.Add (""Forms.CommandButton.1"")"
        Print #1, "Cmb.Name=" & Chr(34) & ButtonName & Chr(34) & ""
        If Not IsMissing(Caption) Then Print #1, "Cmb.Object.Caption=" & Chr(34) & Caption & Chr(34)
        If Not IsMissing(Left) Then Print #1, "Cmb.Left=" & Chr(32) & Str(Left) & Chr(32)
        If Not IsMissing(Top) Then Print #1, "Cmb.Top=" & Chr(32) & Str(Top) & Chr(32)
        If Not IsMissing(Width) Then Print #1, "Cmb.Width=" & Chr(32) & Str(Width) & Chr(32)
        If Not IsMissing(Height) Then Print #1, "Cmb.Height=" & Chr(32) & Str(Height) & Chr(32)
    
    Close #1
    
    'execute the background vbs file.
    Shell "WScript.exe " & VBS_FILE
    '
    If lTimerID = 0 Then
        'hook the button click event.
        lTimerID = SetTimer(0&, 0&, 1000, bytData(0))
    End If

End Sub

Private Sub Class_Initialize()

    Dim lClassPtr As Long
    
    lTimerID = 0
    
    CopyMemory lClassPtr, Me, 4 'lngX=ObjPtr(me)
    
    bytData(0) = &H68
    CopyMemory bytData(1), lClassPtr, 4 'push this (me) on stack
    
    bytData(5) = &HE8
    CopyMemory bytData(6), _
    GetVTableAddress(Me, 7) - VarPtr(bytData(10)), 4 'call TimerProc
    'value of 7 is used because TimerProc is actually the 8th function in
    'the VTable
    'after QueryInterface, AddRef, Release, GetTypeInfoCount, GetTypeInfo,
    'GetIDsOfNames , Invoke
    
    bytData(10) = &HC2
    bytData(11) = &H10
    bytData(12) = &H0 'ret 10 --- return from
    'callback, removing 4 parameters from stack
    
End Sub

Private Function GetVTableAddress _
(ByVal objRef As Object, ByVal Offset As Long) As Long

    Dim lClassPtr As Long
    
    CopyMemory lClassPtr, ByVal ObjPtr(objRef), 4 'Get pointer to VTable
    CopyMemory GetVTableAddress, ByVal lClassPtr + Offset * 4, 4 'Get function
    'pointer

End Function

AS for the Avatar , I really don't remember where I got it from so I never tried anything with it.

 

[Jaafar Tribak]

Ignore the previous code . Here is a much better and more stable update :

Workbook demo


Caller code ( adds 4 CommandButtons to the activesheet and hooks them)

Option Explicit

Private oCmbInstance As InventoryUpdater_Class

Private oCol As New Collection


'Add four CommandButtons and hook each of them.
Sub AddButtons()

    'button 1
    Set oCmbInstance = New InventoryUpdater_Class
    
    oCmbInstance.MakeTheButton _
    Sheet:=ActiveSheet, ButtonName:="Glory", Caption:="Click me!!", _
    Left:=30, Top:=30, Width:=100, Height:=40
    
    oCol.Add oCmbInstance
    
    'button 2
    Set oCmbInstance = New InventoryUpdater_Class
    
    oCmbInstance.MakeTheButton _
    Sheet:=ActiveSheet, ButtonName:="Ruddles", Caption:="Click me!!", _
    Left:=30, Top:=80, Width:=100, Height:=40
    
    oCol.Add oCmbInstance
    
    'button 3
    Set oCmbInstance = New InventoryUpdater_Class
    
    oCmbInstance.MakeTheButton _
    Sheet:=ActiveSheet, ButtonName:="Jaafar", Caption:="Click me!!", _
    Left:=160, Top:=30, Width:=100, Height:=40
    
    oCol.Add oCmbInstance
    
    'button 4
    Set oCmbInstance = New InventoryUpdater_Class
    
    oCmbInstance.MakeTheButton _
    Sheet:=ActiveSheet, ButtonName:="Sektor", Caption:="Click me!!", _
    Left:=160, Top:=80, Width:=100, Height:=40
    
    oCol.Add oCmbInstance

End Sub

Class code :

Option Explicit

Private WithEvents oCmb As CommandButton

Private Declare Function SetTimer Lib "user32" _
(ByVal hWnd As Long, ByVal nIDEvent As Long, _
ByVal uElapse As Long, ByRef lpTimerFunc As Byte) As Long

Private Declare Function KillTimer Lib "user32" _
(ByVal hWnd As Long, ByVal nIDEvent As Long) As Long

Private Declare Sub CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" (Destination As Any, Source As Any, _
ByVal Length As Long)

Private Declare Function LockWindowUpdate Lib "user32" _
(ByVal hwndLock As Long) As Long

Private sButtonName As String
Private VBS_FILE As String
Private lTimerID As Long
Private mlngInterval As Long
Private bytData(12) As Byte

    
'=======================================================
'WARNING !!!
'THE TimerProc MUST ALWAYS BE THE FIRST PROCEDURE IN THE CLASS !!!!  =
Public Sub TimerProc()

    On Error Resume Next

    If lTimerID <> 0 Then
        Call KillTimer(0, lTimerID)
        lTimerID = 0
    End If
    
    Set oCmb = ActiveSheet.OLEObjects(sButtonName).Object
    
    Kill VBS_FILE
    
    LockWindowUpdate 0

End Sub
'=======================================================


Private Sub oCmb_Click()
 
    MsgBox "Hello " & "'" & oCmb.Name & "'"

End Sub


Public Sub MakeTheButton( _
Sheet As Worksheet, _
ButtonName As String, _
Optional Caption As String, _
Optional Left As Variant, _
Optional Top As Variant, _
Optional Width As Variant, _
Optional Height As Variant _
)

    On Error Resume Next
    
    'store the button name
    sButtonName = ButtonName
    
    'create a temp vbs file on the fly.
    VBS_FILE = Environ("Temp") & "\" & ButtonName & ".vbs"  '
    
    Open VBS_FILE For Output As #1
    
        Print #1, "set wb=Getobject(" & Chr(34) & _
        ThisWorkbook.FullName & Chr(34) & ")"
        Print #1, "On Error Resume Next"
        'add the Button control from the vbs file to preserve the variables.
        Print #1, "Set Cmb=Wb.Sheets(""" & Sheet.Name & """).OLEObjects.Add (""Forms.CommandButton.1"")"
        Print #1, "Cmb.Name=" & Chr(34) & ButtonName & Chr(34) & ""
        If Not IsMissing(Caption) Then Print #1, "Cmb.Object.Caption=" & Chr(34) & Caption & Chr(34)
        If Not IsMissing(Left) Then Print #1, "Cmb.Left=" & Chr(32) & Str(Left) & Chr(32)
        If Not IsMissing(Top) Then Print #1, "Cmb.Top=" & Chr(32) & Str(Top) & Chr(32)
        If Not IsMissing(Width) Then Print #1, "Cmb.Width=" & Chr(32) & Str(Width) & Chr(32)
        If Not IsMissing(Height) Then Print #1, "Cmb.Height=" & Chr(32) & Str(Height) & Chr(32)
    
    Close #1
    
    LockWindowUpdate Application.hWnd
    
    'execute the background vbs file.
    Shell "WScript.exe " & VBS_FILE

    If lTimerID = 0 Then
        'hook the button click event.
        lTimerID = SetTimer(0&, 0&, 2000, bytData(0))
    End If

End Sub

Private Sub Class_Initialize()

    Dim lClassPtr As Long
    
    lTimerID = 0
    
    CopyMemory lClassPtr, Me, 4 'lngX=ObjPtr(me)
    
    bytData(0) = &H68
    CopyMemory bytData(1), lClassPtr, 4 'push this (me) on stack
    
    bytData(5) = &HE8
    CopyMemory bytData(6), _
    GetVTableAddress(Me, 7) - VarPtr(bytData(10)), 4 'call TimerProc
    'value of 7 is used because TimerProc is actually the 8th function in
    'the VTable
    'after QueryInterface, AddRef, Release, GetTypeInfoCount, GetTypeInfo,
    'GetIDsOfNames , Invoke
    
    bytData(10) = &HC2
    bytData(11) = &H10
    bytData(12) = &H0 'ret 10 --- return from
    'callback, removing 4 parameters from stack
    
End Sub

Private Function GetVTableAddress _
(ByVal objRef As Object, ByVal Offset As Long) As Long

    Dim lClassPtr As Long
    
    CopyMemory lClassPtr, ByVal ObjPtr(objRef), 4 'Get pointer to VTable
    CopyMemory GetVTableAddress, ByVal lClassPtr + Offset * 4, 4 'Get function
    'pointer

End Function

 

[Glory]

That's just crazy. It works so good I can't use it on this project; if they ever found out I didn't have the first clue how the code I suggested to them worked, I'd be in deep

These procedures intimate a firm grasp of a lot of background stuff, and it's really impressive how fast you're able to turn that back around.

I was forced to use a collection of API functions located on these forums a couple of times to suppress 'Now Printing' dialog popups. If you have the time at any point in the future, might I suggest this as a project?

http://www.mrexcel.com/forum/showthread.php?t=94045

Freezing the screen works great until something goes wrong, and then the user is forced to guess that things aren't working right and 'Ctrl-Alt-Delete' their way back to life.

Maybe a better option would find an eager audience.

Peace

 

[Jaafar Tribak]

Hi Glory,

Yes that code freezes my whole screen when run from the Workbook_BeforePrint which is where it should be located. I had to restart the computer ! even Alt-Ctl-Del was blocked .

If you pass the Application.Hwnd as the second argument it doesn't hide the 'Now Printing' window.

I guess the best approach to solve this is to trap the 'Now Printing' window upon its creation and subclass its PAINT Message.

I guess the reason for wanting to hide this Window is to prevent the user from aborting the printing operation but I think the user shoud be notified that printing is under way so I'll see if I can display a friendly MsgBox informing the user while waiting.

 

[Glory]

The reasoning becomes apparent when you have hundreds of separate pivot reports or whatever to print. All those 'Now Printing' dialogs become a serious hassle, especially if you're trying to get a userform "progress bar" to display the macro's progress.

Maybe that's not exactly the same code that I used, because the code I found didn't freeze my computer completely. I was always able to ctrl-alt-delete out of it if I had to, it was just a nuisance not to be able to use a good error handler.

I ultimately had to use a global boolean and have the code check it periodically, then exit if necessary. I added a global boolean into the print function to check its state (screen disabled or enabled) and reset it to enabled if necessary.

But it's such a clumsy workaround; I'd give a lot to understand this stuff as well as you do.

 

[Jaafar Tribak]

What is the exact text on the Printing progress Window title bar ie: (The text on the Blue Caption at the top of the window ) ?

Does it reads Now Printing or just Printing ? and are there any dots at the end of the text ?

I don't know this text because I use French versions of excel/OS but its needed for the code I am writing so that it works on English versions as well .

Thanks.

 

[Glory]

Actually, now that I look closer, the window reads "Printing" in the title bar, and "Now printing...[more text]" in the body of the message.