Option Explicit
Enum Speed
Slow = 1
Medium = 2
fast = 3
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 LOGBRUSH
lbStyle As Long
lbColor As Long
lbHatch As Long
End Type
Private Type PAINTSTRUCT
hDC As Long
fErase As Long
rcPaint As RECT
fRestore As Long
fIncUpdate As Long
rgbReserved(32) As Byte
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 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
Private Declare Function ShowWindow Lib "user32" _
(ByVal HWnd As Long, _
ByVal nCmdShow As Long) As Long
Private Declare Function MoveWindow Lib "user32" _
(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 DestroyWindow Lib "user32" _
(ByVal HWnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" _
(ByVal HWnd As Long, ByVal hdc1 As Long) As Long
Private Declare Function FillRect Lib "user32" _
(ByVal hdc1 As Long, lpRect As RECT, _
ByVal hBrush As Long) As Long
Private Declare Function GetClientRect Lib "user32" _
(ByVal HWnd As Long, lpRect As RECT) As Long
Private Declare Function PtInRect Lib "user32" _
(lpRect As RECT, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function GetCursorPos Lib "user32.dll" _
(ByRef lpPoint As POINTAPI) _
As Long
Private Declare Function InvalidateRect Lib "user32.dll" _
(ByVal HWnd As Long, _
ByVal lpRect As Long, _
ByVal bErase As Long) As Long
Private Declare Function FindWindowEx Lib "user32" _
Alias "FindWindowExA" _
(ByVal hWnd1 As Long, _
ByVal hWnd2 As Long, _
ByVal lpsz1 As String, _
ByVal lpsz2 As String) As Long
Private Declare Function ClientToScreen Lib "user32.dll" _
(ByVal HWnd As Long, ByRef lpPoint As POINTAPI) As Long
Private Declare Function SetParent Lib "user32.dll" _
(ByVal hWndChild As Long, _
ByVal hWndNewParent As Long) As Long
Private Declare Function GetWindowRect Lib "user32.dll" _
(ByVal HWnd As Long, ByRef lpRect As RECT) As Long
Private Declare Sub Sleep Lib "kernel32" _
(ByVal dwMilliseconds As Long)
Private Declare Function GetFocus Lib "user32.dll" () _
As Long
Private Declare Function BeginPaint Lib "user32.dll" _
(ByVal HWnd As Long, _
ByRef lpPaint As PAINTSTRUCT) As Long
Private Declare Function EndPaint Lib "user32.dll" _
(ByVal HWnd As Long, _
ByRef lpPaint As PAINTSTRUCT) As Long
Private Declare Function CreateBrushIndirect Lib "gdi32" _
(lpLogBrush As LOGBRUSH) As Long
Private Declare Function SetBkMode Lib "gdi32" _
(ByVal hDC As Long, _
ByVal nBkMode As Long) As Long
Private Declare Function DrawText Lib "user32" _
Alias "DrawTextA" _
(ByVal lShapeDC As Long, _
ByVal lpStr As String, _
ByVal nCount As Long, _
lpRect As RECT, _
ByVal wFormat As Long) As Long
Private Declare Function CreateFontIndirect Lib "gdi32" _
Alias "CreateFontIndirectA" _
(lpLogFont As LOGFONT) As Long
Private Declare Function SelectObject Lib "gdi32" _
(ByVal lShapeDC As Long, _
ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long
Private Declare Function DrawEdge Lib "user32" _
(ByVal hDC As Long, _
qrc As RECT, _
ByVal edge As Long, _
ByVal grfFlags As Long) As Long
Private Declare Function GetProp Lib "user32" _
Alias "GetPropA" _
(ByVal HWnd As Long, _
ByVal lpString As String) As Long
Private Declare Function SetProp Lib "user32" _
Alias "SetPropA" _
(ByVal HWnd As Long, _
ByVal lpString As String, _
ByVal hData As Long) As Long
Private Declare Function RemoveProp Lib "user32" _
Alias "RemovePropA" _
(ByVal HWnd As Long, _
ByVal lpString As String) As Long
Private Declare Function GetSysColor Lib "user32" _
(ByVal nIndex As Long) As Long
Private Declare Function PlaySound Lib "winmm.dll" _
Alias "PlaySoundA" (ByVal lpszName As String, _
ByVal hModule As Long, ByVal dwFlags As Long) As Long
Private Const WS_CHILD = &H40000000
Private Const DT_SINGLELINE = &H20
Private Const DT_CENTER = &H1
Private Const DT_VCENTER = &H4
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 SND_FILENAME = &H20000
Private Const SND_LOOP = &H8
Private Const SND_ASYNC = &H1
Private tWB_ClRect As RECT
Private tWB_Rect As RECT
Private tBtn_Rect As RECT
Private tBtn_ClRect As RECT
Private dWidth As Double
Private dHeight As Double
Private hWB As Long
Private bExitLoop As Boolean
Private bCaptionDrawed As Boolean
Private bLoopRunning As Boolean
Sub TEST()
Call CreateBouncingButton( _
Width:=150, _
Height:=30, _
Caption:="Click Me !", _
Fill:=vbYellow, _
Speed:=Medium, _
Blinking:=True, _
SoundFile:="C:\WINDOWS\MEDIA\Notify.wav", _
On_ClickMacro:="Macro" _
)
End Sub
Sub CloseIt()
DestroyWindow GetProp(Application.HWnd, "BouncingButton")
bExitLoop = True
End Sub
'--------------------
'Private routines . '
'--------------------
Private Sub CreateBouncingButton( _
Optional Width As Double, _
Optional Height As Double, _
Optional Caption As String, _
Optional Fill As Long, _
Optional Speed As Speed, _
Optional Blinking As Boolean, _
Optional SoundFile As String, _
Optional On_ClickMacro As String)
Dim hBtn As Long
hBtn = CreateButton(Width, Height)
If hBtn Then
Call BounceButton _
(hBtn, Caption, Fill, Speed, Blinking, _
SoundFile, On_ClickMacro)
End If
End Sub
Private Function CreateButton( _
Optional Width As Double, _
Optional Height As Double _
) As Long
Dim tpt1 As POINTAPI
Dim tpt2 As POINTAPI
Dim hXLDSK As Long
Dim hBtn As Long
Dim lInitX As Long
Dim lInitY As Long
If bLoopRunning Then Exit Function
hXLDSK = FindWindowEx _
(Application.HWnd, 0&, "XLDESK", vbNullString)
hWB = FindWindowEx(hXLDSK, 0&, "EXCEL7", vbNullString)
GetClientRect hWB, tWB_ClRect
With tWB_ClRect
tpt1.X = .Left
tpt1.Y = .Top
tpt2.X = .Right
tpt2.Y = .Bottom
ClientToScreen hWB, tpt1
ClientToScreen hWB, tpt2
Randomize
lInitX = (tpt2.X - tpt1.X) / 2 * Rnd
Randomize
lInitY = (tpt2.Y - tpt1.Y) / 2 * Rnd
End With
DestroyWindow GetProp(Application.HWnd, "BouncingButton")
If Width = 0 Then Width = 50
If Height = 0 Then Height = 50
dWidth = Width
dHeight = Height
hBtn = CreateWindowEx(0, "button", _
"", WS_CHILD, lInitX, lInitY, Width, Height, hWB, 0, 0, 0)
SetProp Application.HWnd, "BouncingButton", hBtn
SetParent hBtn, hWB
CreateButton = hBtn
End Function
Private Sub BounceButton( _
hBtn As Long, _
Optional Caption As String, _
Optional Fill As Long, _
Optional Speed As Speed, _
Optional Blinking As Boolean, _
Optional SoundFile As String, _
Optional On_ClickMacro As String)
Dim Xcoor As Long
Dim Ycoor As Long
Dim Xoffset As Long
Dim Yoffset As Long
Dim tCurPos As POINTAPI
GetWindowRect hBtn, tBtn_Rect
Xcoor = tBtn_Rect.Left
Ycoor = tBtn_Rect.Top
Randomize
Xoffset = Int((20 * Rnd) - 10)
Randomize
Yoffset = Int((20 * Rnd) - 10)
ShowWindow hBtn, 1
If Len(SoundFile) <> 0 Then
If Len(Dir(SoundFile)) <> 0 Then
PlaySound SoundFile, ByVal 0&, _
SND_FILENAME Or SND_ASYNC Or SND_LOOP
End If
End If
bExitLoop = False
Do
bLoopRunning = True
GetClientRect hWB, tWB_ClRect
GetWindowRect hBtn, tBtn_Rect
GetClientRect hBtn, tBtn_ClRect
If Ycoor + dHeight + 1 >= tWB_ClRect.Bottom Or _
Ycoor - 1 <= tWB_ClRect.Top Then
Yoffset = -Yoffset
Randomize
Xoffset = Int((20 * Rnd) - 10)
End If
If Xcoor + dWidth + 1 >= tWB_ClRect.Right Or _
Xcoor - 1 <= tWB_ClRect.Left Then
Xoffset = -Xoffset
Randomize
Yoffset = Int((20 * Rnd) - 10)
End If
Ycoor = Ycoor + Yoffset
Xcoor = Xcoor + Xoffset
InvalidateRect hBtn, 0, 0
If Blinking Then
If Timer Mod 2 = 0 Then
Call PaintButton(hBtn, Caption, Fill)
Else
Call PaintButton(hBtn, "", Fill)
End If
End If
Call PaintButton(hBtn, Caption, Fill)
MoveWindow hBtn, Xcoor, Ycoor, dWidth, dHeight, 1
bCaptionDrawed = False
GetCursorPos tCurPos
Do While PtInRect(tBtn_Rect, tCurPos.X, tCurPos.Y) <> 0
GetCursorPos tCurPos
If Not bCaptionDrawed Then
bCaptionDrawed = True
InvalidateRect hBtn, 0, 0
Call PaintButton(hBtn, Caption, Fill)
End If
MoveWindow hBtn, Xcoor, Ycoor, dWidth, dHeight, 1
If GetFocus = hBtn Then
ShowWindow hBtn, 0
If Len(On_ClickMacro) <> 0 Then
Application.Run On_ClickMacro
End If
ShowWindow hBtn, 1
Exit Do
End If
DoEvents
Loop
Select Case True
Case Speed = 0
Speed = Medium
Case Speed = Slow
Speed = Speed * 200
Case Speed = Medium
Speed = Speed * 35
Case Speed = fast
Speed = Speed * 4
End Select
DoEvents
Sleep Speed
Loop Until bExitLoop
bLoopRunning = False
PlaySound vbNullString, ByVal 0&, SND_FILENAME Or SND_ASYNC
End Sub
Private Sub PaintButton( _
hBtn As Long, _
Optional Caption As String, _
Optional Fill As Long _
)
Dim tPS As PAINTSTRUCT
Dim tLB As LOGBRUSH
Dim tFont As LOGFONT
Dim tBtn_Rect As RECT
Dim hBrush As Long
Dim lFont As Long
Dim hDC As Long
hDC = BeginPaint(hBtn, tPS)
tLB.lbColor = IIf(Fill, Fill, (GetSysColor(10)))
hBrush = CreateBrushIndirect(tLB)
FillRect hDC, tBtn_ClRect, hBrush
DeleteObject hBrush
If Len(Caption) <> 0 Then
tFont.lfHeight = 12
tFont.lfWidth = 10
lFont = CreateFontIndirect(tFont)
SetBkMode hDC, 1
DrawText hDC, Caption, Len(Caption), tBtn_ClRect, _
DT_CENTER + DT_VCENTER + DT_SINGLELINE
DeleteObject lFont
End If
DrawEdge hDC, tBtn_ClRect, EDGE_ETCHED, BF_RECT
EndPaint hBtn, tPS
ReleaseDC hBtn, hDC
End Sub
Private Sub Macro()
If MsgBox("Do you want to remove the 'Bouncing Button' ?", _
vbQuestion + vbYesNo) = vbYes Then
DestroyWindow GetProp(Application.HWnd, "BouncingButton")
bExitLoop = True
End If
End Sub
