Highlighting the cell under the mouse pointer ( GDI based )

Jaafar Tribak

Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
9,779
Office Version
  1. 2016
Platform
  1. Windows
I wrote some code in the past that enables the user to highlight the cell currently under the mouse pointer ... See a code example here : https://www.mrexcel.com/forum/excel...s-selecting-cell-post5240255.html#post5240255

The code in the link works fine except that it clears the undo stack because it temporarly alters the cell interior color, font color etc ..

To fix this problem, I resorted to the GDI API functions to highlight the portion of the screen device context layer situated right above the cell without needing to change the cell color property thus keeping the Undo stack intact.

Here is a workbook example

I have written and tested the code in excel 2010 and all works as expected however I also tested the code on excel 2013 on another computer and the cell flashes and the highlight ends up vanishing so I have a request for users of excel 2013 and later versions : Can you please test the code and let me know if you experience the problem I described ?

Thank you.


1- Code in a Standard Module:
Code: 
Option Explicit

Public Enum FRAME_STYLE
    FOCUSED_NO_COLOR = 0
    ETCHED_NO_COLOR = 1
    STRAIGHT = 2
    DASH = 3
    DOT = 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 BITMAP
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
        bmBits As LongPtr
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
        bmBits As Long
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If
End Type

Private Type BITMAPINFOHEADER '40 bytes
        biSize As Long
        biWidth As Long
        biHeight As Long
        biPlanes As Integer
        biBitCount As Integer
        biCompression As Long
        biSizeImage As Long
        biXPelsPerMeter As Long
        biYPelsPerMeter As Long
        biClrUsed As Long
        biClrImportant As Long
End Type

Private Type RGBQUAD
        rgbBlue As Byte
        rgbGreen As Byte
        rgbRed As Byte
        rgbReserved As Byte
End Type

Private Type BITMAPINFO
        bmiHeader As BITMAPINFOHEADER
        bmiColors As RGBQUAD
End Type

Private Type BLENDFUNCTION
    BlendOp As Byte
    BlendFlags As Byte
    SourceConstantAlpha As Byte
    AlphaFormat As Byte
End Type

Private Type LOGBRUSH
    lbStyle As Long
    lbColor As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
    lbHatch As LongPtr
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
    lbHatch As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If
End Type

Private Type LOGPEN
    lopnStyle As Long
    lopnWidth As POINTAPI
    lopnColor As Long
End Type

Private Type RGB
    R As Long
    G As Long
    B As Long
End Type


