Jaafar Tribak
Well-known Member
- Joined
- Dec 5, 2002
- Messages
- 9,779
- Office Version
- 2016
- Platform
- Windows
Hi all,
Workbook Example
I have just finished this project which hopefully will enable excel users to add functional round buttons to their userforms ... The AddRoundButton routine is what does the job ... This routine contains 13 arguments each of which will hold an attribute of the button ... Attributes such as location, caption, backcolor, tooltiptex ..etc
The last optional argument (EventMacro) takes the name of a generic Click/RightClick and MouseDown events for the button .. This generic event must be declared inside the userform and must be PUBLIC in order to be seen by the main code ... The relevant button name, sought event and mouse coordinates are respectively passed in the event macro arguments
The code uses subclassing and hooking both of which are known to potentially make the code unstable. In order to avoid possible crashes, I have used a hack by adding a small routine that continiously monitors Compile and Runtime errors so in case an error occurs, it is immediatly detected and the relevant windows get a chance to be unhooked in time.
The code is modular. It doesn't follow the OOP approach and it is entirely API based.
limitations I am aware of :
The code doesn't work with Modeless Userforms.
1- Code usage in the Userform Module:
2- Main Code in a Standard Module :
Reagrds.
Workbook Example
I have just finished this project which hopefully will enable excel users to add functional round buttons to their userforms ... The AddRoundButton routine is what does the job ... This routine contains 13 arguments each of which will hold an attribute of the button ... Attributes such as location, caption, backcolor, tooltiptex ..etc
The last optional argument (EventMacro) takes the name of a generic Click/RightClick and MouseDown events for the button .. This generic event must be declared inside the userform and must be PUBLIC in order to be seen by the main code ... The relevant button name, sought event and mouse coordinates are respectively passed in the event macro arguments
The code uses subclassing and hooking both of which are known to potentially make the code unstable. In order to avoid possible crashes, I have used a hack by adding a small routine that continiously monitors Compile and Runtime errors so in case an error occurs, it is immediatly detected and the relevant windows get a chance to be unhooked in time.
The code is modular. It doesn't follow the OOP approach and it is entirely API based.
limitations I am aware of :
The code doesn't work with Modeless Userforms.
1- Code usage in the Userform Module:
Code:
Private Sub UserForm_Activate()
[COLOR=#008000] 'Add first round button using named arguments:[/COLOR]
Call AddRoundButton( _
Form:=Me, _
ButtonName:="Button1", _
Left:=320, _
Top:=20, _
Width:=50, _
Height:=50, _
Caption:="Hello !", _
FontColor:=vbBlack, _
BackColor:=Me.BackColor, _
TooltipText:= _
"This is a long tooltip text demo to show that the tooltip automatically adjusts its size in order to accomodate the whole text.", _
ToolTipBeep:=True, _
AnimateButton:=False, _
EventMacro:="Buttonevents" _
)
[COLOR=#008000] 'Add rest of the buttons without named arguments[/COLOR]
Call AddRoundButton(Me, "Button2", 130, 30, 100, 50, "Click Me", vbYellow, vbRed, , , , "ButtonEvents")
Call AddRoundButton(Me, "Button3", 130, 120, 120, 50, "Elliptical button", vbBlue, , "hello!", True, True, "ButtonEvents")
Call AddRoundButton(Me, "Button4", 250, 0, 60, 88, , vbYellow, RGB(200, 10, 200), "ToolTip Text.", , , "ButtonEvents")
Call AddRoundButton(Me, "Button5", 30, 130, 60, 60, "Click Me", vbBlue, vbCyan, , , , "ButtonEvents")
Call AddRoundButton(Me, "Button6", 80, 200, 40, 40, "hey", vbMagenta, , "This is an API based round Button.", True, True, "ButtonEvents")
Call AddRoundButton(Me, "Button7", 280, 120, 60, 60, "Click Me", vbRed, RGB(120, 200, 150), "This is an API based round Button.", True, True, "ButtonEvents")
Call AddRoundButton(Me, "Button8", 320, 180, 60, 80, "Click Me", vbRed, vbYellow, "This is an API based round Button.", True, True, "ButtonEvents")
Call AddRoundButton(Me, "Button9", 30, 15, 80, 80, "MrExcel", , vbGreen, "This Button swells when the mouse pointer is placed over it.", , True, "ButtonEvents")
End Sub
[COLOR=#008000]'This is the generic event macro for all the buttons ... (MUST be Public!!)[/COLOR]
[COLOR=#008000]'The name of this event macro is optionally passed in the last argument of the AddRoundButton Sub[/COLOR]
Public Sub ButtonEvents(ByVal ButtonName As String, ByVal SoughtEvent As E_V_E_N_T, _
ByVal CurXPos As Long, ByVal CurYPos As Long)
[COLOR=#008000] 'Click code:[/COLOR]
If SoughtEvent = ClickEvent Then
MsgBox "You Clicked : " & ButtonName & vbCr & "Mouse XPos: " & CurXPos & vbCr & "Mouse YPos: " & CurYPos
End If
[COLOR=#008000] 'RightClick code:[/COLOR]
If SoughtEvent = BeforeRightClick Then
MsgBox "You RightClicked : " & ButtonName & vbCr & "Mouse XPos: " & CurXPos & vbCr & "Mouse YPos: " & CurYPos
End If
[COLOR=#008000] 'Mouse Down code:[/COLOR]
If SoughtEvent = MouseMoveEvent Then
[COLOR=#008000] ' other code here...[/COLOR]
End If
End Sub
Private Sub CommandButton1_Click()
Unload Me
End Sub2- Main Code in a Standard Module :
Code:
'Code written in Excel2010 Win10 by jaafar tribak on 10/04/2016
'This code is an attempt to let the user add elliptical buttons to an excel userform @ runtime
'The 'AddRoundButton' Sub lets you specify the button's attributes
'Written and tested on Excel 2010/Win 2010 64 bits
'Code published @ www.MrExcel.com
Option Explicit
Option Base 1
Public Enum E_V_E_N_T
ClickEvent = 1
BeforeRightClick = 2
MouseMoveEvent = 4
End Enum
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As String * 1
lfUnderline As String * 1
lfStrikeOut As String * 1
lfCharSet As String * 1
lfOutPrecision As String * 1
lfClipPrecision As String * 1
lfQuality As String * 1
lfPitchAndFamily As String * 1
lfFaceName As String * 32
End Type
Private Type LOGBRUSH
lbStyle As Long
lbColor As Long
#If VBA7 Then
lbHatch As LongPtr
#Else
lbHatch As Long
#End If
End Type
Private Type PAINTSTRUCT
#If VBA7 Then
hDC As LongPtr
#Else
hDC As Long
#End If
fErase As Long
rcPaint As RECT
fRestore As Long
fIncUpdate As Long
rgbReserved(0 To 31) As Byte
End Type
#If VBA7 Then
Declare PtrSafe Function GetDesktopWindow Lib "user32" () As LongPtr
Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Declare PtrSafe Function IsWindow Lib "user32" (ByVal hWnd As LongPtr) As Long
Declare PtrSafe Function MessageBeep Lib "user32" (ByVal wType As Long) As Long
Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Declare PtrSafe Function ScreenToClient Lib "user32" (ByVal hWnd As LongPtr, lpPoint As POINTAPI) As Long
Declare PtrSafe Function ClientToScreen Lib "user32" (ByVal hWnd As LongPtr, lpPoint As POINTAPI) As Long
Declare PtrSafe Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As LongPtr, ByVal hMenu As LongPtr, ByVal hInstance As LongPtr, lpParam As Any) As LongPtr
Declare PtrSafe Function DestroyWindow Lib "user32" (ByVal hWnd As LongPtr) As Long
Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hWnd As LongPtr, ByVal nCmdShow As Long) As Long
Declare PtrSafe Function SetParent Lib "user32" (ByVal hWndChild As LongPtr, ByVal hWndNewParent As LongPtr) As LongPtr
Declare PtrSafe Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hWnd As LongPtr, lpRect As RECT) As Long
Declare PtrSafe Function GetClientRect Lib "user32" (ByVal hWnd As LongPtr, lpRect As RECT) As Long
Declare PtrSafe Function CreateBrushIndirect Lib "gdi32" (lpLogBrush As LOGBRUSH) As LongPtr
Declare PtrSafe Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As LongPtr
Declare PtrSafe Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As LongPtr
Declare PtrSafe Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As LongPtr
Declare PtrSafe Function FillRgn Lib "gdi32" (ByVal hDC As LongPtr, ByVal hRgn As LongPtr, ByVal hBrush As LongPtr) As Long
Declare PtrSafe Function FillRect Lib "user32" (ByVal hDC As LongPtr, lpRect As RECT, ByVal hBrush As LongPtr) As Long
Declare PtrSafe Function CombineRgn Lib "gdi32" (ByVal hDestRgn As LongPtr, ByVal hSrcRgn1 As LongPtr, ByVal hSrcRgn2 As LongPtr, ByVal nCombineMode As Long) As Long
Declare PtrSafe Function OffsetRgn Lib "gdi32" (ByVal hRgn As LongPtr, ByVal X As Long, ByVal Y As Long) As Long
Declare PtrSafe Function SetWindowRgn Lib "user32" (ByVal hWnd As LongPtr, ByVal hRgn As LongPtr, ByVal bRedraw As Long) As Long
Declare PtrSafe Function SelectClipRgn Lib "gdi32" (ByVal hDC As LongPtr, ByVal hRgn As LongPtr) As Long
Declare PtrSafe Function PtVisible Lib "gdi32" (ByVal hDC As LongPtr, ByVal X As Long, ByVal Y As Long) As Long
Declare PtrSafe Function PtInRegion Lib "gdi32" (ByVal hRgn As LongPtr, ByVal X As Long, ByVal Y As Long) As Long
Declare PtrSafe Function EqualRect Lib "user32" (lpRect1 As RECT, lpRect2 As RECT) As Long
Declare PtrSafe Function IntersectRect Lib "user32" (lpDestRect As RECT, lpSrc1Rect As RECT, lpSrc2Rect As RECT) As Long
Declare PtrSafe Function SetWindowPos Lib "user32" (ByVal hWnd As LongPtr, ByVal hWndInsertAfter As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Declare PtrSafe Function DrawEdge Lib "user32" (ByVal hDC As LongPtr, qrc As RECT, ByVal edge As Long, ByVal grfFlags As Long) As Long
Declare PtrSafe Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As LongPtr, ByVal hWnd As LongPtr, ByVal Msg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
Declare PtrSafe Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Declare PtrSafe Function TranslateColor Lib "oleaut32.dll" Alias "OleTranslateColor" (ByVal clr As OLE_COLOR, ByVal palet As Long, Col As Long) As Long
Declare PtrSafe Function SetTimer Lib "user32" (ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
Declare PtrSafe Function KillTimer Lib "user32" (ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
Declare PtrSafe Function SetWindowLongPtr Lib "user32" Alias "SetWindowLongPtrA" (ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
Declare PtrSafe Function GetWindowLongPtr Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long) As LongPtr
Declare PtrSafe Function SetProp Lib "user32" Alias "SetPropA" (ByVal hWnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
Declare PtrSafe Function GetProp Lib "user32" Alias "GetPropA" (ByVal hWnd As LongPtr, ByVal lpString As String) As LongPtr
Declare PtrSafe Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hWnd As LongPtr, ByVal lpString As String) As LongPtr
Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Declare PtrSafe Function InvalidateRect Lib "user32" (ByVal hWnd As LongPtr, lpRect As RECT, ByVal bErase As Long) As Long
Declare PtrSafe Function SetMapMode Lib "gdi32" (ByVal hDC As LongPtr, ByVal nMapMode As Long) As Long
Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Declare PtrSafe Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hWnd As LongPtr, ByVal lpString As String) As Long
Declare PtrSafe Function RedrawWindow Lib "user32" (ByVal hWnd As LongPtr, ByVal lprcUpdate As Long, ByVal hrgnUpdate As LongPtr, ByVal fuRedraw As Long) As Long
Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnd As LongPtr, ByVal hDC As LongPtr) As Long
Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hDC As LongPtr) As Long
Declare PtrSafe Function BeginPaint Lib "user32" (ByVal hWnd As LongPtr, lpPaint As PAINTSTRUCT) As LongPtr
Declare PtrSafe Function EndPaint Lib "user32" (ByVal hWnd As LongPtr, lpPaint As PAINTSTRUCT) As Long
Declare PtrSafe Function SetTextColor Lib "gdi32" (ByVal hDC As LongPtr, ByVal crColor As Long) As Long
Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hDC As LongPtr, ByVal hObject As LongPtr) As LongPtr
Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As LongPtr) As LongPtr
Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
Declare PtrSafe Function BitBlt Lib "gdi32" (ByVal hDestDC As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As LongPtr, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Declare PtrSafe Function StretchBlt Lib "gdi32" (ByVal hDC As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As LongPtr, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Declare PtrSafe Function SetBkMode Lib "gdi32" (ByVal hDC As LongPtr, ByVal nBkMode As Long) As Long
Declare PtrSafe Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hDC As LongPtr, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Declare PtrSafe Function GetTextCharacterExtra Lib "gdi32" (ByVal hDC As LongPtr) As Long
Declare PtrSafe Function SetTextCharacterExtra Lib "gdi32" (ByVal hDC As LongPtr, ByVal nCharExtra As Long) As Long
Declare PtrSafe Function GlobalAddAtom Lib "kernel32" Alias "GlobalAddAtomA" (ByVal lpString As String) As Integer
Declare PtrSafe Function GlobalGetAtomName Lib "kernel32" Alias "GlobalGetAtomNameA" (ByVal nAtom As Integer, ByVal lpBuffer As String, ByVal nSize As Long) As Long
Declare PtrSafe Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As LongPtr, ByVal lpString As String, ByVal cch As Long) As Long
Declare PtrSafe Function GetCurrentThreadId Lib "kernel32.dll" () As Long
Declare PtrSafe Function CallNextHookEx Lib "user32.dll" (ByVal hhk As LongPtr, ByVal nCode As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
Declare PtrSafe Function SetWindowsHookExW Lib "user32.dll" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hMod As LongPtr, ByVal dwThreadId As Long) As LongPtr
Declare PtrSafe Function UnhookWindowsHookEx Lib "user32.dll" (ByVal hhk As LongPtr) As Long
Declare PtrSafe Function EnumChildWindows Lib "user32" (ByVal hWndParent As LongPtr, ByVal lpEnumFunc As LongPtr, ByVal lParam As LongPtr) As Long
Private lFormHwnd, lFormDC, hFormMinusButtonsRegion, lFormPrevWndProc, lCurrentRGN, _
hwndToolTip, lToolTipPrevWndProc, lButtonReleasedMemDC, lButtonPressedMemDC, hHook As LongPtr
#Else
Declare Function GetDesktopWindow Lib "user32" () As Long
Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
Declare Function MessageBeep Lib "user32" (ByVal wType As Long) As Long
Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Declare Function CreateBrushIndirect Lib "gdi32" (lpLogBrush As LOGBRUSH) As Long
Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Declare Function FillRgn Lib "gdi32" (ByVal hDc As Long, ByVal hRgn As Long, ByVal hBrush As Long) As Long
Declare Function FillRect Lib "user32" (ByVal hDc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Declare Function OffsetRgn Lib "gdi32" (ByVal hRgn As Long, ByVal X As Long, ByVal Y As Long) As Long
Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Long) As Long
Declare Function SelectClipRgn Lib "gdi32" (ByVal hDc As Long, ByVal hRgn As Long) As Long
Declare Function PtVisible Lib "gdi32" (ByVal hDc As Long, ByVal X As Long, ByVal Y As Long) As Long
Declare Function PtInRegion Lib "gdi32" (ByVal hRgn As Long, ByVal X As Long, ByVal Y As Long) As Long
Declare Function EqualRect Lib "user32" (lpRect1 As RECT, lpRect2 As RECT) As Long
Declare Function IntersectRect Lib "user32" (lpDestRect As RECT, lpSrc1Rect As RECT, lpSrc2Rect As RECT) As Long
Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Declare Function DrawEdge Lib "user32" (ByVal hDc As Long, qrc As RECT, ByVal edge As Long, ByVal grfFlags As Long) As Long
Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Declare Function TranslateColor Lib "oleaut32.dll" Alias "OleTranslateColor" (ByVal clr As OLE_COLOR, ByVal palet As Long, Col As Long) As Long
Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT, ByVal bErase As Long) As Long
Declare Function SetMapMode Lib "gdi32" (ByVal hDc As Long, ByVal nMapMode As Long) As Long
Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Declare Function RedrawWindow Lib "user32" (ByVal hwnd As Long, ByVal lprcUpdate As Long, ByVal hrgnUpdate As Long, ByVal fuRedraw As Long) As Long
Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDc As Long) As Long
Declare Function DeleteDC Lib "gdi32" (ByVal hDc As Long) As Long
Declare Function BeginPaint Lib "user32" (ByVal hwnd As Long, lpPaint As PAINTSTRUCT) As Long
Declare Function EndPaint Lib "user32" (ByVal hwnd As Long, lpPaint As PAINTSTRUCT) As Long
Declare Function SetTextColor Lib "gdi32" (ByVal hDc As Long, ByVal crColor As Long) As Long
Declare Function SelectObject Lib "gdi32" (ByVal hDc As Long, ByVal hObject As Long) As Long
Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDc As Long) As Long
Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Declare Function StretchBlt Lib "gdi32" (ByVal hDc As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Declare Function SetBkMode Lib "gdi32" (ByVal hDc As Long, ByVal nBkMode As Long) As Long
Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hDc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Declare Function GetTextCharacterExtra Lib "gdi32" (ByVal hDc As Long) As Long
Declare Function SetTextCharacterExtra Lib "gdi32" (ByVal hDc As Long, ByVal nCharExtra As Long) As Long
Declare Function GlobalAddAtom Lib "kernel32" Alias "GlobalAddAtomA" (ByVal lpString As String) As Integer
Declare Function GlobalGetAtomName Lib "kernel32" Alias "GlobalGetAtomNameA" (ByVal nAtom As Integer, ByVal lpBuffer As String, ByVal nSize As Long) As Long
Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Declare Function GetCurrentThreadId Lib "kernel32.dll" () As Long
Declare Function CallNextHookEx Lib "user32.dll" (ByVal hhk As Long, ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Declare Function SetWindowsHookExW Lib "user32.dll" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hMod As Long, ByVal dwThreadId As Long) As Long
Declare Function UnhookWindowsHookEx Lib "user32.dll" (ByVal hhk As Long) As Long
Declare Function EnumChildWindows Lib "user32" (ByVal hWndParent As Long, ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
Private lFormHwnd, lFormDC, hFormMinusButtonsRegion, lFormPrevWndProc, lCurrentRGN, _
hwndToolTip, lToolTipPrevWndProc, lButtonReleasedMemDC, lButtonPressedMemDC, hHook As Long
#End If
Private tButtonXYCoords As POINTAPI
Private bToollTipDelayExists As Boolean
Private bStreching As Boolean
Private bAnErrorHasOccurred As Boolean
Private sButtonsAttributesArray() As String
Private sToolTipText As String
Private iBoutonsCounter As Integer
Private oForm As Object
Private Const WM_RBUTTONDOWN = &H204
Private Const WM_LBUTTONDOWN = &H201
Private Const WM_PARENTNOTIFY = &H210
Private Const WM_PAINT = &HF
Private Const WM_SETREDRAW = &HB
Private Const WM_ERASEBKGND = &H14
Private Const WM_NCHITTEST = &H84
Private Const WM_NCDESTROY = &H82
Private Const WM_EXITSIZEMOVE = &H232
Private Const WM_DESTROY = &H2
Private Const WM_MOVE = &H3
Private Const WM_SETCURSOR = &H20
Private Const BDR_SUNKENOUTER = &H2
Private Const BDR_RAISEDINNER = &H4
Private Const EDGE_ETCHED = (BDR_SUNKENOUTER Or BDR_RAISEDINNER)
Private Const BF_BOTTOM = &H8
Private Const BF_LEFT = &H1
Private Const BF_RIGHT = &H4
Private Const BF_TOP = &H2
Private Const BF_RECT = (BF_LEFT Or BF_TOP Or BF_RIGHT Or BF_BOTTOM)
Private Const DT_LEFT = &H0
Private Const DT_WORDBREAK = &H10
Private Const DT_CALCRECT = &H400
Private Const DT_EDITCONTROL = &H2000
Private Const DT_NOCLIP = &H100
Private Const DT_SINGLELINE = &H20
Private Const DT_CENTER = &H1
Private Const DT_VCENTER = &H4
Private Const COLOR_INFOTEXT = 23
Private Const COLOR_INFOBK = 24
Private Const GWL_STYLE = (-16)
Private Const WS_CAPTION = &HC00000
Private Const WS_CLIPCHILDREN = &H2000000
Private Const WS_CHILD = &H40000000
Private Const WS_EX_TOOLWINDOW = &H96
Private Const WS_EX_NOACTIVATE = &H8000000
Private Const WS_EX_TOPMOST As Long = &H8
Private Const DS_MODALFRAME = &H96
Private Const SRCCOPY = &HCC0020
Private Const RGN_OR = 2
Private Const RGN_XOR = 3
Private Const RDW_INTERNALPAINT = &H2
Private Const GWL_USERDATA = (-21)
Private Const GWL_WNDPROC = -4
Private Const SM_CXSCREEN = 0
Private Const SM_CYSCREEN = 1
Private Const MB_ICONASTERISK = &H40&
Private Const HCBT_ACTIVATE = 5
Private Const WH_CBT = 5
Public Sub AddRoundButton( _
ByVal Form As Object, _
ByVal ButtonName As String, _
ByVal Left As Long, _
ByVal Top As Long, _
ByVal Width As Long, _
ByVal Height As Long, _
Optional ByVal Caption As String, _
Optional ByVal FontColor As Variant, _
Optional ByVal BackColor As Variant, _
Optional ByVal TooltipText As String, _
Optional ToolTipBeep As Boolean = False, _
Optional AnimateButton As Boolean = False, _
Optional EventMacro As String)
#If VBA7 Then
Dim hwndButton, hRgnWnd, hRgnClient, lPrevRgn As LongPtr
Dim hFont, hFillBrush, hButtonDC, lPrevWinButtonProc As LongPtr
#Else
Dim hwndButton, hRgnWnd, hRgnClient, lPrevRgn As Long
Dim hFont, hFillBrush, hButtonDC, lPrevWinButtonProc As Long
#End If
Dim tFormRect As RECT
Dim tSourceRect As RECT
Dim tDestinationRect As RECT
Dim tPt1 As POINTAPI
Dim tPt2 As POINTAPI
Dim tFont As LOGFONT
Dim tFillLB As LOGBRUSH
Dim tButtonWinRect As RECT
Dim tButtonClientRect As RECT
Dim lRealcolor1 As Long
Dim i As Long
Dim Atom_ID As Integer
Const FontHeight As Long = 14
Const FontWidth As Long = 9
Const PtToPix = 96 / 72
On Error GoTo errHandler
If Len(Caption) = 0 Then Caption = ButtonName
Set oForm = Form
lFormHwnd = FindWindow(vbNullString, Form.Caption)
SetProp Application.hWnd, "FormHwnd", lFormHwnd
GetWindowRect lFormHwnd, tFormRect
hwndButton = CreateWindowEx(WS_EX_TOOLWINDOW, "static", _
vbNullString, WS_CHILD + WS_CLIPCHILDREN, Left * PtToPix, Top * PtToPix, _
Width * PtToPix, Height * PtToPix, lFormHwnd, 0, 0, 0)
If hwndButton <> 0 Then
GetClientRect hwndButton, tButtonClientRect
lFormDC = GetDC(lFormHwnd)
hButtonDC = GetDC(hwndButton)
SetParent hwndButton, lFormHwnd
SetBkMode hButtonDC, 1
ShowWindow hwndButton, 1
TranslateColor oForm.BackColor, 0, lRealcolor1
If IsMissing(BackColor) Then
BackColor = oForm.BackColor
End If
TranslateColor BackColor, 0, lRealcolor1
BackColor = lRealcolor1
tFillLB.lbColor = BackColor
hFillBrush = CreateBrushIndirect(tFillLB)
DoEvents
GetWindowRect hwndButton, tButtonWinRect
With tButtonWinRect
hRgnWnd = CreateEllipticRgn _
(.Left, .Top, .Right, .Bottom)
tPt1.X = .Left
tPt1.Y = .Top
tPt2.X = .Right
tPt2.Y = .Bottom
ScreenToClient lFormHwnd, tPt1
ScreenToClient lFormHwnd, tPt2
.Left = tPt1.X
.Top = tPt1.Y
.Right = tPt2.X
.Bottom = tPt2.Y
lPrevRgn = CreateEllipticRgn(.Left, .Top, .Right, .Bottom)
SetProp hwndButton, "ButtonLeft", CStr(.Left)
SetProp hwndButton, "ButtonTop", CStr(.Top)
SetProp hwndButton, "ButtonRight", CStr(.Right)
SetProp hwndButton, "ButtonBottom", CStr(.Bottom)
End With
With tButtonClientRect
hRgnClient = CreateEllipticRgn(.Left, .Top, .Right, .Bottom)
If hFormMinusButtonsRegion = 0 Then
hFormMinusButtonsRegion = CreateRectRgn(0, 0, tFormRect.Right, tFormRect.Bottom)
End If
CombineRgn hFormMinusButtonsRegion, hFormMinusButtonsRegion, lPrevRgn, RGN_XOR
FillRgn hButtonDC, hRgnClient, hFillBrush
SelectClipRgn hButtonDC, hRgnClient
SetWindowRgn hwndButton, hRgnClient, True
tFont.lfHeight = FontHeight
tFont.lfWidth = FontWidth
FontColor = IIf(IsMissing(FontColor), vbBlack, FontColor)
SetTextColor hButtonDC, FontColor
hFont = CreateFontIndirect(tFont)
Call SelectObject(hButtonDC, hFont)
Call Add3DEffect(hwndButton, hButtonDC, BackColor, hRgnClient, False)
DrawText hButtonDC, Caption, Len(Caption), tButtonClientRect, _
DT_CENTER + DT_VCENTER + DT_SINGLELINE
End With
ReDim Preserve sButtonsAttributesArray(iBoutonsCounter + 1)
sButtonsAttributesArray(iBoutonsCounter + 1) = ButtonName & Chr(1) & CStr(tButtonWinRect.Left) _
& Chr(1) & CStr(tButtonWinRect.Top) & Chr(1) & CStr(tButtonWinRect.Left) & Chr(1) & _
CStr(tButtonWinRect.Right) & Chr(1) & CStr(tButtonWinRect.Bottom) & Chr(1) & _
Caption & Chr(1) & CStr(BackColor) & Chr(1) & FontColor & Chr(1) & TooltipText & _
Chr(1) & CStr(hwndButton) & Chr(1) & CStr(hButtonDC) & Chr(1) & CStr(hRgnWnd) & Chr(1) _
& CStr(hRgnClient) & Chr(1) & AnimateButton & Chr(1) & EventMacro
iBoutonsCounter = iBoutonsCounter + 1
GetWindowRect hwndButton, tButtonWinRect
For i = 1 To UBound(sButtonsAttributesArray)
GetWindowRect Split(sButtonsAttributesArray(i), Chr(1))(10), tSourceRect
If EqualRect(tButtonWinRect, tSourceRect) = 0 Or _
CBool(Split(sButtonsAttributesArray(i), Chr(1))(14)) = False Then
If IntersectRect(tDestinationRect, tButtonWinRect, tSourceRect) <> 0 Then
SetProp hwndButton, "DoNotStretch", 1
SetProp Split(sButtonsAttributesArray(i), Chr(1))(10), "DoNotStretch", 1
End If
End If
Next i
Atom_ID = GlobalAddAtom(TooltipText & Chr(1) & EventMacro)
SetProp hwndButton, "ToolTipTextAndEventMacro_Atom", (Atom_ID)
SetProp hwndButton, "RGN", hRgnClient
With tButtonWinRect
lButtonReleasedMemDC = TakeSnapShot(.Left, .Top, .Right, .Bottom, Caption, FontColor, hFillBrush, BackColor, False)
SetProp hwndButton, "ButtonReleased", lButtonReleasedMemDC
lButtonPressedMemDC = TakeSnapShot(.Left, .Top, .Right, .Bottom, Caption, FontColor, hFillBrush, BackColor, True)
SetProp hwndButton, "ButtonPressed", lButtonPressedMemDC
End With
If ToolTipBeep Then SetProp hwndButton, "Beep", 1
InstallCBTHook
Application.OnTime Now, "HookTheButtons"
Application.OnTime Now, "HookTheForm"
DeleteObject hFillBrush
DeleteObject hFont
ReleaseDC hwndButton, hButtonDC
Else
MsgBox "failed to create button"
End If
Exit Sub
errHandler:
If Err.Number = 457 Then
MsgBox "Error ..." & vbCr & "Failed to add the Button :" & " '" & ButtonName & "'", _
vbCritical, "Button Name Duplicate !"
Else
MsgBox Err.Number & vbCr & Err.Description
End If
End Sub
#If VBA7 Then
Sub EventMacro(ByVal ButtonName As String, ByVal SoughtEvent As E_V_E_N_T, ByVal X As Long, _
ByVal Y As Long, ByVal hWnd As LongPtr)
Dim Atom_ID As LongPtr
Dim hDC As LongPtr
#Else
Sub EventMacro(ByVal ButtonName As String, ByVal SoughtEvent As E_V_E_N_T, ByVal X As Long, _
ByVal Y As Long, ByVal hWnd As Long)
Dim Atom_ID As Long
Dim hDC As Long
#End If
Dim tButtonWinRect As RECT
Dim tPt As POINTAPI
Dim sBuffer As String
Dim lRet As Long
On Error GoTo errHandler:
If IsWindow(hwndToolTip) Then DestroyWindow hwndToolTip
If SoughtEvent = ClickEvent Then
Do
DoEvents
Loop Until GetAsyncKeyState(VBA.vbKeyLButton) = 0
End If
GetCursorPos tPt
ScreenToClient hWnd, tPt
hDC = GetDC(hWnd)
If PtVisible(hDC, tPt.X, tPt.Y) = 0 Then GoTo errHandler
sBuffer = Space(256)
Atom_ID = GetProp(hWnd, "ToolTipTextAndEventMacro_Atom")
lRet = GlobalGetAtomName(CInt(Atom_ID), sBuffer, Len(sBuffer))
sBuffer = Left(sBuffer, lRet)
sBuffer = Split(sBuffer, Chr(1))(1)
If Len(sBuffer) <> 0 Then
CallByName oForm, sBuffer, VbMethod, ButtonName, SoughtEvent, X, Y
End If
errHandler:
If Err.Number = 438 Then
MsgBox "The Button Event Macro" & " '" & sBuffer & "' " & "doesn't exist", vbCritical, "Error"
Err.Clear
End If
GetWindowRect hWnd, tButtonWinRect
tPt.X = tButtonWinRect.Left
tPt.Y = tButtonWinRect.Top
ScreenToClient lFormHwnd, tPt
With tButtonWinRect
BitBlt lFormDC, tPt.X, tPt.Y, .Right - .Left, .Bottom - .Top, _
GetProp(hWnd, "ButtonReleased"), 0, 0, SRCCOPY
End With
ReleaseDC hWnd, hDC
oForm.Repaint
End Sub
Private Sub HookTheButtons()
#If VBA7 Then
Dim lPrevProc As LongPtr
Dim i As Long
For i = 1 To UBound(sButtonsAttributesArray)
If GetWindowLongPtr(Split(sButtonsAttributesArray(i), Chr(1))(10), GWL_USERDATA) = 0 Then
lPrevProc = SetWindowLongPtr _
(Split(sButtonsAttributesArray(i), Chr(1))(10), GWL_WNDPROC, AddressOf ButtonWinProc)
SetWindowLongPtr Split(sButtonsAttributesArray(i), Chr(1))(10), GWL_USERDATA, lPrevProc
End If
Next i
#Else
Dim lPrevProc As Long
Dim i As Long
For i = 1 To UBound(sButtonsAttributesArray)
If GetWindowLong(Split(sButtonsAttributesArray(i), Chr(1))(10), GWL_USERDATA) = 0 Then
lPrevProc = SetWindowLong _
(Split(sButtonsAttributesArray(i), Chr(1))(10), GWL_WNDPROC, AddressOf ButtonWinProc)
SetWindowLong Split(sButtonsAttributesArray(i), Chr(1))(10), GWL_USERDATA, lPrevProc
End If
Next i
#End If
End Sub
Private Sub HookTheForm()
#If VBA7 Then
If lFormPrevWndProc = 0 Then
lFormPrevWndProc = SetWindowLongPtr _
(lFormHwnd, GWL_WNDPROC, AddressOf FormWinProc)
SetWindowLongPtr lFormHwnd, GWL_USERDATA, lFormPrevWndProc
SetWindowLongPtr Application.hWnd, GWL_USERDATA, lFormPrevWndProc
End If
#Else
If lFormPrevWndProc = 0 Then
lFormPrevWndProc = SetWindowLong _
(lFormHwnd, GWL_WNDPROC, AddressOf FormWinProc)
SetWindowLong lFormHwnd, GWL_USERDATA, lFormPrevWndProc
SetWindowLong Application.hWnd, GWL_USERDATA, lFormPrevWndProc
End If
#End If
End Sub
Private Sub unHookTheForm()
#If VBA7 Then
Call SetWindowLongPtr(GetProp(Application.hWnd, "FormHwnd"), GWL_WNDPROC, _
GetWindowLongPtr(Application.hWnd, GWL_USERDATA))
RemoveProp Application.hWnd, "FormHwnd"
lFormPrevWndProc = 0
#Else
Call SetWindowLong(GetProp(Application.hWnd, "FormHwnd"), GWL_WNDPROC, _
GetWindowLong(Application.hWnd, GWL_USERDATA))
RemoveProp Application.hWnd, "FormHwnd"
lFormPrevWndProc = 0
#End If
End Sub
#If VBA7 Then
Private Function TakeSnapShot(ByVal Left As Long, _
ByVal Top As Long, _
ByVal Right As Long, _
ByVal Bottom As Long, _
Optional ByVal Caption As String, _
Optional FontColor As Variant, _
Optional ByVal Brush As Variant, _
Optional ByVal Fill As Variant, _
Optional ByVal PressState As Boolean) As LongPtr
Dim hwndTempButton, hTempShapeDC, lMemoryDC, lBmp, hTempRgnClient As LongPtr
#Else
Private Function TakeSnapShot(ByVal Left As Long, _
ByVal Top As Long, _
ByVal Right As Long, _
ByVal Bottom As Long, _
Optional ByVal Caption As String, _
Optional FontColor As Variant, _
Optional ByVal Brush As Variant, _
Optional ByVal Fill As Variant, _
Optional ByVal PressState As Boolean) As Long
Dim hwndTempButton, hTempShapeDC, lMemoryDC, lBmp, hTempRgnClient As Long
#End If
Dim tTempShapeClientRect As RECT
hwndTempButton = CreateWindowEx(WS_EX_TOOLWINDOW, "static", _
vbNullString, WS_CHILD + WS_CLIPCHILDREN, Left + 100, Top + 100, _
(Right - Left), (Bottom - Top), GetDesktopWindow, 0, 0, 0)
hTempShapeDC = GetDC(hwndTempButton)
SetParent hwndTempButton, GetDesktopWindow
SetBkMode hTempShapeDC, 1
ShowWindow hwndTempButton, 1
GetClientRect hwndTempButton, tTempShapeClientRect
With tTempShapeClientRect
hTempRgnClient = CreateEllipticRgn(.Left, .Top, .Right, .Bottom)
End With
DoEvents
FillRgn hTempShapeDC, hTempRgnClient, Brush
SelectClipRgn hTempShapeDC, hTempRgnClient
SetWindowRgn hwndTempButton, hTempRgnClient, True
Call Add3DEffect(hwndTempButton, hTempShapeDC, Fill, hTempRgnClient, PressState)
SetTextColor hTempShapeDC, FontColor
DrawText hTempShapeDC, Caption, Len(Caption), tTempShapeClientRect, _
DT_CENTER + DT_VCENTER + DT_SINGLELINE
If lMemoryDC = 0 Then
lMemoryDC = CreateCompatibleDC(lFormDC)
End If
With tTempShapeClientRect
lBmp = CreateCompatibleBitmap(hTempShapeDC, .Right - .Left, .Bottom - .Top)
DeleteObject SelectObject(lMemoryDC, lBmp)
BitBlt lMemoryDC, 0, 0, .Right - .Left, .Bottom - .Top, _
hTempShapeDC, 0, 0, SRCCOPY
End With
TakeSnapShot = lMemoryDC
DeleteObject lBmp
ReleaseDC hwndTempButton, hTempShapeDC
DestroyWindow hwndTempButton
End Function
#If VBA7 Then
Private Sub StretchButton(ByVal hWnd As LongPtr)
Dim hBmp, lOldBmp, hMemoryDC, hDC As LongPtr
#Else
Private Sub StretchButton(ByVal hWnd As Long)
Dim hBmp, lOldBmp, hMemoryDC, hDC As Long
#End If
Dim tWinRect As RECT
hDC = GetDC(0)
GetWindowRect hWnd, tWinRect
hMemoryDC = CreateCompatibleDC(hDC)
With tWinRect
hBmp = CreateCompatibleBitmap(hDC, .Right - .Left, .Bottom - .Top)
lOldBmp = SelectObject(hMemoryDC, hBmp)
BitBlt hMemoryDC, 0, 0, .Right - .Left, .Bottom - .Top, _
hDC, .Left, .Top, SRCCOPY
StretchBlt _
hDC, .Left, .Top, (.Right - .Left) * 1.1, (.Bottom - .Top) * 1.1, _
hMemoryDC, 0, 0, _
(.Right - .Left), (.Bottom - .Top), SRCCOPY
End With
ReleaseDC 0, hDC
End Sub
#If VBA7 Then
Private Sub Add3DEffect(ByVal hWnd As LongPtr, ByVal hDC As LongPtr, ByVal Fill As Long, _
ByVal ClientRegion As LongPtr, ByVal ButtonPressed As Boolean)
Dim hRgn1, hRgn2, hRgn3 As LongPtr
Dim hBrush1, hBrush2, hBrush3 As LongPtr
Dim hDestRGN1, hDestRGN2, hDestRGN3 As LongPtr
#Else
Private Sub Add3DEffect(ByVal hWnd As Long, ByVal hDC As Long, ByVal Fill As Long, _
ByVal ClientRegion As Long, ByVal ButtonPressed As Boolean)
Dim hRgn1, hRgn2, hRgn3 As Long
Dim hBrush1, hBrush2, hBrush3 As Long
Dim hDestRGN1, hDestRGN2, hDestRGN3 As Long
#End If
Dim tBrush1 As LOGBRUSH
Dim tBrush2 As LOGBRUSH
Dim tBrush3 As LOGBRUSH
Dim tClientRect As RECT
Dim tPt1 As POINTAPI
Dim tPt2 As POINTAPI
Dim Offset As Integer
Dim lRealColor As Long
TranslateColor oForm.BackColor, 0, lRealColor
Offset = IIf(ButtonPressed, IIf(Fill = lRealColor, 2, 3), IIf(Fill = lRealColor, -2, -3))
GetClientRect hWnd, tClientRect
With tClientRect
hRgn1 = CreateEllipticRgn(.Left, .Top, .Right, .Bottom)
hDestRGN1 = CreateEllipticRgn(.Left, .Top, .Right, .Bottom)
OffsetRgn hRgn1, Offset, Offset
tBrush1.lbColor = DarkenColor(Fill)
hBrush1 = CreateBrushIndirect(tBrush1)
CombineRgn hDestRGN1, hRgn1, ClientRegion, RGN_OR
CombineRgn hDestRGN1, hRgn1, hDestRGN1, RGN_XOR
FillRgn hDC, hDestRGN1, hBrush1
hRgn2 = CreateEllipticRgn(.Left, .Top, .Right, .Bottom)
hDestRGN2 = CreateEllipticRgn(.Left, .Top, .Right, .Bottom)
OffsetRgn hRgn2, -Offset, -Offset
tBrush2.lbColor = LightenColor(Fill)
hBrush2 = CreateBrushIndirect(tBrush2)
CombineRgn hDestRGN2, hRgn2, ClientRegion, RGN_OR
CombineRgn hDestRGN2, hRgn2, hDestRGN2, RGN_XOR
FillRgn hDC, hDestRGN2, hBrush2
hRgn3 = CreateEllipticRgn(.Left, .Top, .Right, .Bottom)
hDestRGN3 = CreateEllipticRgn(.Left, .Top, .Right, .Bottom)
End With
OffsetRgn hRgn3, 1, 1
tBrush3.lbColor = DarkenColor(Fill)
hBrush3 = CreateBrushIndirect(tBrush3)
CombineRgn hDestRGN3, hRgn3, ClientRegion, RGN_OR
CombineRgn hDestRGN3, hRgn3, hDestRGN3, RGN_XOR
If Fill <> lRealColor Then
FillRgn hDC, hDestRGN3, hBrush3
End If
DoEvents
DeleteObject hRgn1
DeleteObject hRgn2
DeleteObject hRgn3
DeleteObject hDestRGN1
DeleteObject hDestRGN2
DeleteObject hDestRGN3
DeleteObject hBrush1
DeleteObject hBrush2
DeleteObject hBrush3
End Sub
Private Sub ShowToolTip(ByVal Text As String, ByVal Left As Long, ByVal Top As Long, _
Right As Long, Bottom As Long, ByVal OffsetX As Long, ByVal OffsetY As Long, _
Optional ByVal ToolTipSecondsDelay As Variant)
#If VBA7 Then
Dim hOldFont, hFont, hDC, lCurrentStyle, lNewStyle As LongPtr
#Else
Dim hOldFont, hFont, hDC, lCurrentStyle, lNewStyle As Long
#End If
Dim lFontHeight As Long
Dim lFontWidth As Long
Dim lPrevCharSpacing As Long
Dim lCalc As Long
Dim tFont As LOGFONT
Dim tRect As RECT
Dim tPt As POINTAPI
sToolTipText = Text
hDC = GetDC(0)
SetMapMode hDC, 1
SetBkMode hDC, 1
lPrevCharSpacing = SetTextCharacterExtra(hDC, 1)
With tFont
.lfFaceName = "TAHOMA" & Chr$(0)
.lfHeight = 16
.lfWidth = 6
lFontHeight = .lfHeight
lFontWidth = .lfWidth
End With
hFont = CreateFontIndirect(tFont)
hOldFont = SelectObject(hDC, hFont)
SetRect tRect, 0, 0, (lFontWidth) * 20, 0
lCalc = DrawText(hDC, sToolTipText, Len(sToolTipText), tRect, _
DT_LEFT + DT_EDITCONTROL + DT_WORDBREAK + DT_CALCRECT)
hOldFont = SelectObject(hDC, hFont)
DeleteObject hFont
hwndToolTip = CreateWindowEx(WS_EX_TOOLWINDOW + WS_EX_TOPMOST, "STATIC", _
vbNullString, WS_CHILD, 0, 0, 0, 0, GetDesktopWindow, 0, 0, 0)
Call SetTextCharacterExtra(hDC, lPrevCharSpacing)
#If VBA7 Then
lCurrentStyle = GetWindowLongPtr(hwndToolTip, GWL_STYLE)
lCurrentStyle = lCurrentStyle And (Not WS_CAPTION)
lNewStyle = SetWindowLongPtr(hwndToolTip, GWL_STYLE, lCurrentStyle)
lToolTipPrevWndProc = SetWindowLongPtr(hwndToolTip, GWL_WNDPROC, AddressOf ToolTipWinProc)
#Else
lCurrentStyle = GetWindowLong(hwndToolTip, GWL_STYLE)
lCurrentStyle = lCurrentStyle And (Not WS_CAPTION)
lNewStyle = SetWindowLong(hwndToolTip, GWL_STYLE, lCurrentStyle)
lToolTipPrevWndProc = SetWindowLong(hwndToolTip, GWL_WNDPROC, AddressOf ToolTipWinProc)
#End If
tPt.X = Right + OffsetX
tPt.Y = Bottom + OffsetY
ClientToScreen lFormHwnd, tPt
SetWindowPos hwndToolTip, 0, tPt.X, tPt.Y, _
(lFontWidth + GetTextCharacterExtra(hDC)) * 20, lCalc + 5, &H40
ReleaseDC 0, hDC
If Not IsMissing(ToolTipSecondsDelay) Then
SetTimer hwndToolTip, 0, ToolTipSecondsDelay * 1000, AddressOf DestroyToolTip
End If
End Sub
Private Sub DestroyToolTip()
#If VBA7 Then
Call SetWindowLongPtr(hwndToolTip, GWL_WNDPROC, _
lToolTipPrevWndProc)
#Else
Call SetWindowLong(hwndToolTip, GWL_WNDPROC, _
lToolTipPrevWndProc)
#End If
DestroyWindow hwndToolTip
hwndToolTip = 0
oForm.Repaint
End Sub
#If VBA7 Then
Private Function FormWinProc _
(ByVal hWnd As LongPtr, ByVal uMsg As Long, _
ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
Dim hRgnWnd As LongPtr
#Else
Private Function FormWinProc _
(ByVal hWnd As Long, ByVal uMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
Dim hRgnWnd As Long
#End If
Dim i As Integer
Dim TempArray() As String
Dim LOWORD As Long, HIWORD As Long
Dim tCursorPos As POINTAPI
Dim tPt As POINTAPI
Dim tButtonWinRect As RECT
Dim tFormRect As RECT
Dim tFormClientRect As RECT
Dim EventAction As E_V_E_N_T
On Error Resume Next
Call MonitorErrors
Select Case uMsg
Case WM_PARENTNOTIFY
GetHiLoword CLng(wParam), LOWORD, HIWORD
If LOWORD = WM_LBUTTONDOWN Then
EventAction = ClickEvent
ElseIf LOWORD = WM_RBUTTONDOWN Then
EventAction = BeforeRightClick
End If
If EventAction <> 0 Then
GetHiLoword CLng(lParam), LOWORD, HIWORD
tCursorPos.X = LOWORD
tCursorPos.Y = HIWORD
ClientToScreen hWnd, tCursorPos
For i = 1 To UBound(sButtonsAttributesArray)
TempArray = Split(sButtonsAttributesArray(i), Chr(1))
hRgnWnd = TempArray(12)
If PtInRegion(hRgnWnd, tCursorPos.X, tCursorPos.Y) <> 0 Then
If Len(TempArray(15)) > 0 Then
GetWindowRect TempArray(10), tButtonWinRect
tPt.X = tButtonWinRect.Left
tPt.Y = tButtonWinRect.Top
ScreenToClient lFormHwnd, tPt
With tButtonWinRect
BitBlt lFormDC, tPt.X, tPt.Y, .Right - .Left, .Bottom - .Top, _
GetProp(TempArray(10), "ButtonPressed"), 0, 0, SRCCOPY
oForm.Repaint
End With
Application.OnTime Now, " 'EventMacro " & Chr(34) & TempArray(0) & Chr(34) & _
", " & Chr(34) & EventAction & Chr(34) & ", " & Chr(34) & tButtonXYCoords.X & Chr(34) & ", " & _
Chr(34) & tButtonXYCoords.Y & Chr(34) & ", " & Chr(34) & TempArray(10) & Chr(34) & " ' "
End If
Exit For
End If
Next i
End If
Case WM_SETCURSOR
GetCursorPos tCursorPos
ScreenToClient hWnd, tCursorPos
If PtInRegion(hFormMinusButtonsRegion, tCursorPos.X, tCursorPos.Y) <> 0 Then
bToollTipDelayExists = False
lCurrentRGN = 0
If CBool(IsWindow(hwndToolTip)) Then
Call DestroyToolTip
End If
If bStreching = True Then
bStreching = False
oForm.Repaint
End If
End If
Case WM_MOVE
For i = 1 To UBound(sButtonsAttributesArray)
TempArray = Split(sButtonsAttributesArray(i), Chr(1))
GetWindowRect TempArray(10), tButtonWinRect
DeleteObject TempArray(12)
With tButtonWinRect
TempArray(12) = CreateEllipticRgn _
(.Left, .Top, .Right, .Bottom)
End With
sButtonsAttributesArray(i) = Join(TempArray, Chr(1))
Next i
Case WM_EXITSIZEMOVE
SendMessage hWnd, ByVal WM_SETREDRAW, ByVal 1&, 0&
Case WM_ERASEBKGND
Call GetWindowRect(hWnd, tFormRect)
With tFormRect
If .Right > GetSystemMetrics(SM_CXSCREEN) Or .Left < 0 Or _
.Bottom > GetSystemMetrics(SM_CYSCREEN) Or .Top < 0 Then
SendMessage hWnd, ByVal WM_SETREDRAW, ByVal 0&, 0&
End If
End With
Case WM_DESTROY
Call unHookTheForm
RemoveCBTHook
hHook = 0
bAnErrorHasOccurred = False
GetClientRect hWnd, tFormClientRect
InvalidateRect hWnd, tFormClientRect, 0
For i = 1 To UBound(sButtonsAttributesArray)
TempArray = Split(sButtonsAttributesArray(i), Chr(1))
DeleteObject TempArray(12)
DestroyWindow TempArray(10)
Next i
Erase TempArray
Call CleanUp
End Select
#If VBA7 Then
FormWinProc = CallWindowProc _
(GetWindowLongPtr(Application.hWnd, GWL_USERDATA), _
GetProp(Application.hWnd, "FormHwnd"), uMsg, wParam, lParam)
#Else
FormWinProc = CallWindowProc _
(GetWindowLong(Application.hWnd, GWL_USERDATA), _
GetProp(Application.hWnd, "FormHwnd"), uMsg, wParam, lParam)
#End If
End Function
Private Sub CleanUp()
Erase sButtonsAttributesArray
DestroyWindow hwndToolTip
ReleaseDC lFormHwnd, lFormDC
DeleteDC lButtonReleasedMemDC
DeleteDC lButtonPressedMemDC
DeleteObject hFormMinusButtonsRegion
bStreching = False
iBoutonsCounter = 0
hwndToolTip = 0
hFormMinusButtonsRegion = 0
lCurrentRGN = 0
Set oForm = Nothing
End Sub
#If VBA7 Then
Private Function ButtonWinProc _
(ByVal hWnd As LongPtr, ByVal uMsg As Long, _
ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
Dim Atom_ID As LongPtr
#Else
Private Function ButtonWinProc _
(ByVal hWnd As Long, ByVal uMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
Dim Atom_ID As Long
#End If
Dim sBuffer As String
Dim lRet As Long
Dim LOWORD As Long, HIWORD As Long
Dim OffsetX, OffsetY As Long
On Error Resume Next
Select Case uMsg
Case WM_NCHITTEST
GetHiLoword CLng(lParam), LOWORD, HIWORD
tButtonXYCoords.X = LOWORD
tButtonXYCoords.Y = HIWORD
lCurrentRGN = GetProp(hWnd, "RGN")
ScreenToClient hWnd, tButtonXYCoords
If PtVisible(GetDC(hWnd), tButtonXYCoords.X, tButtonXYCoords.Y) <> 0 Then
If Not CBool(IsWindow(hwndToolTip)) And bToollTipDelayExists = False Then
sBuffer = Space(256)
Atom_ID = GetProp(hWnd, "ToolTipTextAndEventMacro_Atom")
lRet = GlobalGetAtomName(CInt(Atom_ID), sBuffer, Len(sBuffer))
sBuffer = Left(sBuffer, lRet)
sBuffer = Split(sBuffer, Chr(1))(0)
If Len(Left(sBuffer, lRet)) > 0 Then
OffsetX = IIf(GetProp(hWnd, "DoNotStretch") = 0, 15, -15)
OffsetY = IIf(GetProp(hWnd, "DoNotStretch") = 0, 2, -2)
Call ShowToolTip(Left(sBuffer, lRet), _
CLng(GetProp(hWnd, "ButtonLeft")), CLng(GetProp(hWnd, "ButtonTop")), _
CLng(GetProp(hWnd, "ButtonRight")), CLng(GetProp(hWnd, "ButtonBottom")), OffsetX, OffsetY, 5)
If GetProp(hWnd, "Beep") = 1 Then
MessageBeep MB_ICONASTERISK
End If
bToollTipDelayExists = True
End If
End If
If GetProp(hWnd, "DoNotStretch") = 0 Then
If Not bStreching Then
bStreching = True
DoEvents
StretchButton hWnd
DoEvents
End If
End If
End If
Case WM_NCDESTROY
#If VBA7 Then
Call SetWindowLongPtr(hWnd, GWL_WNDPROC, GetWindowLongPtr(hWnd, GWL_USERDATA))
#Else
Call SetWindowLong(hWnd, GWL_WNDPROC, GetWindowLong(hWnd, GWL_USERDATA))
#End If
DestroyWindow hWnd
End Select
#If VBA7 Then
ButtonWinProc = CallWindowProc(GetWindowLongPtr(hWnd, GWL_USERDATA), _
hWnd, uMsg, wParam, lParam)
#Else
ButtonWinProc = CallWindowProc(GetWindowLong(hWnd, GWL_USERDATA), _
hWnd, uMsg, wParam, lParam)
#End If
End Function
#If VBA7 Then
Private Function ToolTipWinProc _
(ByVal hWnd As LongPtr, ByVal uMsg As Long, _
ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
Dim hDC, hOldFont, hFont, hBrush As LongPtr
#Else
Private Function ToolTipWinProc _
(ByVal hWnd As Long, ByVal uMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
Dim hDC, hOldFont, hFont, hBrush As Long
#End If
Dim tPS As PAINTSTRUCT
Dim tFont As LOGFONT
Dim tFillLB As LOGBRUSH
Dim tToolTipClientRect As RECT
Select Case uMsg
Case WM_PAINT
BeginPaint hWnd, tPS
GetClientRect hWnd, tToolTipClientRect
hDC = GetDC(hWnd)
SetMapMode hDC, 1
SetBkMode hDC, 1
With tFont
.lfFaceName = "Tahoma" & Chr$(0)
.lfHeight = 16
.lfWidth = 6 '
End With
hFont = CreateFontIndirect(tFont)
hOldFont = SelectObject(hDC, hFont)
tFillLB.lbColor = GetSysColor(COLOR_INFOBK)
hBrush = CreateBrushIndirect(tFillLB)
FillRect hDC, tToolTipClientRect, hBrush
Call DeleteObject(hBrush)
DrawEdge hDC, tToolTipClientRect, EDGE_ETCHED, BF_RECT
SetTextColor hDC, GetSysColor(COLOR_INFOTEXT)
DrawText _
hDC, sToolTipText, Len(sToolTipText), tToolTipClientRect, _
DT_NOCLIP + DT_LEFT + DT_EDITCONTROL + DT_WORDBREAK
RedrawWindow hWnd, ByVal 0&, ByVal 0&, RDW_INTERNALPAINT
DeleteObject hFont
ReleaseDC 0, hDC
EndPaint hWnd, tPS
#If VBA7 Then
Call SetWindowLongPtr(hWnd, GWL_WNDPROC, lToolTipPrevWndProc)
#Else
Call SetWindowLong(hWnd, GWL_WNDPROC, lToolTipPrevWndProc)
#End If
End Select
ToolTipWinProc = CallWindowProc(lToolTipPrevWndProc, hWnd, uMsg, wParam, lParam)
End Function
Private Sub InstallCBTHook()
If hHook = 0 Then
hHook = SetWindowsHookExW(WH_CBT, AddressOf CBTProc, 0, GetCurrentThreadId)
End If
End Sub
Private Sub RemoveCBTHook()
Call UnhookWindowsHookEx(hHook)
hHook = 0
End Sub
#If VBA7 Then
Private Function EnumChildProc(ByVal hWnd As LongPtr, ByVal lParam As Long) As Long
#Else
Private Function EnumChildProc(ByVal hWnd As Long, ByVal lParam As Long) As Long
#End If
DestroyWindow hWnd
EnumChildProc = 1
End Function
#If VBA7 Then
Private Function CBTProc(ByVal nCode As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
Dim lCurrentStyle As LongPtr
#Else
Private Function CBTProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim lCurrentStyle As Long
#End If
Dim sBuffer As String
Dim lRet As Long
Select Case nCode
Case HCBT_ACTIVATE
sBuffer = Space(255)
lRet = GetWindowText(wParam, sBuffer, Len(sBuffer))
#If VBA7 Then
lCurrentStyle = GetWindowLongPtr(wParam, GWL_STYLE)
#Else
lCurrentStyle = GetWindowLong(wParam, GWL_STYLE)
#End If
If lCurrentStyle And DS_MODALFRAME Then
If InStr(1, Left(sBuffer, lRet), "Microsoft Visual Basic") > 0 Then
Call RemoveCBTHook
bAnErrorHasOccurred = True
End If
End If
End Select
CBTProc = CallNextHookEx(hHook, nCode, wParam, lParam)
End Function
Private Sub MonitorErrors()
If bAnErrorHasOccurred Then
EnumChildWindows lFormHwnd, AddressOf EnumChildProc, ByVal 0&
Call unHookTheForm
End If
End Sub
Private Function DarkenColor(ByVal lColor As Long) As Long
Dim R As Integer, g As Integer, B As Integer, i As Integer
R = lColor And &HFF
g = (lColor \ &H100) And &HFF
B = lColor \ &H10000
For i = 1 To 96
If R - 1 > -1 Then R = R - 1
If g - 1 > -1 Then g = g - 1
If B - 1 > -1 Then B = B - 1
Next i
DarkenColor = RGB(R, g, B)
End Function
Private Function LightenColor(ByVal lColor As Long) As Long
Dim R As Integer, g As Integer, B As Integer, i As Integer
R = lColor And &HFF
g = (lColor \ &H100) And &HFF
B = lColor \ &H10000
R = R + 96
g = g + 96
B = B + 96
LightenColor = RGB(R, g, B)
End Function
Private Sub GetHiLoword _
(Param As Long, ByRef LOWORD As Long, ByRef HIWORD As Long)
LOWORD = Param And &HFFFF&
HIWORD = Param \ &H10000 And &HFFFF&
End Sub
Private Function LongToUShort(Unsigned As Long) As Integer
LongToUShort = CInt(Unsigned - &H10000)
End Function
'******************************************************
' USERFORM CODE USAGE EXAMPLE
'******************************************************
'Private Sub UserForm_Activate()
' 'Add first round button using named arguments:
' Call AddRoundButton( _
' Form:=Me, _
' ButtonName:="Button1", _
' Left:=320, _
' Top:=20, _
' Width:=50, _
' Height:=50, _
' Caption:="Hello !", _
' FontColor:=vbBlack, _
' BackColor:=Me.BackColor, _
' TooltipText:= _
' "This is a long tooltip text demo to show that the tooltip automatically adjusts its size in order to accomodate the whole text.", _
' ToolTipBeep:=True, _
' AnimateButton:=False, _
' EventMacro:="Buttonevents" _
' )
'
' 'Add rest of the buttons without named arguments
' Call AddRoundButton(Me, "Button2", 130, 30, 100, 50, "Click Me", vbYellow, vbRed, , , , "ButtonEvents")
' Call AddRoundButton(Me, "Button3", 130, 120, 120, 50, "Elliptical button", vbBlue, , "hello!", True, True, "ButtonEvents")
' Call AddRoundButton(Me, "Button4", 250, 0, 60, 88, , vbYellow, RGB(200, 10, 200), "ToolTip Text.", , , "ButtonEvents")
' Call AddRoundButton(Me, "Button5", 30, 130, 60, 60, "Click Me", vbBlue, vbCyan, , , , "ButtonEvents")
' Call AddRoundButton(Me, "Button6", 80, 200, 40, 40, "hey", vbMagenta, , "This is an API based round Button.", True, True, "ButtonEvents")
' Call AddRoundButton(Me, "Button7", 280, 120, 60, 60, "Click Me", vbRed, RGB(120, 200, 150), "This is an API based round Button.", True, True, "ButtonEvents")
' Call AddRoundButton(Me, "Button8", 320, 180, 60, 80, "Click Me", vbRed, vbYellow, "This is an API based round Button.", True, True, "ButtonEvents")
' Call AddRoundButton(Me, "Button9", 30, 15, 80, 80, "MrExcel", , vbGreen, "This Button swells when the mouse pointer is placed over it.", , True, "ButtonEvents")
'End Sub
'
'
'
''This is the generic event macro for all the buttons ... (MUST be Public!!)
''The name of this event macro is optionally passed in the last argument of the AddRoundButton Sub
'Public Sub ButtonEvents(ByVal ButtonName As String, ByVal SoughtEvent As E_V_E_N_T, _
'ByVal CurXPos As Long, ByVal CurYPos As Long)
'
' 'Click code:
' If SoughtEvent = ClickEvent Then
' MsgBox "You Clicked : " & ButtonName & vbCr & "Mouse XPos: " & CurXPos & vbCr & "Mouse YPos: " & CurYPos
' End If
'
' 'RightClick code:
' If SoughtEvent = BeforeRightClick Then
' MsgBox "You RightClicked : " & ButtonName & vbCr & "Mouse XPos: " & CurXPos & vbCr & "Mouse YPos: " & CurYPos
' End If
'
' 'Mouse Down code:
' If SoughtEvent = MouseMoveEvent Then
' ' other code here...
' End If
'End SubReagrds.
