Option Explicit
Declare Function SetWindowsHookEx Lib _
"user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, _
ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Declare Function CallNextHookEx Lib "user32" _
(ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long
Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function sndPlaySound32 Lib "winmm.dll" Alias "sndPlaySoundA" _
(ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetForegroundWindow Lib "user32" () As Long
Private Declare Function GetDeviceCaps Lib "gdi32" ( _
ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Declare Function GetDC Lib "user32" ( _
ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" ( _
ByVal hwnd As Long, ByVal hDC As Long) As Long
Private Type POINTAPI
x As Long
y As Long
End Type
Const HC_ACTION = 0
Const WH_MOUSE_LL = 14
Const WM_MOUSEMOVE = &H200
Const LOGPIXELSX As Long = 88
Const LOGPIXELSY As Long = 90
Const PointsPerInch = 72
Dim hhkLowLevelMouse As Long
Dim blnHookEnabled As Boolean
Dim udtCursorPos As POINTAPI
Dim objTargetShape As Shape
Dim lnghDC As Long
Dim lngPixelsPerPointsX, lngPixelsPerPointsY, lngZoomPercentage
Function LocationPoint(Shp As Shape, Border As String) As POINTAPI
lnghDC = GetDC(0)
Dim x, y As Long
'\\ Get current screen Pixels per points + current Zoom
lngPixelsPerPointsX = GetDeviceCaps(lnghDC, LOGPIXELSX) / PointsPerInch
lngPixelsPerPointsY = GetDeviceCaps(lnghDC, LOGPIXELSY) / PointsPerInch
lngZoomPercentage = (ActiveWindow.Zoom / 100)
'\\ Determine the exact coordinates of the shape's(chart)edges in Pixels
Select Case Border
Case Is = "TopLeft"
x = ActiveWindow.PointsToScreenPixelsX(Shp.Left * _
(lngPixelsPerPointsX * lngZoomPercentage))
y = ActiveWindow.PointsToScreenPixelsY(Shp.Top * _
(lngPixelsPerPointsY * lngZoomPercentage))
Case Is = "TopRight"
x = ActiveWindow.PointsToScreenPixelsX((Shp.Left + Shp.Width) * _
(lngPixelsPerPointsX * lngZoomPercentage))
y = ActiveWindow.PointsToScreenPixelsY(Shp.Top * _
(lngPixelsPerPointsY * lngZoomPercentage))
Case Is = "BottomLeft"
x = ActiveWindow.PointsToScreenPixelsX(Shp.Left * _
(lngPixelsPerPointsX * lngZoomPercentage))
y = ActiveWindow.PointsToScreenPixelsY((Shp.Top + Shp.Height) * _
(lngPixelsPerPointsY * lngZoomPercentage))
Case Is = "BottomRight"
x = ActiveWindow.PointsToScreenPixelsX((Shp.Left + Shp.Width) * _
(lngPixelsPerPointsX * lngZoomPercentage))
y = ActiveWindow.PointsToScreenPixelsY((Shp.Top + Shp.Height) * _
(lngPixelsPerPointsY * lngZoomPercentage))
Case Else
MsgBox "error": Exit Function
End Select
With LocationPoint
.x = x
.y = y
End With
ReleaseDC 0, lnghDC
End Function
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub PlaySound()
If Application.CanPlaySounds Then
'Substitute the path and filename of the sound you want to play
Call sndPlaySound32("c:\windows\media\chimes.wav", 0)
End If
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Sub Hook_Mouse(Sh As Shape)
'\\ Prevent Hooking more than once
If blnHookEnabled = False Then
'\\ Change this Target Shape address as required
Set objTargetShape = Sh
hhkLowLevelMouse = SetWindowsHookEx _
(WH_MOUSE_LL, AddressOf LowLevelMouseProc, Application.Hinstance, 0)
blnHookEnabled = True
End If
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Sub UnHook_Mouse()
If hhkLowLevelMouse <> 0 Then UnhookWindowsHookEx hhkLowLevelMouse
'\\ reset Flag
blnHookEnabled = False
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Function LowLevelMouseProc _
(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'\\ Prevent error if No shape(chart) exists
On Error Resume Next
If (nCode = HC_ACTION) Then
'\\ when Mouse is moved
If wParam = WM_MOUSEMOVE Then
'\\ Process WM_MOUSEMOVE message first
LowLevelMouseProc = False
'\\ Get Mouse Pointer location in Screen Pixels
GetCursorPos udtCursorPos
'\\Check if Mouse is within the shape(chart)rectangle
'\\ Also make sure XL is active
With udtCursorPos
If (.x > LocationPoint(objTargetShape, "TopLeft").x) And _
(.x < LocationPoint(objTargetShape, "TopRight").x) And _
.y > LocationPoint(objTargetShape, "TopLeft").y _
And .y < LocationPoint(objTargetShape, "BottomLeft").y And _
ActiveSheet Is objTargetShape.Parent And _
GetForegroundWindow = FindWindow("XLMAIN", Application.Caption) And _
Application.WindowState <> xlMinimized Then '\\if so generate sound
PlaySound
End If
End With
End If
Exit Function
End If
' \\ Call next hook if any
LowLevelMouseProc = CallNextHookEx(0, nCode, wParam, ByVal lParam)
End Function