Jaafar Tribak
Well-known Member
- Joined
- Dec 5, 2002
- Messages
- 9,797
- Office Version
- 2016
- Platform
- Windows
I have set up this Class called CFloatingButton which uses a simple standard UserForm with a CommandButton in it.
With some API trickery, the result you get with this Class is the possibility to create any number of concomitant floating buttons even on sheets that are not active .
See Workbook Demo here.
Once an instance of the Class is created, you can assign to it the following Properties & Methods :
-Caption.
-PositionAtRange.
-ClickMacro.
Here is an example of how to create two floating buttons on a worksheet: (code goes in a standard module)
Code for the Class Module :
Code in the UserForm module :
Tested this on Excel 2003 - WinXP and worked well. Not sure about other versions.
Regards.
With some API trickery, the result you get with this Class is the possibility to create any number of concomitant floating buttons even on sheets that are not active .
See Workbook Demo here.
Once an instance of the Class is created, you can assign to it the following Properties & Methods :
-Caption.
-PositionAtRange.
-ClickMacro.
Here is an example of how to create two floating buttons on a worksheet: (code goes in a standard module)
Code:
Option Explicit
Private FloatingButton1 As New CFloatingButton
Private FloatingButton2 As New CFloatingButton
'first example.
'==============
'--------------------------------------------
'\Adding first floating button
'\to Cell B6.
Sub AddFloatingButton1()
With FloatingButton1
.Caption = "FloatingButton1"
.PositionAtRange Sheets(1).Range("B6")
.ClickMacro = "MyMacro1"
.Show
End With
End Sub
Sub MyMacro1()
MsgBox "hello!"
End Sub
Sub RemoveFloatingButton1()
Set FloatingButton1 = Nothing
End Sub
'----------------------------------------------
'second example.
'==============
'-----------------------------------------------
'\Adding another concomitant floating button
'\to Cell A14.
Sub AddFloatingButton2()
With FloatingButton2
.Caption = "FloatingButton2"
.PositionAtRange Sheets(1).Range("A14")
.ClickMacro = "MyMacro2"
.Show
End With
End Sub
Sub MyMacro2()
MsgBox "hello again!"
End Sub
Sub RemoveFloatingButton2()
Set FloatingButton2 = Nothing
End SubCode for the Class Module :
Code:
'\This class uses a standard VBA UserForm with
'\a single CommandButton to create any
'\number of floating worksheet Buttons.
'\Via its intuitive interface,(Properties & Methods)
'\one can easily set the caption and the Click Macro
'\of the Buttons as well as their initial position
'\in relation to a chosen range.
'\The Class also allows adding the Buttons
'\to non active sheets.
'\tested on Excel 2003.
Option Explicit
Private sCaption As String
Private oRangePos As Range
Private oUF As UserForm1
Private Sub Class_Initialize()
Set oUF = New UserForm1
End Sub
Private Sub Class_Terminate()
Unload oUF
End Sub
Public Property Let Caption(ByVal ButtonCaption As String)
sCaption = ButtonCaption
End Property
Public Sub PositionAtRange(RangePos As Range)
Set oRangePos = RangePos
oUF.Position RangePos
End Sub
Public Property Let ClickMacro(ByVal MacroName As String)
oUF.ButtonMacro = MacroName
End Property
Public Sub Show()
oUF.CommandButton1.Caption = sCaption
If oRangePos.Parent Is ActiveSheet Then
If Intersect(ActiveWindow.VisibleRange, oRangePos) _
Is Nothing Then
Application.Goto oRangePos
End If
oUF.Show vbModeless
End If
End SubCode in the UserForm module :
Code:
Option Explicit
Private WithEvents wbEvents As Workbook
Private Type POINTAPI
x As Long
y As Long
End Type
Private Declare Function FindWindow Lib "user32.dll" Alias _
"FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Function FindWindowEx Lib "user32.dll" Alias _
"FindWindowExA" _
(ByVal hWnd1 As Long, _
ByVal hWnd2 As Long, _
ByVal lpsz1 As String, _
ByVal lpsz2 As String) As Long
Private Declare Function GetWindow Lib "user32.dll" _
(ByVal hwnd As Long, _
ByVal wCmd As Long) As Long
Private Declare Function ShowWindow Lib "user32.dll" _
(ByVal hwnd As Long, _
ByVal nCmdShow As Long) As Long
Private Declare Function SetWindowLong Lib "user32.dll" Alias _
"SetWindowLongA" _
(ByVal hwnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
Private Declare Function GetWindowLong Lib "user32.dll" Alias _
"GetWindowLongA" _
(ByVal hwnd As Long, _
ByVal nIndex As Long) As Long
Private Declare Function DrawMenuBar Lib "user32.dll" _
(ByVal hwnd As Long) As Long
Private Declare Function MoveWindow Lib "user32.dll" _
(ByVal hwnd As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long, _
ByVal bRepaint As Long) As Long
Private Declare Function SetParent Lib "user32.dll" _
(ByVal hWndChild As Long, _
ByVal hWndNewParent As Long) As Long
Private Declare Function SetFocus Lib "user32.dll" _
(ByVal hwnd As Long) As Long
Private Declare Function LockWindowUpdate Lib "user32" _
(ByVal hwndLock As Long) As Long
Private Declare Function GetDC Lib "user32.dll" _
(ByVal hwnd As Long) As Long
Private Declare Function GetWindowDC Lib "user32.dll" _
(ByVal hwnd As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" _
(ByVal hDC As Long, _
ByVal nIndex As Long) As Long
Private Declare Function ReleaseDC Lib "user32" _
(ByVal hwnd As Long, _
ByVal hDC As Long) As Long
Private Declare Function ScreenToClient Lib "user32.dll" _
(ByVal hwnd As Long, _
ByRef lpPoint As POINTAPI) As Long
Private Const WS_CAPTION As Long = &HC00000
Private Const GWL_STYLE As Long = -16
Private Const GWL_EXSTYLE As Long = (-20)
Private Const WS_EX_DLGMODALFRAME As Long = &H1&
Private Const GW_CHILD As Long = 5
Private Const LOGPIXELSX As Long = 88
Private Const LOGPIXELSY As Long = 90
Private tPt As POINTAPI
Private lApphwnd As Long
Private lEXCEL7 As Long
Private lXLDESK As Long
Private lMehwnd As Long
Private ldc As Long
Private lClienthwnd As Long
Private sButtonMacro As String
Private bSkipActivateEvent As Boolean
Private oPosition As Range
Private Sub CommandButton1_Click()
Application.Run sButtonMacro
SetFocus lApphwnd
End Sub
Private Sub UserForm_Activate()
If Not bSkipActivateEvent Then
bSkipActivateEvent = True
Me.StartUpPosition = 0
lClienthwnd = GetWindow(lMehwnd, GW_CHILD)
ldc = GetWindowDC(lClienthwnd)
tPt = TopLeftPoint(oPosition)
ScreenToClient lEXCEL7, tPt
LockWindowUpdate lMehwnd
MoveWindow lMehwnd, tPt.x, tPt.y, _
Me.CommandButton1.Width * _
(GetDeviceCaps(ldc, LOGPIXELSX) / 72), _
Me.CommandButton1.Height * _
(GetDeviceCaps(ldc, LOGPIXELSY) / 72), True
ReleaseDC lClienthwnd, ldc
LockWindowUpdate 0
SetParent lMehwnd, lEXCEL7
SetFocus lApphwnd
End If
End Sub
Private Sub UserForm_Initialize()
lApphwnd = FindWindow("XLMAIN", Application.Caption)
lXLDESK = FindWindowEx _
(lApphwnd, 0, "XLDESK", vbNullString)
lEXCEL7 = FindWindowEx _
(lXLDESK, 0, "EXCEL7", vbNullString)
Set wbEvents = ThisWorkbook
Call SetUpUserForm
End Sub
Private Sub SetUpUserForm()
Dim lStyle As Long
Dim lExStyle As Long
With Me
CommandButton1.Left = 0
CommandButton1.Top = 0
Height = 0
Width = 0
End With
lMehwnd = FindWindow(vbNullString, Me.Caption)
lStyle = GetWindowLong(lMehwnd, GWL_STYLE)
lStyle = lStyle And Not (WS_CAPTION)
SetWindowLong lMehwnd, GWL_STYLE, lStyle
lExStyle = GetWindowLong(lMehwnd, GWL_EXSTYLE)
lExStyle = lExStyle And Not (WS_EX_DLGMODALFRAME)
SetWindowLong lMehwnd, GWL_EXSTYLE, lExStyle
DrawMenuBar lMehwnd
End Sub
Public Sub Position(R As Range)
Set oPosition = R
End Sub
Public Property Let ButtonMacro(ByVal ClickMacro As String)
sButtonMacro = ClickMacro
End Property
Private Sub wbEvents_BeforeClose(Cancel As Boolean)
SetFocus lApphwnd
bSkipActivateEvent = False
Unload Me
End Sub
Private Sub wbEvents_SheetActivate(ByVal Sh As Object)
If Sh Is oPosition.Parent Then _
ShowWindow lMehwnd, 1 Else ShowWindow lMehwnd, 0
End Sub
Private Function TopLeftPoint(rng As Range) As POINTAPI
Dim ldc As Long
Dim lCurrentZoom As Long
ldc = GetDC(0)
lCurrentZoom = ActiveWindow.Zoom / 100
With TopLeftPoint
.x = ActiveWindow.PointsToScreenPixelsX(rng.Left * _
(GetDeviceCaps(ldc, LOGPIXELSX) / 72 * lCurrentZoom))
.y = ActiveWindow.PointsToScreenPixelsY(rng.Top * _
(GetDeviceCaps(ldc, LOGPIXELSY) / 72 * lCurrentZoom))
End With
ReleaseDC 0, ldc
End FunctionTested this on Excel 2003 - WinXP and worked well. Not sure about other versions.
Regards.
Last edited:
