A Hack to alternate the Colours of Row/Column Headears !!

[Jaafar Tribak]

Greetings all,

As the title implies this is a hack that i have been experimenting with to colour format the headings of a worksheet. It uses a running timer to ensure the colours of the headings are refreshed should the excel screen be repainted for whatever reason.

here is a workbook demo.

I first tried subclassing the workbook window for doing this in order to avoid the performance hit associated with the use of a timer but it froze the excel app on some systems.

At the moment, the code works only for a zoom set to 100. I 'll see if i can expand this so it works regardless of the window zoom.

Anyway, here is the code that goes in a standard module. ( run the SetHeadingColors routine )

Option Explicit
 
Private Type RGB
    R As Byte
    G As Byte
    B As Byte
End Type
 
Private Type Metrics
    Wdt As Double
    Hgt As Double
End Type
 
Private Type RECT
    Left As Double
    Top As Double
    Right As Double
    Bottom As Double
End Type
 
Private Type SAFEARRAYBOUND
    cElements As Long
    lLbound As Long
End Type
 
Private Type SAFEARRAY2D
    cDims As Integer
    fFeatures As Integer
    cbElements As Long
    cLocks As Long
    pvData As Long
    Bounds(0 To 1) As SAFEARRAYBOUND
End Type
 
Private Type BLENDFUNCTION
    BlendOp As Byte
    BlendFlags As Byte
    SourceConstantAlpha As Byte
    AlphaFormat As Byte
End Type
 
Private Type MEMORYBITMAP
    hdc As Long
    hBM As Long
    oldhdc As Long
    lft As Long
    tp As Long
    wid As Long
    Hgt As Long
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 Declare Sub CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" _
(Destination As Any, _
Source As Any, _
ByVal Length As Long)
 
Private Declare Function VarPtrArray Lib "msvbvm50.dll" _
Alias "VarPtr" _
(Ptr() As Any) As Long
 
