Jaafar Tribak
Well-known Member
- Joined
- Dec 5, 2002
- Messages
- 9,797
- Office Version
- 2016
- Platform
- Windows
Hi all.
I just thought I would share this with you.
PULSATING CELL DEMO.
Takes a snapshot of the Cell and uses a Timer to expand and shrink it periodically. The resulting visual effect is that of a pulsating cell which could ,for example, be used to draw the user's attention when an event occurs. Not exactly very useful but fun to use and more importantly a good coding learning exercise .
A usage example that pulsates Cell D10 :
Main code- goes in a Standard module :
Tested on Excel 2003 Win XP.
Regards.
I just thought I would share this with you.
PULSATING CELL DEMO.
Takes a snapshot of the Cell and uses a Timer to expand and shrink it periodically. The resulting visual effect is that of a pulsating cell which could ,for example, be used to draw the user's attention when an event occurs. Not exactly very useful but fun to use and more importantly a good coding learning exercise .
A usage example that pulsates Cell D10 :
Code:
Option Explicit
Sub StartPulsating()
PulsateRange Target:=Sheets(1).Range("D10"), PlaySound:=True
End Sub
Main code- goes in a Standard module :
Code:
Option Explicit
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 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 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 Declare Function CreateCompatibleDC Lib "gdi32" _
(ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" _
(ByVal hdc As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32" _
(ByVal hdc As Long, _
ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long
Private 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
Private 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
Private Declare Function InvalidateRect Lib "user32.dll" _
(ByVal hwnd As Long, _
ByVal lpRect As Long, _
ByVal bErase As Long) As Long
Private Declare Function RedrawWindow Lib "user32" _
(ByVal hwnd As Long, _
ByVal lprcUpdate As Long, _
ByVal hrgnUpdate As Long, _
ByVal fuRedraw As Long) As Long
Private Declare Function ScreenToClient Lib "user32" ( _
ByVal hwnd As Long, _
lpPoint As POINTAPI) As Long
Private Declare Function SetRect Lib "user32.dll" _
(ByRef lpRect As RECT, _
ByVal X1 As Long, _
ByVal Y1 As Long, _
ByVal X2 As Long, _
ByVal Y2 As Long) As Long
Private Declare Function CreateRectRgn Lib "gdi32.dll" _
(ByVal X1 As Long, _
ByVal Y1 As Long, _
ByVal X2 As Long, _
ByVal Y2 As Long) As Long
Private Declare Function PlaySoundAPI Lib "winmm.dll" _
Alias "PlaySoundA" _
(ByVal lpszName As String, _
ByVal hModule As Long, _
ByVal dwFlags As Long) As Long
Private Declare Function SetTimer Lib "user32.dll" _
(ByVal hwnd As Long, _
ByVal nIDEvent As Long, _
ByVal uElapse As Long, _
ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32.dll" _
(ByVal hwnd As Long, _
ByVal nIDEvent As Long) As Long
Private Const SRCCOPY As Long = &HCC0020
Private Const LOGPIXELSX As Long = 88
Private Const LOGPIXELSY As Long = 90
Private Const RDW_INVALIDATE As Long = &H1
Private Const RDW_ALLCHILDREN As Long = &H80
Private Const SND_ASYNC As Long = &H1
Private Const SND_FILENAME As Long = &H20000
Private Const SND_LOOP As Long = &H8
Private Const CYCLE As Long = 40
Private Const POINTSPERINCH As Long = 72
Private Const SOUNDFILEPATHNAME As String = _
"C:\WINDOWS\MEDIA\chimes.WAV" 'change sound file as required.
Private tRect As RECT
Private tUpdateRect As RECT
Private lWBHwnd As Long
Private lMemoryDC As Long
Private lInterval As Long
Private oPulsatingRange As Range
Private vInitialRangeVal As Variant
Private bPlayBeep As Boolean
Sub PulsateRange _
(ByVal Target As Range, Optional ByVal PlaySound As Boolean)
Dim lXLDeskhwnd As Long
vInitialRangeVal = Target
lInterval = 0
Set oPulsatingRange = Target
lXLDeskhwnd = _
FindWindowEx(FindWindow("XLMAIN", Application.Caption) _
, 0, "XLDESK", vbNullString)
lWBHwnd = FindWindowEx _
(lXLDeskhwnd, 0, "EXCEL7", vbNullString)
If PlaySound Then
If Len(Dir(SOUNDFILEPATHNAME)) <> 0 Then
PlaySoundAPI SOUNDFILEPATHNAME, _
ByVal 0&, SND_FILENAME Or SND_ASYNC Or SND_LOOP
Else
bPlayBeep = True
End If
End If
Call TakeRangeSnapShot(ByVal oPulsatingRange)
End Sub
Sub StopPulsating()
KillTimer lWBHwnd, 0
InvalidateRect 0, 0, 0
PlaySoundAPI vbNullString, 0, 0
bPlayBeep = False
lInterval = 0
End Sub
Private Sub TakeRangeSnapShot(ByVal Target As Range)
Dim lDC As Long
lInterval = 0
lDC = GetDC(lWBHwnd)
With GetRangeRect(ByVal Target)
Call GetRngBmpHandle(lDC, .Left, .Top, _
(.Right - .Left), (.Bottom - .Top))
SetRect tRect, .Left, .Top, .Right, .Bottom
End With
ReleaseDC 0, lDC
SetTimer lWBHwnd, 0, 1, AddressOf TimerProc1
End Sub
Private Sub TimerProc1()
Dim lDC As Long
Dim lhRng As Long
On Error Resume Next
If Not ActiveSheet Is oPulsatingRange.Parent Then Exit Sub
lDC = GetDC(lWBHwnd)
If (GetRangeRect(ByVal oPulsatingRange).Right <> tRect.Right _
Or GetRangeRect(ByVal oPulsatingRange).Top <> tRect.Top) Or _
vInitialRangeVal <> oPulsatingRange.Value Then
InvalidateRect 0, 0, 0
tRect.Right = GetRangeRect(ByVal oPulsatingRange).Right
tRect.Top = GetRangeRect(ByVal oPulsatingRange).Top
vInitialRangeVal = oPulsatingRange.Value
KillTimer lWBHwnd, 0
SetTimer lWBHwnd, 0, 1, AddressOf TimerProc2
ReleaseDC 0, lDC
Exit Sub
End If
With tRect
If lInterval < (CYCLE / 2) Then
StretchBlt _
lDC, .Left - lInterval, .Top - lInterval, _
(.Right - .Left) + 2 * lInterval, _
(.Bottom - .Top) + 2 * lInterval, _
lMemoryDC, 0, 0, (.Right - .Left), _
(.Bottom - .Top), SRCCOPY
tUpdateRect.Left = .Left - lInterval
tUpdateRect.Top = .Top - lInterval
tUpdateRect.Right = tUpdateRect.Left + _
(.Right - .Left) + (2 * lInterval)
tUpdateRect.Bottom = tUpdateRect.Top + _
(.Bottom - .Top) + (2 * lInterval)
Else
With tUpdateRect
lhRng = CreateRectRgn _
(.Left, .Top, .Right, .Bottom)
End With
RedrawWindow lWBHwnd, 0, lhRng, _
RDW_INVALIDATE + RDW_ALLCHILDREN
DoEvents
With tUpdateRect
StretchBlt _
lDC, .Left + lInterval - (CYCLE / 2), _
.Top + lInterval - (CYCLE / 2), _
(.Right - .Left) - (lInterval - _
(CYCLE / 2)) * 2, (.Bottom - .Top) - _
(lInterval - (CYCLE / 2)) * 2, _
lMemoryDC, 0, 0, (tRect.Right - tRect.Left), _
(tRect.Bottom - tRect.Top), SRCCOPY
End With
End If
End With
ReleaseDC 0, lDC
lInterval = lInterval + 1
If lInterval = CYCLE Then
If bPlayBeep Then Beep
lInterval = 0
End If
End Sub
Private Sub TimerProc2()
KillTimer lWBHwnd, 0
Call TakeRangeSnapShot(ByVal oPulsatingRange)
End Sub
Private Sub GetRngBmpHandle _
(lDC As Long, lRngLeft As Long, lRngTop As Long, _
lRngWidth As Long, lRngHeight As Long)
Dim lBmp As Long
lMemoryDC = CreateCompatibleDC(lDC)
lBmp = CreateCompatibleBitmap(lDC, lRngWidth, lRngHeight)
DeleteObject SelectObject(lMemoryDC, lBmp)
BitBlt lMemoryDC, 0, 0, lRngWidth, lRngHeight, _
lDC, lRngLeft, lRngTop, SRCCOPY
ReleaseDC lMemoryDC, 0
End Sub
Private Function ScreenDPI(bVert As Boolean) As Long
Static lDPI(1), lDC
If lDPI(0) = 0 Then
lDC = GetDC(0)
lDPI(0) = GetDeviceCaps(lDC, LOGPIXELSX)
lDPI(1) = GetDeviceCaps(lDC, LOGPIXELSY)
lDC = ReleaseDC(0, lDC)
End If
ScreenDPI = lDPI(Abs(bVert))
End Function
Private Function PTtoPX _
(Points As Single, bVert As Boolean) As Long
PTtoPX = Points * ScreenDPI(bVert) / POINTSPERINCH
End Function
Private Function GetRangeRect(ByVal rng As Range) As RECT
Dim tPt1 As POINTAPI
Dim tPt2 As POINTAPI
Dim OWnd As Window
On Error Resume Next
Set OWnd = rng.Parent.Parent.Windows(1)
With rng
GetRangeRect.Left = _
PTtoPX(.Left * OWnd.Zoom / 100, 0) _
+ OWnd.PointsToScreenPixelsX(0)
GetRangeRect.Top = _
PTtoPX(.Top * OWnd.Zoom / 100, 1) _
+ OWnd.PointsToScreenPixelsY(0)
GetRangeRect.Right = _
PTtoPX(.Width * OWnd.Zoom / 100, 0) _
+ GetRangeRect.Left
GetRangeRect.Bottom = _
PTtoPX(.Height * OWnd.Zoom / 100, 1) _
+ GetRangeRect.Top
End With
With GetRangeRect
tPt1.x = .Left
tPt1.y = .Top
tPt2.x = .Right
tPt2.y = .Bottom
ScreenToClient lWBHwnd, tPt1
ScreenToClient lWBHwnd, tPt2
.Left = tPt1.x
.Top = tPt1.y
.Right = tPt2.x
.Bottom = tPt2.y
End With
End Function
Tested on Excel 2003 Win XP.
Regards.