Cool Pulsating Cell !!

Jaafar Tribak

Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
9,806
Office Version
  1. 2016
Platform
  1. 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 :

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.
 

Excel Facts

Easy bullets in Excel
If you have a numeric keypad, press Alt+7 on numeric keypad to type a bullet in Excel.
Sort by date Sort by votes
Hi Jaafar,

I just spotted this. How cool!!!

Mark
 
Upvote 0
Upo request of a member, I am posting here an update of the code that is compatible with Excel 32 and 64 bits

Workbook Update demo

Place this code in standard module and run the Test Macro:

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


#If VBA7 Then
    Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
    Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
    Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hdc As LongPtr, ByVal nIndex 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 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 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 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 InvalidateRect Lib "user32" (ByVal hwnd As LongPtr, ByVal lpRect As Long, ByVal bErase As Long) 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 ScreenToClient Lib "user32" (ByVal hwnd As LongPtr, lpPoint As POINTAPI) As Long
    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 CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As LongPtr
    Declare PtrSafe Function PlaySoundAPI Lib "winmm.dll" Alias "PlaySoundA" (ByVal lpszName As String, ByVal hModule As LongPtr, ByVal dwFlags 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


    Dim lWBHwnd As LongPtr, lXLDeskhwnd As LongPtr, lhRng As LongPtr, lBmp As LongPtr, lMemoryDC As LongPtr, lDC1 As LongPtr, lDC2 As LongPtr, lDC3 As LongPtr
#Else
    Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA"(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    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
    Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex 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 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 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 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 InvalidateRect Lib "user32.dll" (ByVal hwnd As Long,ByVal lpRect As Long,ByVal bErase As Long) 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 ScreenToClient Lib "user32" (ByVal hwnd As Long,lpPoint As POINTAPI) As Long
    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
    Declare Function CreateRectRgn Lib "gdi32.dll" (ByVal X1 As Long,ByVal Y1 As Long,ByVal X2 As Long, ByVal Y2 As Long) As Long
    Declare Function PlaySoundAPI Lib "winmm.dll" Alias "PlaySoundA" (ByVal lpszName As String,ByVal hModule As Long,ByVal dwFlags As Long) As Long
    Declare Function SetTimer Lib "user32.dll"(ByVal hwnd As Long,ByVal nIDEvent As Long,ByVal uElapse As Long,ByVal lpTimerFunc As Long) As Long
    Declare Function KillTimer Lib "user32.dll" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
    
    Dim lWBHwnd As Long, lXLDeskhwnd As Long, lhRng As Long, lBmp As Long, lMemoryDC As Long, lDC1 As Long, lDC2 As Long, lDC3 As Long
#End If
 
Private Const SRCCOPY = &HCC0020
Private Const LOGPIXELSX = 88
Private Const LOGPIXELSY = 90
Private Const RDW_INVALIDATE = &H1
Private Const RDW_ALLCHILDREN = &H80
Private Const SND_ASYNC = &H1
Private Const SND_FILENAME = &H20000
Private Const SND_LOOP = &H8
Private Const CYCLE = 40
Private Const POINTSPERINCH = 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 lInterval As Long
Private oPulsatingRange As Range
Private vInitialRangeVal As Variant
Private bPlayBeep As Boolean
Private bPulsating As Boolean




Sub Test()
    Call PulsateRange(Target:=Sheet1.Range("G8"), PlaySound:=True)
End Sub


 
Sub PulsateRange(ByVal Target As Range, Optional ByVal PlaySound As Boolean)
    If bPulsating Then Exit Sub
    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
    bPulsating = True
    Call TakeRangeSnapShot(ByVal oPulsatingRange)
End Sub
 
Sub StopPulsating()
    KillTimer Application.hwnd, 0
    DeleteDC lMemoryDC
    InvalidateRect 0, 0, 0
    PlaySoundAPI vbNullString, 0, 0
    bPlayBeep = False
    lInterval = 0
    bPulsating = False
End Sub
 
Private Sub TakeRangeSnapShot(ByVal Target As Range)
    lInterval = 0
    lDC1 = GetDC(lWBHwnd)
    With GetRangeRect(ByVal Target)
        Call GetRngBmpHandle(lDC1, .Left, .Top, _
        (.Right - .Left), (.Bottom - .Top))
        SetRect tRect, .Left, .Top, .Right, .Bottom
    End With
    ReleaseDC 0, lDC1
    SetTimer Application.hwnd, 0, 1, AddressOf TimerProc1
End Sub
 
Private Sub TimerProc1()
    On Error Resume Next
    If Not ActiveSheet Is oPulsatingRange.Parent Then Exit Sub
    lDC2 = 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 Application.hwnd, 0
        SetTimer Application.hwnd, 0, 1, AddressOf TimerProc2
        ReleaseDC 0, lDC2
        Exit Sub
    End If
    With tRect
        If lInterval < (CYCLE / 2) Then
            StretchBlt _
            lDC2, .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 _
                lDC2, .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, lDC2
        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 LongPtr, lRngLeft As Long, lRngTop As Long, lRngWidth As Long, lRngHeight As Long)
    lMemoryDC = CreateCompatibleDC(lDC)
    lBmp = CreateCompatibleBitmap(lDC, lRngWidth, lRngHeight)
    DeleteObject SelectObject(lMemoryDC, lBmp)
    BitBlt lMemoryDC, 0, 0, lRngWidth, lRngHeight, _
    lDC, lRngLeft, lRngTop, SRCCOPY
End Sub
 
Private Function ScreenDPI(bVert As Boolean) As Long
    Static lDPI(1) As Long
    If lDPI(0) = 0 Then
        lDC3 = GetDC(0)
        lDPI(0) = GetDeviceCaps(lDC3, LOGPIXELSX)
        lDPI(1) = GetDeviceCaps(lDC3, LOGPIXELSY)
        lDC3 = ReleaseDC(0, lDC3)
    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
 
Last edited:
Upvote 0
Editing time up so quick !!

I forgot to to include a conditional compiler structure for the GetRngBmpHandle routine ... Ignore the previous code and workbook demo and use this one :

Workbook update demo

Place this code in a Standard module and run the Test Macro:

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


#If VBA7 Then
    Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
    Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
    Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hdc As LongPtr, ByVal nIndex 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 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 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 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 InvalidateRect Lib "user32" (ByVal hwnd As LongPtr, ByVal lpRect As Long, ByVal bErase As Long) 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 ScreenToClient Lib "user32" (ByVal hwnd As LongPtr, lpPoint As POINTAPI) As Long
    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 CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As LongPtr
    Declare PtrSafe Function PlaySoundAPI Lib "winmm.dll" Alias "PlaySoundA" (ByVal lpszName As String, ByVal hModule As LongPtr, ByVal dwFlags 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


    Dim lWBHwnd As LongPtr, lXLDeskhwnd As LongPtr, lhRng As LongPtr, lBmp As LongPtr, lMemoryDC As LongPtr, lDC1 As LongPtr, lDC2 As LongPtr, lDC3 As LongPtr
#Else
    Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA"(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    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
    Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex 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 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 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 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 InvalidateRect Lib "user32.dll" (ByVal hwnd As Long,ByVal lpRect As Long,ByVal bErase As Long) 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 ScreenToClient Lib "user32" (ByVal hwnd As Long,lpPoint As POINTAPI) As Long
    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
    Declare Function CreateRectRgn Lib "gdi32.dll" (ByVal X1 As Long,ByVal Y1 As Long,ByVal X2 As Long, ByVal Y2 As Long) As Long
    Declare Function PlaySoundAPI Lib "winmm.dll" Alias "PlaySoundA" (ByVal lpszName As String,ByVal hModule As Long,ByVal dwFlags As Long) As Long
    Declare Function SetTimer Lib "user32.dll"(ByVal hwnd As Long,ByVal nIDEvent As Long,ByVal uElapse As Long,ByVal lpTimerFunc As Long) As Long
    Declare Function KillTimer Lib "user32.dll" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
    
    Dim lWBHwnd As Long, lXLDeskhwnd As Long, lhRng As Long, lBmp As Long, lMemoryDC As Long, lDC1 As Long, lDC2 As Long, lDC3 As Long
#End If
 
Private Const SRCCOPY = &HCC0020
Private Const LOGPIXELSX = 88
Private Const LOGPIXELSY = 90
Private Const RDW_INVALIDATE = &H1
Private Const RDW_ALLCHILDREN = &H80
Private Const SND_ASYNC = &H1
Private Const SND_FILENAME = &H20000
Private Const SND_LOOP = &H8
Private Const CYCLE = 40
Private Const POINTSPERINCH = 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 lInterval As Long
Private oPulsatingRange As Range
Private vInitialRangeVal As Variant
Private bPlayBeep As Boolean
Private bPulsating As Boolean




Sub Test()
    Call PulsateRange(Target:=Sheet1.Range("G8"), PlaySound:=True)
End Sub


 
Sub PulsateRange(ByVal Target As Range, Optional ByVal PlaySound As Boolean)
    If bPulsating Then Exit Sub
    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
    bPulsating = True
    Call TakeRangeSnapShot(ByVal oPulsatingRange)
End Sub
 
Sub StopPulsating()
    KillTimer Application.hwnd, 0
    DeleteDC lMemoryDC
    InvalidateRect 0, 0, 0
    PlaySoundAPI vbNullString, 0, 0
    bPlayBeep = False
    lInterval = 0
    bPulsating = False
End Sub
 
Private Sub TakeRangeSnapShot(ByVal Target As Range)
    lInterval = 0
    lDC1 = GetDC(lWBHwnd)
    With GetRangeRect(ByVal Target)
        Call GetRngBmpHandle(lDC1, .Left, .Top, _
        (.Right - .Left), (.Bottom - .Top))
        SetRect tRect, .Left, .Top, .Right, .Bottom
    End With
    ReleaseDC 0, lDC1
    SetTimer Application.hwnd, 0, 1, AddressOf TimerProc1
End Sub
 
Private Sub TimerProc1()
    On Error Resume Next
    If Not ActiveSheet Is oPulsatingRange.Parent Then Exit Sub
    lDC2 = 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 Application.hwnd, 0
        SetTimer Application.hwnd, 0, 1, AddressOf TimerProc2
        ReleaseDC 0, lDC2
        Exit Sub
    End If
    With tRect
        If lInterval < (CYCLE / 2) Then
            StretchBlt _
            lDC2, .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 _
                lDC2, .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, lDC2
        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
 
#If VBA7 Then
    Private Sub GetRngBmpHandle(lDC As LongPtr, lRngLeft As Long, lRngTop As Long, lRngWidth As Long, lRngHeight As Long)
#Else
    Private Sub GetRngBmpHandle(lDC As Long, lRngLeft As Long, lRngTop As Long, lRngWidth As Long, lRngHeight As Long)
#End If
    lMemoryDC = CreateCompatibleDC(lDC)
    lBmp = CreateCompatibleBitmap(lDC, lRngWidth, lRngHeight)
    DeleteObject SelectObject(lMemoryDC, lBmp)
    BitBlt lMemoryDC, 0, 0, lRngWidth, lRngHeight, _
    lDC, lRngLeft, lRngTop, SRCCOPY
End Sub
 
Private Function ScreenDPI(bVert As Boolean) As Long
    Static lDPI(1) As Long
    If lDPI(0) = 0 Then
        lDC3 = GetDC(0)
        lDPI(0) = GetDeviceCaps(lDC3, LOGPIXELSX)
        lDPI(1) = GetDeviceCaps(lDC3, LOGPIXELSY)
        lDC3 = ReleaseDC(0, lDC3)
    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

I hope one of the administrators deletes the previous post to avoid confusion
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

Jaafar Tribak
  • Question Question
KeyPress Event for Worksheet Cells (Subclassing Without Crashing)
Replies
1
Views
396
Bib195
B
M
  • Question Question
Please help me to correct Excel VBA code!
Replies
1
Views
368
Minh Tuan VN
M
A
  • Question Question
Using Hittest with more than one Listview Control
Replies
0
Views
37
AlexanderBB
A
S
  • Solved
Hide userform title bar, and locking the userform into a relative position on the application.
2
Replies
16
Views
722
Jaafar Tribak
Jaafar Tribak
T
  • Solved
Chart point must move to point of click in chart
Replies
2
Views
709
tigger_na
T

Forum statistics

Threads
1,224,823
Messages
6,181,181
Members
453,022
Latest member
Mohamed Magdi Tawfiq Emam

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top