Cool MultiColoured ListBox !!

Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
9,577
Office Version
  1. 2016
Platform
  1. Windows
Greetings,

Download workbook demo

Ok, this is a raw experiment and needs some more tweaking .The main issue is if the Listbox has a scrollbar ,the painting will not fit exactly as it should. This is because the listbox scrollbar has no hwnd so it's very difficult to manipulate it.


Proceedings :

Embeed a listbox in sheets(1), populate it with some items and make it large enough so as not to display a scrollbar(see above).


* Code in Standard Module (Main)

Code:
Option Base 1
Option Explicit
 
Public Type RGB
    R As Byte
    G As Byte
    B As Byte
End Type
 
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 GetWindowRect Lib "user32" _
(ByVal hwnd As Long, _
lpRect As RECT) As Long
 
Private Type TEXTMETRIC
    tmHeight As Long
    tmAscent As Long
    tmDescent As Long
    tmInternalLeading As Long
    tmExternalLeading As Long
    tmAveCharWidth As Long
    tmMaxCharWidth As Long
    tmWeight As Long
    tmOverhang As Long
    tmDigitizedAspectX As Long
    tmDigitizedAspectY As Long
    tmFirstChar As Byte
    tmLastChar As Byte
    tmDefaultChar As Byte
    tmBreakChar As Byte
    tmItalic As Byte
    tmUnderlined As Byte
    tmStruckOut As Byte
    tmPitchAndFamily As Byte
    tmCharSet As Byte
End Type
 
Private Const MM_TEXT = 1
 
Private Declare Function GetTextMetrics Lib "gdi32" _
Alias "GetTextMetricsA" (ByVal hdc As Long, _
lpMetrics As TEXTMETRIC) As Long
 
Private Declare Function SetMapMode Lib "gdi32" _
(ByVal hdc As Long, _
ByVal nMapMode As Long) As Long
 
Private Declare Function FindWindow Lib "user32" _
Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long

Private Declare Function FindWindowEx Lib "user32" _
Alias "FindWindowExA" _
(ByVal hWnd1 As Long, _
ByVal hWnd2 As Long, _
ByVal lpsz1 As String, _
ByVal lpsz2 As String) As Long

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 Declare Function VarPtrArray Lib "msvbvm50.dll" _
Alias "VarPtr" (Ptr() As Any) As Long
 
Private Type BLENDFUNCTION
    BlendOp As Byte
    BlendFlags As Byte
    SourceConstantAlpha As Byte
    AlphaFormat As Byte
End Type
 
Private Const AC_SRC_OVER = &H0

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 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 Const LOGPIXELSX As Long = 88
Private Const LOGPIXELSY As Long = 90
Private Const PointsPerInch = 72

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 CreateCompatibleDC Lib "gdi32" _
(ByVal hdc As Long) As Long
 
