Rob said:
It worked for me just fine - XL2003
Some of the line wrapping on that post screwed me up.
There was one that I missed were the line contained the word Message. It was
accepted without error by VBA, but was in fact a comment from the previous
line.
Hi Rob,
I'm very pleased you made me have another look. I thought I had carefully
"un line wrapped". I caught the line ending in "Message" which as you say
did not glow red. But there was another one I missed - lParam at the end of
the commented line starting "Copy our copy". After removing the stray
"lParam" all works fine.
Michel - please accept my apologies for casting aspersions on your amazing
code!!
I hope you will not mind if I take the liberty of reposting your code,
exactly as original but (hopefully) without any line wrapping.
Regards,
Peter T
Michel Pierron's code:
In UserForm module:
'''start code Userform
Option Explicit
Private Declare Function SetWindowLong& Lib "user32" Alias _
"SetWindowLongA" (ByVal hWnd&, ByVal nIndex&, ByVal dwNewLong&)
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetWindow Lib "user32" (ByVal hWnd As Long _
, ByVal wCmd As Long) As Long
Private Const GWL_WNDPROC As Long = (-4&)
Private hWnd As Long
Private Sub UserForm_Initialize()
Dim i&
hWnd = GetWindow(FindWindow(vbNullString, Me.Caption), 5)
With Me.ListView1
..ColumnHeaders.Add , , "Item Column", .Width * 1 / 3
..ColumnHeaders.Add , , "Subitem 1", .Width * 1 / 3
..ColumnHeaders.Add , , "Subitem 2", .Width * 1 / 3
For i = 0 To 99
With .ListItems.Add(, , "Item " & Format(i, "00"))
..SubItems(1) = "Subitem 1"
..SubItems(2) = "Subitem 2"
End With
Next
End With
OldProc = SetWindowLong(hWnd, GWL_WNDPROC, AddressOf WindowProc)
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, _
CloseMode As Integer)
Call SetWindowLong(hWnd, GWL_WNDPROC, OldProc)
End Sub
'''end code Userform
In standard module:
''''''start code standard module
Option Explicit
' Constants used for customdraw routine
Private Const NM_CUSTOMDRAW = (-12&)
Private Const WM_NOTIFY As Long = &H4E&
Private Const CDDS_PREPAINT As Long = &H1&
Private Const CDRF_NOTIFYITEMDRAW As Long = &H20&
Private Const CDDS_ITEM As Long = &H10000
Private Const CDDS_ITEMPREPAINT As Long = CDDS_ITEM Or CDDS_PREPAINT
Private Const CDRF_NEWFONT As Long = &H2&
' The NMHDR structure contains information about a
' notification message.
' The pointer to this structure is specified as the lParam member of
'a WM_NOTIFY message.
Private Type NMHDR
hWndFrom As Long ' Window handle of control sending message
idFrom As Long ' Identifier of control sending message
code As Long ' Specifies the notification code
End Type
' Struct of the NMCUSTOMDRAW struct
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
' Generic customdraw struct
Private Type NMCUSTOMDRAW
hdr As NMHDR
dwDrawStage As Long
hDC As Long
rc As RECT
dwItemSpec As Long
uItemState As Long
lItemlParam As Long
End Type
' Listview specific customdraw struct
Private Type NMLVCUSTOMDRAW
NMCW As NMCUSTOMDRAW
ForeColorText As Long
BackColorText As Long
' if IE >= 4.0 this member of the struct can be used
'iSubItem As Integer
End Type
' Function used to manipulate memory data
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(lpDest As Any, lpSource As Any, ByVal cBytes&)
' Function used to call the next window proc in the "chain" for the
' subclassed Window
Declare Function CallWindowProc& Lib "user32" Alias _
"CallWindowProcA" (ByVal lpPrevWndFunc&, ByVal hWnd&, _
ByVal Msg&, ByVal wParam&, ByVal lParam&)
' This var will hold a pointer to the original message handler
' so we MUST save it so that it can be restored before we
' exit the app.
' if we don't restore it.... CRASH!!!!
Public OldProc As Long
' WARNING -----------------------------------------------
' Do not try to step through this function in debug mode !
' You will crash also, do no set any break points in this function !
' You will crash subclassing is non-trivial and should be handled with
' extreame care !
'There are ways to use a "Debug" dll to allow you to set breakpoints in
' subclassed code in the IDE but this was not implimented for this demo.
' WARNING -----------------------------------------------
' This is implementation of the message handling routine
' determine which message was recieved
Function WindowProc(ByVal hWnd As Long, ByVal iMsg As Long _
, ByVal wParam As Long, ByVal lParam As Long) As Long
Select Case iMsg
Case WM_NOTIFY
' If it's a WM_NOTIFY message copy the data from the
' address pointed to by lParam into a NMHDR struct
Dim UDT_NMHDR As NMHDR
CopyMemory UDT_NMHDR, ByVal lParam, 12&
With UDT_NMHDR
If .code = NM_CUSTOMDRAW Then
' If the code member of the struct is NM_CUSTOMDRAW, copy
' the data pointed to by lParam into a NMLVCUSTOMDRAW struct
Dim UDT_NMLVCUSTOMDRAW As NMLVCUSTOMDRAW
' This is now OUR copy of the struct
CopyMemory UDT_NMLVCUSTOMDRAW, ByVal lParam, Len(UDT_NMLVCUSTOMDRAW)
With UDT_NMLVCUSTOMDRAW.NMCW
' Determine whether or not this is one of the messages we are
' interested in
Select Case .dwDrawStage
' If it's a prepaint message, tell windows WE want first dibs on
' painting for each item and then exit without letting VB get
' this message
Case CDDS_PREPAINT
WindowProc = CDRF_NOTIFYITEMDRAW
Exit Function
Case CDDS_ITEMPREPAINT
' Set the forecolor for items in the listview.
' Set the backcolor for items in the listview.
If (.dwItemSpec Mod 2) = 0 Then
UDT_NMLVCUSTOMDRAW.ForeColorText = vbRed
UDT_NMLVCUSTOMDRAW.BackColorText = &HC0C0C0
' Copy our copy of the struct back to the memory address pointed
' to by lParam
CopyMemory ByVal lParam, UDT_NMLVCUSTOMDRAW, Len(UDT_NMLVCUSTOMDRAW)
End If
' Tell windows that we changed the font and do not allow VB to
' get this Message
WindowProc = CDRF_NEWFONT
Exit Function
End Select
End With
End If
End With
End Select
' Pass all messages on to VB and then return the value to windows
WindowProc = CallWindowProc(OldProc, hWnd, iMsg, wParam, lParam)
End Function
Sub CustomListView()
UserForm1.Show
End Sub
''''''end code standard module