Private Declare Function FindWindow Lib "user32" _
Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) 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 CreateCompatibleDC Lib "gdi32" _
(ByVal hdc 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 GetDeviceCaps Lib "gdi32" _
(ByVal hdc As Long, _
ByVal nIndex 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 GetPixel Lib "gdi32" _
(ByVal hdc As Long, _
ByVal x As Long, _
ByVal y As Long) As Long
 
Private Declare Function WindowFromPoint Lib "user32" _
(ByVal xPoint As Long, _
ByVal yPoint As Long) As Long
 
 
Private Declare Function CreateDIBSection Lib "gdi32" _
(ByVal hdc As Long, _
pBitmapInfo As BITMAPINFO, _
ByVal un As Long, _
lplpVoid As Long, _
ByVal handle As Long, _
ByVal dw 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 InvalidateRect Lib "user32" _
(ByVal hwnd As Long, _
 lpRect As Long, _
ByVal bErase 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 Function IsWindowEnabled Lib "user32" _
(ByVal hwnd As Long) As Long

Private Declare Function SetTimer Lib "user32" _
(ByVal hwnd As Long, _
ByVal nIDEvent As Long, _
ByVal uElapse As Long, _
ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" _
(ByVal hwnd As Long, _
ByVal nIDEvent As Long) As Long

Private Const BI_RGB         As Long = 0&
Private Const DIB_RGB_COLORS As Long = 0
Private Const AC_SRC_OVER    As Long = &H0
Private Const LOGPIXELSX     As Long = 88
Private Const LOGPIXELSY     As Long = 90
Private Const PointsPerInch  As Long = 72

Private lXLAPPhwnd           As Long
Private lEXCEL7              As Long
Private lTimerID             As Long
Private lPxColorX1           As Long
Private lPxColorX2           As Long
Private lPxColorY1           As Long
Private lPxColorY2           As Long
Private dShtStandardHeight   As Double
Private dShtStandardWidth    As Double

Sub SetHeadingColors()
    
    Const TIMER_TIMEOUT As Long = 100
    Dim lXLDESK As Long
    
   [COLOR=seagreen] 'store the xl main and wkbk wnd hwnds
    'in module level vars for later use.
[/COLOR]    lXLAPPhwnd = FindWindow("XLMAIN", Application.Caption)
    lXLDESK = FindWindowEx _
    (lXLAPPhwnd, ByVal 0&, "XLDESK", vbNullString)
    lEXCEL7 = FindWindowEx _
    (lXLDESK, ByVal 0&, "EXCEL7", vbNullString)
    
    [COLOR=seagreen]'store the curr wsht StandardHeight/Width props
    'in module level vars for later use.
[/COLOR]    dShtStandardHeight = ActiveSheet.StandardHeight
    dShtStandardWidth = ActiveSheet.StandardWidth
    
    [COLOR=seagreen]'start a timer for periodic painting of the wnd headings.
[/COLOR]    If lTimerID = 0 Then
        lTimerID = SetTimer(0, 0, TIMER_TIMEOUT, AddressOf TimerProc)
    End If
    
End Sub

Sub RemoveHeadingColors()
 
    [COLOR=seagreen]'cleanup.
[/COLOR]    KillTimer 0, lTimerID
    lTimerID = 0
    InvalidateRect 0, 0, 0
 
End Sub

Private Sub TimerProc _
(ByVal hwnd As Long, ByVal nIDEvent As Long, _
ByVal uElapse As Long, ByVal lpTimerFunc As Long)
 
    Static bXLwasDisabled        As Boolean
    Static dPrevZoom             As Double
    Dim dCurZoom                 As Double
    Dim BF As BLENDFUNCTION, lBF As Long
    Dim lDC                      As Long
    Dim i                        As Long
    Dim lMembpX1                 As MEMORYBITMAP
    Dim lMembpX2                 As MEMORYBITMAP
    Dim lMembpY1                 As MEMORYBITMAP
    Dim lMembpY2                 As MEMORYBITMAP
    Dim tColorX1                 As RGB
    Dim tColorX2                 As RGB
    
    
    On Error Resume Next
    
    
    [COLOR=seagreen]'skip the timer procedure if the main[/COLOR]
   [COLOR=seagreen] 'excel window is in the background.
[/COLOR]    If IsWindowEnabled(lXLAPPhwnd) <> 1 Then
        bXLwasDisabled = True
        Exit Sub
   [COLOR=seagreen] 'if the excel main window is reenabled[/COLOR]
    [COLOR=seagreen]'refresh the entire screen.
[/COLOR]    ElseIf bXLwasDisabled Then
        bXLwasDisabled = False
        InvalidateRect 0, 0, 0
    End If
    
    [COLOR=seagreen]'make sure headings are displayed.[/COLOR]
    If Not ActiveWindow.DisplayHeadings Then
    ActiveWindow.DisplayHeadings = True: End If
    
    [COLOR=seagreen]'Ensure wnd zooming is @ 100.
[/COLOR]    If ActiveWindow.Zoom <> 100 Then
        InvalidateRect 0, 0, 0
        ActiveWindow.Zoom = 100
[COLOR=seagreen]'        dPrevZoom = ActiveWindow.Zoom
'        Exit Sub
[/COLOR]    End If
    
    [COLOR=seagreen]'get current zoom factor.[/COLOR]
    dCurZoom = (ActiveWindow.Zoom / 100)
  
    [COLOR=seagreen]'set the headings colors.
[/COLOR]    With tColorX1
        .R = 0
        .G = 255
        .B = 0
    End With
    
    With tColorX2
        .R = 255
        .G = 0
        .B = 0
    End With
    
   [COLOR=seagreen] 'fill the BF structure.
[/COLOR]    With BF
        .BlendOp = AC_SRC_OVER
        .BlendFlags = 0
        .SourceConstantAlpha = 120
        .AlphaFormat = 0
    End With
    CopyMemory lBF, BF, 4
    
    
   [COLOR=seagreen] 'this is the meat of the code.
    'loop tru all hor and ver headings of the
    'current window and set their colors.[/COLOR]
[COLOR=seagreen]    '----------- column headings ---------------------[/COLOR]
    For i = 1 To ActiveWindow.VisibleRange.Columns.Count - 1
        Select Case True
            Case ActiveWindow.VisibleRange.Columns(i).Column Mod 2 = 0
                With GetRangeRect _
                (ActiveWindow.VisibleRange.Cells(1, i))
                    lDC = GetDC(0)
                    If GetPixel(lDC, .Left, _
                    .Top - (GetHeadingMetrics.Hgt) / 2) _
                    <> lPxColorX1 And _
                    ActiveCell.Column <> _
                    ActiveWindow.VisibleRange.Cells(1, i).Column And _
                    WindowFromPoint(.Left, .Top) = lEXCEL7 Then
                        lMembpX1 = MakeMemoryBitmap _
                        (.Right - .Left, _
                        (GetHeadingMetrics.Hgt), tColorX1)
                        AlphaBlend _
                        lDC, .Left, _
                        .Top - (GetHeadingMetrics.Hgt), _
                        .Right - .Left, GetHeadingMetrics.Hgt, _
                        lMembpX1.hdc, 0, 0, .Right - .Left, _
                        GetHeadingMetrics.Hgt, (lBF)
                        If lPxColorX1 = 0 Then
                            With GetRangeRect _
                            (ActiveWindow.VisibleRange.Cells(1, i))
                                lPxColorX1 = GetPixel _
                                (lDC, .Left, .Top - _
                                (GetHeadingMetrics.Hgt / 2))
                            End With
                        End If
                    End If
                    ReleaseDC 0, lDC
                End With
            Case Else
                With GetRangeRect _
                (ActiveWindow.VisibleRange.Cells(1, i))
                    lDC = GetDC(0)
                    If GetPixel(lDC, .Left, _
                    .Top - (GetHeadingMetrics.Hgt / 2)) _
                    <> lPxColorX2 And _
                    ActiveCell.Column <> _
                    ActiveWindow.VisibleRange.Cells(1, i).Column And _
                    WindowFromPoint(.Left, .Top) = lEXCEL7 Then
                        lMembpX2 = MakeMemoryBitmap _
                        (.Right - .Left, _
                        GetHeadingMetrics.Hgt, tColorX2)
                        AlphaBlend _
                        lDC, .Left, _
                        .Top - (GetHeadingMetrics.Hgt), _
                        .Right - .Left, GetHeadingMetrics.Hgt, _
                        lMembpX2.hdc, 0, 0, .Right - .Left, _
                        GetHeadingMetrics.Hgt, (lBF)
                        If lPxColorX2 = 0 Then
                            With GetRangeRect _
                            (ActiveWindow.VisibleRange.Cells(1, i))
                                lPxColorX2 = GetPixel _
                                (lDC, .Left, .Top - _
                                (GetHeadingMetrics.Hgt / 2))
                            End With
                        End If
                    End If
                    ReleaseDC 0, lDC
                End With
        End Select
    Next
        
   [COLOR=seagreen] '------------- row headings ----------------------
[/COLOR]    
    For i = 1 To ActiveWindow.VisibleRange.Rows.Count - 1
        Select Case True
            Case ActiveWindow.VisibleRange.Rows(i).Row Mod 2 = 0
                With GetRangeRect _
                (ActiveWindow.VisibleRange.Cells(i, 1))
                    lDC = GetDC(0)
                    If GetPixel _
                    (lDC, .Left - (GetHeadingMetrics.Wdt), _
                    .Top) <> lPxColorY1 And _
                    ActiveCell.Row <> _
                    ActiveWindow.VisibleRange.Cells(i, 1).Row And _
                    WindowFromPoint(.Left, .Top) = lEXCEL7 Then
                        lMembpY1 = MakeMemoryBitmap _
                        ((GetHeadingMetrics.Wdt * 2), _
                        .Bottom - .Top, tColorX1)
                        AlphaBlend _
                        lDC, .Left - (GetHeadingMetrics.Wdt * 2), _
                        .Top, GetHeadingMetrics.Wdt * 2, .Bottom - .Top, _
                        lMembpY1.hdc, 0, 0, GetHeadingMetrics.Wdt * 2, _
                        .Bottom - .Top, (lBF)
                        If lPxColorY1 = 0 Then
                            With GetRangeRect _
                            (ActiveWindow.VisibleRange.Cells(i, 1))
                                lPxColorY1 = _
                                GetPixel _
                                (lDC, .Left - (GetHeadingMetrics.Wdt), .Top)
                            End With
                        End If
                    End If
                    ReleaseDC 0, lDC
                End With
        Case Else
            With GetRangeRect(ActiveWindow.VisibleRange.Cells(i, 1))
                lDC = GetDC(0)
                If GetPixel(lDC, .Left - (GetHeadingMetrics.Wdt), .Top) _
                <> lPxColorY2 And _
                ActiveCell.Row <> _
                ActiveWindow.VisibleRange.Cells(i, 1).Row And _
                WindowFromPoint(.Left, .Top) = lEXCEL7 Then
                    lMembpY2 = MakeMemoryBitmap _
                    ((GetHeadingMetrics.Wdt * 2), _
                    .Bottom - .Top, tColorX2)
                    AlphaBlend _
                    lDC, .Left - (GetHeadingMetrics.Wdt * 2), _
                    .Top, GetHeadingMetrics.Wdt * 2, .Bottom - .Top, _
                    lMembpY2.hdc, 0, 0, _
                    GetHeadingMetrics.Wdt, .Bottom - .Top, (lBF)
                    If lPxColorY2 = 0 Then
                        With GetRangeRect _
                        (ActiveWindow.VisibleRange.Cells(i, 1))
                            lPxColorY2 = GetPixel _
                            (lDC, .Left - (GetHeadingMetrics.Wdt), .Top)
                        End With
                    End If
                End If
                ReleaseDC 0, lDC
            End With
        End Select
    Next
End Sub

Private Function GetHeadingMetrics() As Metrics
 
    Const PointsPerInch     As Long = 72
    Dim tRect               As RECT
    Dim dDevCapsX           As Double
    Dim dDevCapsY           As Double
    Dim dCurZoom            As Double
    Dim lhdc                As Long
    
    lhdc = GetDC(0)
    dCurZoom = (ActiveWindow.Zoom / 100)
    dDevCapsX = _
    (GetDeviceCaps(lhdc, LOGPIXELSX) / PointsPerInch * dCurZoom)
    dDevCapsY = _
    (GetDeviceCaps(lhdc, LOGPIXELSY) / PointsPerInch * dCurZoom)
    
    
    With ActiveWindow
        tRect.Left = _
        .PointsToScreenPixelsX _
        ((.VisibleRange.Cells(1, 1).Left - (dShtStandardWidth)) * dDevCapsX)
        tRect.Top = _
        .PointsToScreenPixelsY _
        ((.VisibleRange.Cells(1, 1).Top - dShtStandardHeight) * dDevCapsY)
        tRect.Right = _
        .PointsToScreenPixelsX _
        ((.VisibleRange.Cells(1, 1).Left) * dDevCapsX)
        tRect.Bottom = _
        .PointsToScreenPixelsY _
        ((.VisibleRange.Cells(1, 1).Top) * dDevCapsY)
    End With
    ReleaseDC 0, lhdc
    
    With tRect
        GetHeadingMetrics.Hgt = .Bottom - .Top
        GetHeadingMetrics.Wdt = .Right - .Left
    End With
  
End Function

Private Function MakeMemoryBitmap(ByVal wid As Long, ByVal _
Hgt As Long, color As RGB) As MEMORYBITMAP
    
    Dim bDib()          As Byte
    Dim bBytes()        As Byte
    Dim tSA             As SAFEARRAY2D
    Dim result          As MEMORYBITMAP
    Dim bi24BitInfo     As BITMAPINFO
    Dim Cnt             As Long
    Dim x               As Long
    Dim y               As Long
    Dim xMax            As Long
    Dim yMax            As Long
    Dim lB              As Long
    Dim lG              As Long
    Dim lR              As Long
    Dim lA              As Long
    Dim lA2             As Long
    Dim lTIme           As Long
    Dim iDC             As Long
    Dim iBitmap         As Long
    Dim m_lPtr          As Long
    Dim lDC             As Long
    
    
    With bi24BitInfo.bmiHeader
        .biBitCount = 24
        .biCompression = BI_RGB
        .biPlanes = 1
        .biSize = Len(bi24BitInfo.bmiHeader)
        .biWidth = wid
        .biHeight = Hgt
    End With
    
    ReDim bBytes _
    (1 To bi24BitInfo.bmiHeader.biWidth * _
    bi24BitInfo.bmiHeader.biHeight * 3) As Byte
    lDC = GetDC(0)
    
    iDC = CreateCompatibleDC(lDC)
    
    ReleaseDC 0, lDC
    iBitmap = _
    CreateDIBSection(iDC, bi24BitInfo, _
    DIB_RGB_COLORS, m_lPtr, ByVal 0&, ByVal 0&)
    SelectObject iDC, iBitmap
    
    [COLOR=seagreen]' Get the bits in the from DIB section:
[/COLOR]    With tSA
        .cbElements = 1
        .cDims = 2
        .Bounds(0).lLbound = 0
        [COLOR=seagreen]' Height of the bitmap
[/COLOR]        .Bounds(0).cElements = Hgt  'bi24BitInfo.bmiHeader.biHeight
        .Bounds(1).lLbound = 0
       [COLOR=seagreen] ' Width of the bitmap in bits (see earlier):
[/COLOR]        .Bounds(1).cElements = _
        (bi24BitInfo.bmiHeader.biWidth * 3 + 3) And &HFFFFFFFC
        .pvData = m_lPtr
    End With
    
   [COLOR=seagreen] ' Make the bDib() array point to the memory addresses:
[/COLOR]    CopyMemory ByVal VarPtrArray(bDib), VarPtr(tSA), 4
    
    yMax = bi24BitInfo.bmiHeader.biHeight - 1
    xMax = bi24BitInfo.bmiHeader.biWidth - 1
    
    For x = 0 To (xMax * 3) Step 3
        For y = 0 To yMax
            bDib(x, y) = color.B
            bDib(x + 1, y) = color.G
            bDib(x + 2, y) = color.R
        Next y
    Next x
    
    CopyMemory ByVal VarPtrArray(bDib), 0&, 4
    
    With result
        .hBM = iBitmap
        .hdc = iDC
        .wid = wid
        .Hgt = Hgt
        .oldhdc = SelectObject(.hdc, result.hBM)
    End With
    
    [COLOR=seagreen]'cleanup
[/COLOR]    ReleaseDC 0, iDC
    DeleteObject result.hBM
    
    MakeMemoryBitmap = result
    
End Function

Private Function ScreenDPI(bVert As Boolean) As Long
 
    Static lDPI(1), lDC
    
    If lDPI(0) = 0 Then
        lDC = GetDC(0)
        lDPI(0) = GetDeviceCaps(lDC, 88)
        lDPI(1) = GetDeviceCaps(lDC, 90)
        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) / 72
  
End Function
 
Private Function GetRangeRect(ByVal rng As Range) As RECT
 
    Dim OWnd  As Window
    
    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
 
End Function

Before experimenting with this code , please save your work as a precaution !

Any feedback much appreciated.

Regards.