Private Declare Function ReleaseDC Lib "user32" _
(ByVal hwnd As Long, _
ByVal hdc 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 Sub CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" _
(Destination As Any, _
Source As Any, ByVal Length As Long)

Private Const GWL_WNDPROC = -4
 
Private Declare Function CallWindowProc Lib "user32" _
Alias "CallWindowProcA" _
(ByVal lpPrevWndFunc As Long, _
ByVal hwnd As Long, _
ByVal MSG As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
 
Private Declare Function SetWindowLong Lib "user32" _
Alias "SetWindowLongA" _
(ByVal hwnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
 
Private Const WM_WINDOWPOSCHANGED As Long = &H47
Private Const WM_MOUSEACTIVATE As Long = &H21
Private Const WM_PAINT As Long = &HF
 
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 Const SRCCOPY As Long = &HCC0020

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 Const BI_RGB As Long = 0&

Private Const DIB_RGB_COLORS As Long = 0
 
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 GetWindowDC Lib "user32" _
(ByVal hwnd As Long) As Long

Private Declare Function UpdateWindow Lib "user32" _
(ByVal hwnd 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 SendMessage Lib "user32" _
Alias "SendMessageA" _
(ByVal hwnd As Long, _
ByVal MSG As Long, _
wParam As Any, _
lParam As Any) As Long
 
Public g_lListBoxChildhwnd As Long
Public g_lLbHook As Long '--handle for subclass.
Public g_lMemSnapShot As Long
Private g_oListBox As OLEObject
Private g_lListBoxParenthwnd As Long
Private oClistBox As ClistBox

Private Function GetListBoxhwnd() As Long

    Dim lXLAPPhwnd As Long, lXLDESKhwnd As Long, lEXCEL7hwnd As Long
    
        lXLAPPhwnd = FindWindow("XLMAIN", Application.Caption)
        lXLDESKhwnd = FindWindowEx _
        (lXLAPPhwnd, ByVal 0&, "XLDESK", vbNullString)
        lEXCEL7hwnd = FindWindowEx _
        (lXLDESKhwnd, ByVal 0&, "EXCEL7", vbNullString)
        g_lListBoxParenthwnd = FindWindowEx _
        (lEXCEL7hwnd, ByVal 0&, "F3 Server 60000000", vbNullString)
        g_lListBoxChildhwnd = FindWindowEx _
        (g_lListBoxParenthwnd, ByVal 0&, "F3 Server 60000000", vbNullString)
    
    If g_lListBoxParenthwnd Then
        GetListBoxhwnd = g_lListBoxParenthwnd
    End If

End Function
 
Private Function GetListBoxRect(ListBox As OLEObject) As RECT
 
    Const PointsPerInch As Long = 72
    Dim hdc As Long
    Dim lDevCapsX As Double
    Dim lDevCapsY As Double
    Dim lCurZoom As Double
    Dim tRect As RECT
    Dim tRect2 As RECT
    Dim ListBoxWidth
    Dim lhdc As Long
    
    lhdc = GetWindowDC(g_lListBoxParenthwnd)
    lCurZoom = (ActiveWindow.Zoom / 100)
    lDevCapsX = _
    (GetDeviceCaps(lhdc, LOGPIXELSX) / PointsPerInch * lCurZoom)
    lDevCapsY = _
    (GetDeviceCaps(lhdc, LOGPIXELSY) / PointsPerInch * lCurZoom)
    With ActiveWindow
        tRect.Left = _
        .PointsToScreenPixelsX((ListBox.Left) * lDevCapsX)
        tRect.Top = _
        .PointsToScreenPixelsY(ListBox.Top * lDevCapsY)
        tRect.Right = _
        .PointsToScreenPixelsX _
        ((ListBox.Left + ListBox.Width) * lDevCapsX)
        tRect.Bottom = _
        .PointsToScreenPixelsY _
        ((ListBox.Top + ListBox.Height) * lDevCapsY)
    End With
    ReleaseDC g_lListBoxParenthwnd, lhdc
    
    GetListBoxRect = tRect
 
End Function

Private Function MakeMemoryBitmap(ByVal wid As Long, ByVal _
hgt As Long, color As RGB) As MemoryBitmap
 
    Dim bDib() As Byte
    Dim X As Long, Y As Long
    Dim xMax As Long, yMax As Long
    Dim lB As Long, lG As Long, lR As Long
    Dim lA As Long, lA2 As Long
    Dim lTIme As Long
    Dim tSA As SAFEARRAY2D
    Dim result As MemoryBitmap
    Dim iDC As Long
    Dim iBitmap As Long
    Dim m_lPtr As Long
    
    
    Dim bi24BitInfo As BITMAPINFO, bBytes() As Byte, Cnt 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
    iDC = CreateCompatibleDC(GetWindowDC(g_lListBoxParenthwnd))
    iBitmap = _
    CreateDIBSection(iDC, bi24BitInfo, DIB_RGB_COLORS, m_lPtr, ByVal 0&, ByVal 0&)
    SelectObject iDC, iBitmap
    
    ' Get the bits in the from DIB section:
    With tSA
        .cbElements = 1
        .cDims = 2
        .Bounds(0).lLbound = 0
        ' Height of the bitmap
        .Bounds(0).cElements = hgt  'bi24BitInfo.bmiHeader.biHeight
        .Bounds(1).lLbound = 0
        ' Width of the bitmap in bits (see earlier):
        .Bounds(1).cElements = _
        (bi24BitInfo.bmiHeader.biWidth * 3 + 3) And &HFFFFFFFC
        .pvData = m_lPtr
    End With
    
    ' Make the bDib() array point to the memory addresses:
    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
    
    ReleaseDC g_lListBoxParenthwnd, iDC
   
    MakeMemoryBitmap = result
    
End Function
 
Private Sub Hook(hWnd1 As Long)  '--subclass Listbox.
 
    If (g_lLbHook = 0) Then
        g_lLbHook = SetWindowLong(hWnd1, GWL_WNDPROC, AddressOf WindowProc)
    End If
 
End Sub
 
Private Sub Unhook(hWnd1 As Long)
 
    Dim LRet As Long
    
    'Set the message handler back to the original
    If (g_lLbHook <> 0) Then
        LRet = SetWindowLong(hWnd1, GWL_WNDPROC, g_lLbHook)
        g_lLbHook = 0
    End If
 
End Sub

Private Function WindowProc _
(ByVal hwnd As Long, ByVal uMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
 
    Dim lhdc As Long
    
    On Error Resume Next
    
    Select Case uMsg
        Case WM_PAINT
            lhdc = GetDC(g_lListBoxChildhwnd)
            SendMessage g_lListBoxChildhwnd, WM_PAINT, lhdc, 0
            RefreshListBox g_lMemSnapShot, g_lListBoxChildhwnd
            ReleaseDC g_lListBoxChildhwnd, lhdc
        Case WM_MOUSEACTIVATE
            RefreshListBox g_lMemSnapShot, g_lListBoxChildhwnd
    End Select
    
    WindowProc = CallWindowProc(g_lLbHook, hwnd, uMsg, wParam, lParam)
 
End Function
 
Private Function GetMemSnapshot(hwnd As Long, tRect As RECT) As Long
 
    Dim lMemoryDC As Long
    Dim lhdc As Long
    Dim lbmp As Long
    
    lhdc = GetWindowDC(hwnd)
    
    With tRect
        lMemoryDC = CreateCompatibleDC(lhdc)
        lbmp = CreateCompatibleBitmap _
        (lhdc, .Right - .Left, .Bottom - .Top)
        SelectObject lMemoryDC, lbmp
        DeleteObject (lbmp)
        BitBlt lMemoryDC, 0, 0, .Right - .Left, _
        .Bottom - .Top, lhdc, 0, 0, SRCCOPY
    End With
    
    GetMemSnapshot = lMemoryDC
 
End Function
 

Private Function GetListBoxTextSize(hwnd As Long) As Long
 
    Dim hdc As Long
    Dim PrevMapMode As Long, tm As TEXTMETRIC
    
    hdc = GetWindowDC(hwnd)
    ' Set the mapping mode to pixels
    PrevMapMode = SetMapMode(hdc, MM_TEXT)
    ' Get the size of the system font
    GetTextMetrics hdc, tm
    ' Set the mapping mode back to what it was
    PrevMapMode = SetMapMode(hdc, PrevMapMode)
    
    ' Release the device context
    ReleaseDC hwnd, hdc
    
    GetListBoxTextSize = tm.tmHeight
 
End Function

Sub PaintListBoxItems(ListBox As OLEObject, ItemsColors() As RGB)
 
    Dim lRowHeight
    Dim tRect As RECT
    Dim memory_bitmap As MemoryBitmap
    Dim BF As BLENDFUNCTION, lBF As Long
    Dim lColorsItem As Long
    
    
    If (g_lLbHook = 0) Then
        Set g_oListBox = ListBox
        Set oClistBox = New ClistBox
        Set oClistBox.ListBox = ListBox.Object
        ListBox.Object.ListIndex = -1
        g_lListBoxParenthwnd = GetListBoxhwnd()
        lRowHeight = _
        (GetListBoxTextSize(g_lListBoxChildhwnd)) * (ActiveWindow.Zoom / 100)
        UpdateWindow g_lListBoxChildhwnd
        tRect = GetListBoxRect(ListBox)
        With BF
            .BlendOp = AC_SRC_OVER
            .BlendFlags = 0
            .SourceConstantAlpha = 100
            .AlphaFormat = 0
        End With
        CopyMemory lBF, BF, 4
        With tRect
            For lColorsItem = LBound(ItemsColors) To UBound(ItemsColors)
                memory_bitmap = MakeMemoryBitmap _
                (.Right - .Left, .Bottom - .Top, ItemsColors(lColorsItem))
                AlphaBlend _
                GetWindowDC(g_lListBoxParenthwnd), 3, _
                (lRowHeight) * (lColorsItem - 1) + 3, .Right - .Left, lRowHeight, _
                memory_bitmap.hdc, 0, 0, .Right - .Left, .Bottom - .Top, (lBF)
            Next lColorsItem
        End With
        g_lMemSnapShot = GetMemSnapshot(g_lListBoxParenthwnd, tRect)
        RefreshListBox g_lMemSnapShot, g_lListBoxParenthwnd
        Call Hook(g_lListBoxParenthwnd)
    End If
 
End Sub

Sub RefreshListBox(lMemSnapShotDC As Long, ListBoxhwnd As Long)
 
    Dim tRect As RECT
    Dim lhdc As Long
    
    tRect = GetListBoxRect(g_oListBox)
    lhdc = GetWindowDC(ListBoxhwnd)
    With tRect
        BitBlt lhdc, 0, 0, _
        (.Right - .Left), _
        .Bottom - .Top, lMemSnapShotDC, 0, 0, SRCCOPY
    End With
    ReleaseDC ListBoxhwnd, lhdc
    
End Sub

Sub RestoreListBox()
 
    Call Unhook(g_lListBoxParenthwnd)
    InvalidateRect 0, 0, 0
    g_oListBox.Object.ListIndex = 0
 
End Sub

* Add a class module to your project , give it the name of ClistBox and place the following code it it :

Code:
Option Explicit
 
Public WithEvents ListBox  As MSForms.ListBox
 
Private Sub ListBox_KeyDown _
(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
 
    Call UpdateListBoxColors
 
End Sub
 
Private Sub ListBox_KeyUp _
(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
 
    Call UpdateListBoxColors
 
End Sub
 
Private Sub ListBox_MouseUp _
(ByVal Button As Integer, ByVal Shift As Integer, _
ByVal X As Single, ByVal Y As Single)
 
    Call UpdateListBoxColors
 
End Sub
 
Private Sub UpdateListBoxColors()
 
    If g_lLbHook Then
        RefreshListBox g_lMemSnapShot, g_lListBoxChildhwnd
        ListBox.ListIndex = -1
    End If
 
End Sub

* This is an example of how to call it in a standard module :

Code:
Option Explicit
 
Sub Test()
 
    Dim ColoredItems() As RGB
    Dim i As Long
    Dim r1 As RGB
    Dim r2 As RGB
    Dim r3 As RGB
    Dim r4 As RGB
 
    With r1
        .R = 255
        .G = 0
        .B = 0
    End With
                               
    With r2
        .R = 0
        .G = 255
        .B = 0
    End With
    
    With r3
        .R = 0
        .G = 0
        .B = 0
    End With
    
    With r4
        .R = 100
        .G = 0
        .B = 250
    End With
    On Error Resume Next
    
    With Sheets(1).OLEObjects("ListBox1")
        ReDim ColoredItems(.Object.ListCount)
        For i = LBound(ColoredItems) + 1 To UBound(ColoredItems) Step 4
            ColoredItems(i) = r1
            ColoredItems(i + 1) = r2
            ColoredItems(i + 2) = r3
            ColoredItems(i + 3) = r4
        Next i
        PaintListBoxItems Sheets(1).OLEObjects("ListBox1"), ColoredItems
    End With
 
End Sub

Tested on WIN XP Excel 2003.

Other caveats :

Zooming and changing the listbox Font size may affect the metrics of the diaplay.

Hopefully, the scrollbar issue and the others will be solved somehow :)

Any feedback on (other bugs, suggestions etc...) much appreciated .

Regards.
 

Excel Facts

Excel Wisdom
Using a mouse in Excel is the work equivalent of wearing a lanyard when you first get to college
Has anyone tried the workbook demo and got it working ?

I would like to know if this multicoloured listbox hack works in different systems and is stable enough to deserve spending more time on improving it .

Regards.
 
Upvote 0
Hi Jaafar,
First up let me just say this is really, really cool:) I have been taking it apart (as I am wont to do) have found a few issues with it, but I was waiting until I had a solution to offer as well. I am working on a few methods but none that I feel is perfect. I'll go ahead and list them out though. First off, The numbers that follow the class name F3 Server are not always the same so you can't hard code them. Secondly you can have more than one listbox (and therefore more than one match to "F3 Server*". Finally I am getting a hang on find win process that I haven't quite run down.

I am still going over it though so I will post back. But this really has a ton of potential and I want to thank you for the obvious amount of work that went into putting it all together.
 
Upvote 0
Also XLDESK can have more than one child named Excel7 if there are add-ins enabled.
 
Upvote 0
Oorang,

Thanks very much for taking an interest and trying this .

First off, The numbers that follow the class name F3 Server are not always the same so you can't hard code them..
Actually they are always the same at least in Win XP Office XP XL2003. I used Winspector in different PCs and they all returned F3 Server 60000000.

Secondly you can have more than one listbox (and therefore more than one match to "F3 Server*". Finally I am getting a hang on find win process that I haven't quite run down.

That's true, and the code will need some workround to identify the target Listbox as the Listbox can't be identified by it's window text as it has none. I am already working on this.

The same goes for the EXCEL7 class name as there might be more than one workbook/Addin open simultaniously but i guess this easy to solve.

Regards.
 
Upvote 0
Hmmm, on vista, it's "F3 Server 677e0000". Have you considered using a ListVIEW on a form instead. ListView has a nice HWND property that solves a lot of problems:) (I wouldn't try embedding into a sheet though.)
 
Upvote 0
Here is an idea to overcome the scrolbar problem. Hopefully, we can figure out if the listbox is currently displaying a scrollbar when the listbox height is <= to the sum of each row height (in pixels). Once this is established we can adapt the result of the GetListBoxRect function accordingly.

As for the listbox items that are off the listbox visible area , the MakeMemoryBitmap function hopefully can handle that as it creates the bitmaps in memory although it's going to be quite difficult repainting the listbox after each scroll.

As far as getting the exact target listbox if there happens to be more than one on the worksheet, I think the TopLeft Property can come in handy to uniquely identify it.

Will be looking into this and hoefully post back with any progress made.

Regards.
 
Upvote 0

Forum statistics

Threads
1,213,535
Messages
6,114,192
Members
448,554
Latest member
Gleisner2

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