[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then

    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As Long
    Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
    Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As LongPtr) As LongPtr
    Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hDC As LongPtr) As Long
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hDC As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare PtrSafe Function FillRect Lib "user32" (ByVal hDC As LongPtr, lpRect As RECT, ByVal hBrush As LongPtr) As Long
    Private Declare PtrSafe Function DrawEdge Lib "user32" (ByVal hDC As LongPtr, qrc As RECT, ByVal edge As Long, ByVal grfFlags As Long) As Long
    Private Declare PtrSafe Function DrawFocusRect Lib "user32" (ByVal hDC As LongPtr, lpRect As RECT) As Long
    Private 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
    Private Declare PtrSafe Function AlphaBlend Lib "msimg32.dll" (ByVal hDC As LongPtr, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal hDC As LongPtr, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal BLENDFUNCT As Long) As Long
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare PtrSafe Function RedrawWindow Lib "user32" (ByVal hwnd As LongPtr, lprcUpdate As RECT, ByVal hrgnUpdate As LongPtr, ByVal fuRedraw As Long) As Long
    Private Declare PtrSafe Function CreateBrushIndirect Lib "gdi32" (lpLogBrush As LOGBRUSH) As LongPtr
    Private 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
    Private Declare PtrSafe Function TransparentBlt Lib "msimg32.dll" (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 crTransparent As Long) As Boolean
    Private Declare PtrSafe Function GetDIBits Lib "gdi32" (ByVal aHDC As LongPtr, ByVal hBitmap As LongPtr, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
    Private Declare PtrSafe Function SetDIBitsToDevice Lib "gdi32" (ByVal hDC As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal dx As Long, ByVal dy As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal Scan As Long, ByVal NumScans As Long, Bits As Any, BitsInfo As BITMAPINFO, ByVal wUsage As Long) As Long
    Private Declare PtrSafe Function LineTo Lib "gdi32" (ByVal hDC As LongPtr, ByVal X As Long, ByVal Y As Long) As Long
    Private Declare PtrSafe Function MoveToEx Lib "gdi32" (ByVal hDC As LongPtr, ByVal X As Long, ByVal Y As Long, lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function CreatePenIndirect Lib "gdi32" (lpLogPen As LOGPEN) As LongPtr
    Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Private 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
    Private Declare PtrSafe Function GetClientRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function ClientToScreen Lib "user32" (ByVal hwnd As LongPtr, lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function GetRgnBox Lib "gdi32" (ByVal hRgn As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function CombineRgn Lib "gdi32" (ByVal hDestRgn As LongPtr, ByVal hSrcRgn1 As LongPtr, ByVal hSrcRgn2 As LongPtr, ByVal nCombineMode As Long) As Long
    Private Declare PtrSafe Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As LongPtr
    Private Declare PtrSafe Function RectInRegion Lib "gdi32" (ByVal hRgn As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function IsWindowVisible Lib "user32" (ByVal hwnd As LongPtr) As Long

[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
    
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Function GetActiveWindow Lib "user32" () 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 CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
    Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
    Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
    Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
    Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush 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 DrawFocusRect Lib "user32" (ByVal hdc As Long, lpRect As RECT) As Long
    Private 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
    Private Declare Function AlphaBlend Lib "msimg32.dll" (ByVal hdc As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal hdc As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal BLENDFUNCT As Long) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private Declare Function RedrawWindow Lib "user32" (ByVal hwnd As Long, lprcUpdate As RECT, ByVal hrgnUpdate As Long, ByVal fuRedraw As Long) As Long
    Private Declare Function CreateBrushIndirect Lib "gdi32" (lpLogBrush As LOGBRUSH) 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 TransparentBlt Lib "msimg32.dll" (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 crTransparent As Long) As Boolean
    Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
    Private Declare Function SetDIBitsToDevice Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal y As Long, ByVal dx As Long, ByVal dy As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal Scan As Long, ByVal NumScans As Long, Bits As Any, BitsInfo As BITMAPINFO, ByVal wUsage As Long) As Long
    Private Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal y As Long) As Long
    Private Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal y As Long, lpPoint As POINTAPI) As Long
    Private Declare Function CreatePenIndirect Lib "gdi32" (lpLogPen As LOGPEN) As Long
    Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) 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 GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
    Private Declare Function GetRgnBox Lib "gdi32" (ByVal hRgn As Long, lpRect As RECT) As Long
    Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
    Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
    Private Declare Function RectInRegion Lib "gdi32" (ByVal hRgn As Long, lpRect As RECT) As Long
    Private Declare Function IsWindowVisible Lib "user32" (ByVal hwnd As Long) As Long

[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If

Private Const EDGE_ETCHED = &H6
Private Const BF_RECT = &HF

Private Const RDW_INVALIDATE = &H1
Private Const RDW_ALLCHILDREN = &H80

Private Const AC_SRC_OVER = &H0
Private Const SRCCOPY = &HCC0020

Private Const DIB_RGB_COLORS = 0&
Private Const BI_RGB = 0&
Private Const CAPTUREBLT = &H40000000

Private Const SIMPLEREGION = 2
Private Const COMPLEXREGION = 3
Private Const RGN_AND = 1
Private Const RGN_OR = 2
Private Const RGN_DIFF = 4


Public Sub HighlightCellUsingAlphaBlendMethod(ByVal Cell As Range, ByVal Color As Long)
    Call AlphaBlendRoutine(Cell, Color)
End Sub


Public Sub HighlightCellUsingDIBitsMethod(ByVal Cell As Range, ByVal Color As Long)
    Call DIBitsRoutine(Cell, Color)
End Sub


Public Sub DeHighlightCell(ByVal Cell As Range)

    Dim tCellRect As RECT
    tCellRect = ObjRect(Cell)
    With tCellRect
        Call SetRect(tCellRect, .Left - 1, .Top - 1, .Right + 1, .Bottom + 1)
    End With
    RedrawWindow 0, tCellRect, 0, RDW_INVALIDATE + RDW_ALLCHILDREN
    DoEvents
End Sub


Public Sub DrawFrame(ByVal Cell As Range, ByVal FrameStyle As FRAME_STYLE, ByVal FrameColor As Long)

    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
        Dim hDC As LongPtr, hPen As LongPtr, hOldPen As LongPtr, hRgn As LongPtr, hCellRgn As LongPtr
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
        Dim hDC As Long, hPen As Long, hOldPen As Long, hRgn As Long, hCellRgn As Long
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If
    
    Dim tRangeRect As RECT, tRealVisibleRect As RECT, tFrameRect   As RECT, tPen As LOGPEN, tpt As POINTAPI
    Dim lLeft As Long, lTop As Long, lRight As Long, lBottom As Long
    Dim RgnType As Long
    
    hDC = GetDC(0)
    tRangeRect = ObjRect(Cell)
    tRealVisibleRect = GetRealVisibleRangeRectPix
    
    With tRealVisibleRect
        hRgn = CreateRectRgn(.Left, .Top, .Right, .Bottom)
    End With
    
    With tRangeRect
        hCellRgn = CreateRectRgn(.Left, .Top, .Right, .Bottom)
    End With
    
    Call CombineRgn(hRgn, hRgn, hCellRgn, RGN_AND)
    Call GetRgnBox(hRgn, tFrameRect)
    
    With tFrameRect
        lLeft = .Left: lTop = .Top
        lRight = .Right:     lBottom = .Bottom
    End With
    
    Call ShapeOverlapsCell(tFrameRect, RgnType)
    
    If (tFrameRect.Left <> 0 And tFrameRect.Right <> 0) Then
        If FrameStyle = ETCHED_NO_COLOR Then
            Call DrawEdge(hDC, tFrameRect, EDGE_ETCHED, BF_RECT): GoTo Xit
        End If
        If FrameStyle = FOCUSED_NO_COLOR Then
            Call DrawFocusRect(hDC, tFrameRect): GoTo Xit
        End If
    Else
        GoTo Xit
    End If
    
    If RgnType = SIMPLEREGION Then
        With tFrameRect
            lLeft = .Left: lTop = .Top
            lRight = .Right:     lBottom = .Bottom
        End With
    End If
    
     With tPen
        .lopnColor = FrameColor
        .lopnStyle = FrameStyle - 2
        .lopnWidth.X = 1
        .lopnWidth.Y = 1
    End With
    
    hPen = CreatePenIndirect(tPen)
    hOldPen = SelectObject(hDC, hPen)
    
    Call MoveToEx(hDC, lLeft, lTop, tpt)
    Call LineTo(hDC, lRight, lTop)
    
    Call MoveToEx(hDC, lRight, lTop, tpt)
    Call LineTo(hDC, lRight, lBottom)
    
    Call MoveToEx(hDC, lRight, lBottom, tpt)
    Call LineTo(hDC, lLeft, lBottom)
    
    Call MoveToEx(hDC, lLeft, lBottom, tpt)
    Call LineTo(hDC, lLeft, lTop)
    
    Call SelectObject(hDC, hOldPen)
    
Xit:
    Call ReleaseDC(0, hDC)
    Call DeleteObject(hPen)
    Call DeleteObject(hOldPen)
    Call DeleteObject(hRgn)
    Call DeleteObject(hCellRgn)

End Sub
   
Public Sub GetCurPos(ByRef X As Long, ByRef Y As Long)
    Dim tpt As POINTAPI
    GetCursorPos tpt
    X = tpt.X: Y = tpt.Y
End Sub


 [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
    Public Function GetTheActiveWindow() As LongPtr
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
    Public Function GetTheActiveWindow() As Long
 [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If
        GetTheActiveWindow = GetActiveWindow
End Function



'**************************************************************************
'                                                       PRIVATE  ROUTINES
'**************************************************************************


Private Sub AlphaBlendRoutine(ByVal Cell As Range, ByVal Color As Long)
  
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
        Dim hDC As LongPtr, hMemDc As LongPtr, hMemBmp As LongPtr, hOldBmp As LongPtr, hCellRgn As LongPtr, hRgn As LongPtr, hBrush As LongPtr
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
        Dim hDC As Long, hMemDc As Long, hMemBmp As Long, hOldBmp As Long, hCellRgn As Long, hRgn As Long, hBrush As Long
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If
    
    Dim tBF As BLENDFUNCTION, lBF As Long
    Dim tFill As LOGBRUSH, tRangeRect As RECT, tRealRect As RECT, tRgnRect As RECT
    Dim lLeft As Long, lTop As Long, lRight As Long, lBottom As Long, RgnType As Long

    tRangeRect = ObjRect(Cell)
    hDC = GetDC(0)
    hMemDc = CreateCompatibleDC(hDC)
    tRealRect = GetRealVisibleRangeRectPix

    With tRealRect
        hRgn = CreateRectRgn(.Left, .Top, .Right, .Bottom)
    End With
    
    With tRangeRect
        hCellRgn = CreateRectRgn(.Left, .Top, .Right, .Bottom)
    End With

    Call CombineRgn(hRgn, hRgn, hCellRgn, RGN_AND)
    Call GetRgnBox(hRgn, tRgnRect)
    
    With tRgnRect
        lLeft = .Left: lTop = .Top
        lRight = .Right:     lBottom = .Bottom
    End With
'
    Call ShapeOverlapsCell(tRgnRect, RgnType)
        
    With tRgnRect
        lLeft = .Left: lTop = .Top
        lRight = .Right:     lBottom = .Bottom
    End With
    
    hMemBmp = CreateCompatibleBitmap(hDC, lRight - lLeft, lBottom - lTop)
    hOldBmp = SelectObject(hMemDc, hMemBmp)
    Call SetRect(tRgnRect, 0, 0, lRight - lLeft, lBottom - lTop)
    tFill.lbColor = Color
    hBrush = CreateBrushIndirect(tFill)
    Call FillRect(hMemDc, tRgnRect, hBrush)
    
    With tBF
        .BlendOp = AC_SRC_OVER
        .BlendFlags = 0
        .SourceConstantAlpha = 50
        .AlphaFormat = 0
    End With
    
    Call CopyMemory(lBF, tBF, LenB(lBF))
    Call AlphaBlend(hDC, lLeft, lTop, lRight - lLeft, lBottom - lTop, hMemDc, 0, 0, lRight - lLeft, lBottom - lTop, lBF)
    Call SelectObject(hMemDc, hOldBmp)

    Call ReleaseDC(0, hDC)
    Call DeleteDC(hMemDc)
    Call DeleteObject(hMemBmp)
    Call DeleteObject(hBrush)
    Call DeleteObject(hOldBmp)
    Call DeleteObject(hCellRgn)
    Call DeleteObject(hRgn)

End Sub


Private Sub DIBitsRoutine(ByVal Cell As Range, ByVal Color As Long)

    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
        Dim hDC As LongPtr, hMemDc As LongPtr, hMemBmp As LongPtr, hOldBmp As LongPtr, hCellRgn As LongPtr, hRgn As LongPtr
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
        Dim hDC As Long, hMemDc As Long, hMemBmp As Long, hOldBmp As Long, hCellRgn As Long, hRgn As Long
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If
    
    Dim tRangeRect As RECT, tRealRect As RECT, tRgnRect   As RECT, tBMInfo As BITMAPINFO, tPixels() As RGBQUAD
    Dim X As Currency, Y As Currency, lCellColor As Long
    Dim lLeft As Long, lTop As Long, lRight As Long, lBottom As Long

    lCellColor = Cell.Interior.Color
    tRangeRect = ObjRect(Cell)
    hDC = GetDC(0)
    hMemDc = CreateCompatibleDC(hDC)
    tRealRect = GetRealVisibleRangeRectPix

    With tRealRect
        hRgn = CreateRectRgn(.Left, .Top, .Right, .Bottom)
    End With
    
    With tRangeRect
        hCellRgn = CreateRectRgn(.Left, .Top, .Right, .Bottom)
    End With

    Call CombineRgn(hRgn, hRgn, hCellRgn, RGN_AND)
    Call GetRgnBox(hRgn, tRgnRect)

    With tRgnRect
        lLeft = .Left: lTop = .Top
        lRight = .Right:     lBottom = .Bottom
    End With
        
        hMemBmp = CreateCompatibleBitmap(hDC, lRight - lLeft, lBottom - lTop)
        hOldBmp = SelectObject(hMemDc, hMemBmp)
        Call BitBlt(hMemDc, 0, 0, lRight - lLeft, lBottom - lTop, hDC, lLeft, lTop, SRCCOPY Or CAPTUREBLT)
        tBMInfo.bmiHeader.biSize = LenB(tBMInfo.bmiHeader)
        Call GetDIBits(hMemDc, hMemBmp, 0, 0, 0, tBMInfo, DIB_RGB_COLORS)
        ReDim tPixels(tBMInfo.bmiHeader.biWidth, tBMInfo.bmiHeader.biHeight)
        tBMInfo.bmiHeader.biCompression = BI_RGB
        Call GetDIBits(hMemDc, hMemBmp, 0, tBMInfo.bmiHeader.biHeight, tPixels(1, 1), tBMInfo, DIB_RGB_COLORS)
        Call SelectObject(hMemDc, hOldBmp)
        
        For X = 0 To tBMInfo.bmiHeader.biWidth
            For Y = 0 To tBMInfo.bmiHeader.biHeight
                If tPixels(X, Y).rgbRed = ColorToRGB(lCellColor).R And _
                tPixels(X, Y).rgbGreen = ColorToRGB(lCellColor).G And _
                tPixels(X, Y).rgbBlue = ColorToRGB(lCellColor).B Then
                    tPixels(X, Y).rgbRed = ColorToRGB(Color).R:  tPixels(X, Y).rgbGreen = ColorToRGB(Color).G:  tPixels(X, Y).rgbBlue = ColorToRGB(Color).B
                End If
            Next Y
        Next X


        Call SetDIBitsToDevice(hDC, lLeft, lTop, tBMInfo.bmiHeader.biWidth, tBMInfo.bmiHeader.biHeight, 0, 0, 0, tBMInfo.bmiHeader.biHeight, tPixels(1, 1), tBMInfo, DIB_RGB_COLORS)
    
    Call ReleaseDC(0, hDC)
    Call DeleteDC(hMemDc)
    Call DeleteObject(hMemBmp)
    Call DeleteObject(hOldBmp)
    Call DeleteObject(hCellRgn)
    Call DeleteObject(hRgn)

End Sub


Private Function ShapeOverlapsCell(ByRef HighlightRect As RECT, ByRef RGN_ERR As Long) As Boolean

    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
        Dim hShapeRgn As LongPtr, hHighlightRgn As LongPtr, hDestRgn As LongPtr
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
        Dim hShapeRgn As Long, hHighlightRgn As Long, hDestRgn As Long
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If
    
    Dim tTempRect As RECT, lCounter As Long


    For lCounter = 1 To ActiveSheet.Shapes.Count
        If ActiveSheet.Shapes(lCounter).FormControlType <> xlGroupBox Then
            tTempRect = ObjRect(ActiveSheet.Shapes(lCounter))
            If hDestRgn = 0 Then
                hDestRgn = CreateRectRgn(tTempRect.Left, tTempRect.Top, tTempRect.Right, tTempRect.Bottom)
            End If
            hShapeRgn = CreateRectRgn(tTempRect.Left, tTempRect.Top, tTempRect.Right, tTempRect.Bottom)
            Call CombineRgn(hDestRgn, hDestRgn, hShapeRgn, RGN_OR)
        End If
    Next lCounter
    
    If RectInRegion(hDestRgn, HighlightRect) Then
        hHighlightRgn = CreateRectRgn(HighlightRect.Left, HighlightRect.Top, HighlightRect.Right, HighlightRect.Bottom)
        RGN_ERR = CombineRgn(hHighlightRgn, hHighlightRgn, hDestRgn, RGN_DIFF)
        If RGN_ERR = COMPLEXREGION Then
            With HighlightRect
                .Left = 0:  .Top = 0:   .Right = 0:   .Bottom = 0
            End With
        Else
            GetRgnBox hHighlightRgn, HighlightRect
        End If
        ShapeOverlapsCell = True
    End If
    
    DeleteObject hHighlightRgn
    DeleteObject hShapeRgn
    DeleteObject hDestRgn

End Function


Private Function GetRealVisibleRangeRectPix() As RECT

    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
        Static hWbk As LongPtr
        Dim hDesk As LongPtr, hVert As LongPtr, hHoriz As LongPtr
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
        Static hWbk As Long
        Dim hDesk As Long, hVert As Long, hHoriz As Long
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If
    
    Dim tDeskRect As RECT, WrkbookRect As RECT, VerRect As RECT, HorizRect As RECT, tPt1 As POINTAPI, tpt2 As POINTAPI


    hDesk = FindWindowEx(Application.hwnd, 0, "XLDESK", vbNullString)
    Call GetWindowRect(hDesk, tDeskRect)
    If hWbk = 0 Then hWbk = GetThisWorkbookHwnd
    
    Call GetClientRect(hWbk, WrkbookRect)
    tPt1.X = WrkbookRect.Left: tPt1.Y = WrkbookRect.Top
    tpt2.X = WrkbookRect.Right: tpt2.Y = WrkbookRect.Bottom
    Call ClientToScreen(hWbk, tPt1)
    Call ClientToScreen(hWbk, tpt2)
    WrkbookRect.Left = tPt1.X: WrkbookRect.Top = tPt1.Y
    WrkbookRect.Right = tpt2.X: WrkbookRect.Bottom = tpt2.Y
     hVert = FindWindowEx(hWbk, 0, "NUIScrollbar", "Vertical")
     hHoriz = FindWindowEx(hWbk, 0, "NUIScrollbar", "Horizontal")
    If IsWindowVisible(hHoriz) Or ThisWorkbook.Windows(1).DisplayWorkbookTabs Then
        Call GetWindowRect(hHoriz, HorizRect)
    End If
    If IsWindowVisible(hVert) Then
        Call GetWindowRect(hVert, VerRect)
    End If
    
    With Application.ActiveWindow
        GetRealVisibleRangeRectPix.Left = Application.Max(.ActivePane.PointsToScreenPixelsX(.VisibleRange.Cells(1, 1).Left) + (.Zoom / 100), tDeskRect.Left)
        GetRealVisibleRangeRectPix.Top = Application.Max(.ActivePane.PointsToScreenPixelsY(.VisibleRange.Cells(1, 1).Top) + (.Zoom / 100), tDeskRect.Top)
        GetRealVisibleRangeRectPix.Right = Application.Min(WrkbookRect.Right - (VerRect.Right - VerRect.Left), tDeskRect.Right)
        GetRealVisibleRangeRectPix.Bottom = Application.Min(WrkbookRect.Bottom - (HorizRect.Bottom - HorizRect.Top), tDeskRect.Bottom)
    End With

End Function
    
    
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
    Private Function GetThisWorkbookHwnd() As LongPtr
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
    Private Function GetThisWorkbookHwnd() As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If

    Dim sCaption As String
    
    On Error GoTo Xit
    sCaption = ThisWorkbook.Windows(1).Caption
    ThisWorkbook.Windows(1).Caption = "@@{}@@"
    GetThisWorkbookHwnd = FindWindowEx(FindWindowEx(Application.hwnd, 0, "XLDESK", vbNullString), 0, "EXCEL7", "@@{}@@")
Xit:
    ThisWorkbook.Windows(1).Caption = sCaption

End Function


Private Function ColorToRGB(ByVal Col As Long) As RGB
    ColorToRGB.R = &HFF& And Col
    ColorToRGB.G = (&HFF00& And Col) \ 256
    ColorToRGB.B = (&HFF0000 And Col) \ 65536
End Function


Private Function ObjRect(ByVal Obj As Object) As RECT

    Dim oPane  As Pane
    Set oPane = ThisWorkbook.Windows(1).ActivePane
    
    With Obj
        ObjRect.Left = oPane.PointsToScreenPixelsX(.Left - 1)
        ObjRect.Top = oPane.PointsToScreenPixelsY(.Top - 1)
        ObjRect.Right = oPane.PointsToScreenPixelsX(.Left + .Width)
        ObjRect.Bottom = oPane.PointsToScreenPixelsY(.Top + .Height)
    End With

End Function



'I chose not to use this Approach because the 'TransparentBlt' API causes memory leaks.
'======================================================================
'Private Sub TransparentBltRoutine(ByVal Cell As Range, ByVal Color As Long)
'
'    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
'        Dim hdc As LongPtr, hMemDc As LongPtr, hMemBmp As LongPtr, hMemDc2 As LongPtr, hMemBmp2 As LongPtr, hBrush As LongPtr, hOldBmp As LongPtr, hOldBmp2 As LongPtr
'    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
'        Dim hdc As Long, hMemDc As Long, hMemBmp As Long, hMemDc2 As Long, hMemBmp2 As Long, hBrush As Long, hOldBmp As Long, hOldBmp2 As Long
'    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If
'
'    Dim tRangeRect As RECT, tRealRect As RECT, tMemRect As RECT, tMemRect2 As RECT, tFill As LOGBRUSH
'    Dim lLeft As Long, lTop As Long, lRight As Long, lBottom As Long, lCellColor As Long
'
'    lCellColor = Cell.Interior.Color
'    tRangeRect = ObjRect(Cell)
'    hdc = GetDC(0)
'
'    With tRangeRect
'        hMemDc = CreateCompatibleDC(hdc)
'        hMemBmp = CreateCompatibleBitmap(hdc, .Right - .Left, .Bottom - .Top)
'        hOldBmp = SelectObject(hMemDc, hMemBmp)
'        hMemDc2 = CreateCompatibleDC(hdc)
'        hMemBmp2 = CreateCompatibleBitmap(hdc, .Right - .Left, .Bottom - .Top)
'        hOldBmp2 = SelectObject(hMemDc2, hMemBmp2)
'        Call SetRect(tMemRect, 0, 0, .Right - .Left, .Bottom - .Top)
'        Call SetRect(tMemRect2, 0, 0, .Right - .Left, .Bottom - .Top)
'        tFill.lbColor = Color
'        hBrush = CreateBrushIndirect(tFill)
'        Call FillRect(hMemDc2, tMemRect2, hBrush)
'        Call BitBlt(hMemDc, 0, 0, .Right - .Left, .Bottom - .Top, hdc, .Left, .Top, SRCCOPY)
'        Call TransparentBlt(hMemDc2, 0, 0, .Right - .Left, .Bottom - .Top, hMemDc, 0, 0, .Right - .Left, .Bottom - .Top, lCellColor)
'        Call SelectObject(hMemDc, hOldBmp)
'        tRealRect = GetRealVisibleRangeRectPix
'        lLeft = Application.Min(.Left, tRealRect.Right): lTop = Application.Min(.Top, tRealRect.Bottom)
'        lRight = Application.Min(.Right, tRealRect.Right): lBottom = Application.Min(.Bottom, tRealRect.Bottom)
'    End With
'
'    BitBlt hdc, lLeft, lTop, lRight - lLeft, lBottom - lTop, hMemDc2, 0, 0, SRCCOPY
'    Call SelectObject(hMemDc2, hOldBmp2)
'
'    Call ReleaseDC(0, hdc)
'    Call DeleteDC(hMemDc)
'    Call DeleteDC(hMemDc2)
'    Call DeleteObject(hMemBmp)
'    Call DeleteObject(hMemBmp2)
'    Call DeleteObject(hOldBmp)
'    Call DeleteObject(hOldBmp2)
'    Call DeleteObject(hBrush)
'
'End Sub


2- Code in a Class Module : ( Calss name: HighlightClass)
Code: 
Option Explicit

Private WithEvents Cmbrs As CommandBars
Private WithEvents Wbevents As Workbook


Public Sub Start()
    Set Cmbrs = Application.CommandBars
    Set Wbevents = ThisWorkbook
    Call Cmbrs_OnUpdate
End Sub


Public Sub Finish()
    Call ThisWorkbook.OnCellMouseMove(Nothing)
    Set Cmbrs = Nothing
    Set Wbevents = Nothing
End Sub


Private Sub wbevents_Activate()
    Call Me.Start
End Sub

Private Sub Wbevents_Deactivate()
    Call Me.Finish
End Sub


Private Sub Wbevents_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    Call Me.Start
End Sub


Private Sub Cmbrs_OnUpdate()

    Static oPrevCell As Range
    Dim oCurCell  As Range
    Dim X As Long, Y As Long

    On Error Resume Next

    Application.CommandBars.FindControl(ID:=2040).Enabled = Not Application.CommandBars.FindControl(ID:=2040).Enabled

    If GetTheActiveWindow <> Application.hwnd Then
        Exit Sub
    End If

    GetCurPos X, Y

    Set oCurCell = ActiveWindow.RangeFromPoint(X, Y)

    If TypeName(oCurCell) = "Range" Then
        If oPrevCell.Address <> oCurCell.Address Then
            Set oPrevCell = oCurCell
            Call ThisWorkbook.OnCellMouseMove(oCurCell)
        End If
    Else
        Call DeHighlightCell(oPrevCell)
    End If 

End Sub


3- Code in the ThisWorkbook Module:
Code: 
Option Explicit

Private oHighlightInstance As HighlightClass

Public Sub StartMacro()
    If oHighlightInstance Is Nothing Then
        Set oHighlightInstance = New HighlightClass
        oHighlightInstance.Start
    End If
End Sub


Public Sub StopMacro()
    If Not oHighlightInstance Is Nothing Then
        oHighlightInstance.Finish
        Set oHighlightInstance = Nothing
    End If
End Sub



[B][COLOR=#008000]'**********************************************************
'                 PSEUDO-EVENT
'**********************************************************[/COLOR][/B]

Public Sub OnCellMouseMove(ByVal CellUnderMousePointer As Range)

    Static oPrevCell As Range
    Dim lDrawMethod As Long
    Dim lFrame As Long


    lDrawMethod = 1 [COLOR=#008000]' set to 2 for AlphaBlending or 0 for NoDrawing.[/COLOR]
    lFrame = 1 [COLOR=#008000]' set to 0 for NoFrame.[/COLOR]

    If oPrevCell Is Nothing Then Set oPrevCell = ActiveCell
    If CellUnderMousePointer Is Nothing Then Call DeHighlightCell(oPrevCell): Exit Sub

    [COLOR=#008000]'Apply to Sheet1 only - comment out this line to apply to all sheets.[/COLOR]
    If CellUnderMousePointer.Parent.Name <> "Sheet1" Then Exit Sub

    If Not CellUnderMousePointer Is Nothing Then
        Call DeHighlightCell(oPrevCell)
        Set oPrevCell = CellUnderMousePointer
        If lDrawMethod = 1 Then
            Call HighlightCellUsingDIBitsMethod(CellUnderMousePointer, vbYellow)
        ElseIf lDrawMethod = 2 Then
            Call HighlightCellUsingAlphaBlendMethod(CellUnderMousePointer, vbYellow)
        End If
        If lFrame = 1 Then
            Call DrawFrame(CellUnderMousePointer, DOT, vbRed)
        End If
    End If

End Sub
 
Last edited:

Excel Facts

Which lookup functions find a value equal or greater than the lookup value?
MATCH uses -1 to find larger value (lookup table must be sorted ZA). XLOOKUP uses 1 to find values greater and does not need to be sorted.
Sort by date Sort by votes
I used the code on my 365 version 1808 and i get a yellow interior colour and red dashed line border for about half a second upon hovering over a cell which then disappears.
 
Upvote 0
steve the fish said:
I used the code on my 365 version 1808 and i get a yellow interior colour and red dashed line border for about half a second upon hovering over a cell which then disappears.
Click to expand...

Thanks for the feedback .

For some strange reason , the code works fine on all versions of excel prior to excel 2013 ... It looks as if excel 2013 (and 365 version as you mentioned) somehow affects the screen device context so it doesn't accept persistent painting on it.

I have googled this issue but nothing comes up !
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Question Question
Please help me to correct Excel VBA code!
Replies
1
Views
307
Minh Tuan VN
M
Jaafar Tribak
  • Question Question
KeyPress Event for Worksheet Cells (Subclassing Without Crashing)
Replies
0
Views
165
Jaafar Tribak
Jaafar Tribak
Jaafar Tribak
  • Question Question
Capturing the Paste Event (API Hooking - Redirection)
Replies
4
Views
747
Jaafar Tribak
Jaafar Tribak
H
  • Solved
Catching the Mouse Click Error in Modal User Form
Replies
4
Views
743
huiettcm
H
T
  • Solved
Chart point must move to point of click in chart
Replies
2
Views
587
tigger_na
T

Forum statistics

Threads
1,223,214
Messages
6,170,771
Members
452,353
Latest member
strainu

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