Jaafar Tribak
Well-known Member
- Joined
- Dec 5, 2002
- Messages
- 9,621
- Office Version
- 2016
- Platform
- 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)
* Add a class module to your project , give it the name of ClistBox and place the following code it it :
* This is an example of how to call it in a standard module :
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.
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.