David what exactly are you trying to do?
Here is some code to get you started. I modified the source to work with
Access Forms. It is from a test project where I was helping someone
Subclass a ListView control.
Place a ListView control and a TextBox control, named as indicated in
the source code onto a Form. Place the following code behind the Form.
After the code for the Form's class module you will find code to be
placed into a standard code module.
Good Luck!
Option Compare Database
Option Explicit
' demo project showing how to custom draw single items in a listview
' by Bryan Stafford of New Vision Software® - (e-mail address removed)
' this demo is released into the public domain "as is" without
' warranty or guaranty of any kind. In other words, use at
' your own risk.
' constant used to get the address of the window proc for the
subclassed window
Private Const GWL_WNDPROC As Long = (-4&)
' API call to alter the class data for this window
Private Declare Function SetWindowLong& Lib "user32" Alias
"SetWindowLongA" (ByVal hwnd&, _
ByVal
nIndex&, ByVal dwNewLong&)
' WIndow we will subclass
Private hwndTemp As Long
Private Sub Form_Load()
' we will *borrow* the font from the form since we are not using it.
' set the font attributes we want the custom draw items in the
listview to have
'
' With Font
' .Bold = True
' '.Italic = True
' '.Underline = True
' End With
'
' ' grab a handle to the form's font and store it in the global
variable
'Dim IFont As IFont
'Set IFont = lvCustomDraw.Object.Font
'
'g_hBoldFont = IFont.hFont
'
'hFont = GetStockObject(ANSI_VAR_FONT)
' fill the listview with some stuff....
With lvCustomDraw
.ColumnHeaders.Add , , "Item Column"
.ColumnHeaders.Add , , "Subitem 1"
.ColumnHeaders.Add , , "Subitem 2"
Dim i&
For i = 0 To 99
With .ListItems.Add(, , "Item " & CStr(i))
.SubItems(1) = "Subitem 1"
.SubItems(2) = "Subitem 2"
End With
Next
End With
' take control of message processing by installing our message
handling
' routine into the chain of message routines for this window.
' we subclass the form because wm_notify messages are sent to the
parent
' of the control, in this case, the VB form.
hwndTemp = FindDetailWindow(Me.hwnd)
hwndTemp = FindLVFrameWindow(hwndTemp)
g_addProcOld = SetWindowLong(hwndTemp, GWL_WNDPROC, AddressOf
WindowProcLV)
End Sub
Private Sub Form_Unload(Cancel As Integer)
' give message processing control back to VB
' if you don't do this you WILL crash!!!
Call SetWindowLong(hwndTemp, GWL_WNDPROC, g_addProcOld)
End Sub
Private Sub Text1_Click()
Me.Text1.Value = Me.lvCustomDraw.Object.hwnd
End Sub
'***********************************************************************
*****************************
' Place the following code into a standard Code module.
Option Compare Database
Option Explicit
Private Declare Function apiGetWindow Lib "user32" _
Alias "GetWindow" _
(ByVal hwnd As Long, _
ByVal wCmd As Long) _
As Long
Private Declare Function apiGetClassName Lib "user32" _
Alias "GetClassNameA" _
(ByVal hwnd As Long, _
ByVal lpClassName As String, _
ByVal nMaxCount 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
' GetWindow() Constants
Private Const GW_HWNDFIRST = 0
Private Const GW_HWNDLAST = 1
Private Const GW_HWNDNEXT = 2
Private Const GW_HWNDPREV = 3
Private Const GW_OWNER = 4
Private Const GW_CHILD = 5
Private Const GW_MAX = 5
' demo project showing how to custom draw single items in a listview
' by Bryan Stafford of New Vision Software® - (e-mail address removed)
' this demo is released into the public domain "as is" without
' warranty or guaranty of any kind. In other words, use at
' your own risk.
' Generic WM_NOTIFY notification codes for common controls
'Public Enum WinNotifications
Private Const NM_FIRST = (-0&) ' (0U- 0U) ' //
generic to all controls
Private Const NM_LAST = (-99&) ' (0U- 99U)
Private Const NM_OUTOFMEMORY = (NM_FIRST - 1&)
Private Const NM_CLICK = (NM_FIRST - 2&)
Private Const NM_DBLCLK = (NM_FIRST - 3&)
Private Const NM_RETURN = (NM_FIRST - 4&)
Private Const NM_RCLICK = (NM_FIRST - 5&)
Private Const NM_RDBLCLK = (NM_FIRST - 6&)
Private Const NM_SETFOCUS = (NM_FIRST - 7&)
Private Const NM_KILLFOCUS = (NM_FIRST - 8&)
Private Const NM_CUSTOMDRAW = (NM_FIRST - 12&)
Private Const NM_HOVER = (NM_FIRST - 13&)
'End Enum
Public Const WM_NOTIFY As Long = &H4E&
' constants used for customdraw routine
Public Const CDDS_PREPAINT As Long = &H1&
Public Const CDRF_NOTIFYITEMDRAW As Long = &H20&
Public Const CDDS_ITEM As Long = &H10000
Public Const CDDS_ITEMPREPAINT As Long = CDDS_ITEM Or CDDS_PREPAINT
Public 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.
Public 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
' sub struct of the NMCUSTOMDRAW struct
' Public Type RECT
' Left As Long
' Top As Long
' Right As Long
' Bottom As Long
' End Type
'
' generic customdraw struct
Public 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
Public Type NMLVCUSTOMDRAW
nmcd As NMCUSTOMDRAW
clrText As Long
clrTextBk As Long
' if IE >= 4.0 this member of the struct can be used
'iSubItem As Integer
End Type
Public Declare Function GetStockObject Lib "gdi32" (ByVal nIndex As
Long) As Long
' function used to manipulate memory data
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory"
(lpDest As Any, lpSource As Any, ByVal cBytes&)
' gdi function used to select bold font into the hDC passed in the
prepaint message
Public Declare Function SelectObject Lib "gdi32" (ByVal hdc&, ByVal
hObject&) As Long
' handle to the bold font set for the form. this is used to set the
bold font for the listview items
Public g_hBoldFont As Long
' 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 g_addProcOld As Long
' function used to call the next window proc in the "chain" for the
subclassed window
Public Declare Function CallWindowProc& Lib "user32" Alias
"CallWindowProcA" (ByVal lpPrevWndFunc&, _
ByVal hwnd&, ByVal
msg&, ByVal wparam&, ByVal lparam&)
' Stock Logical
Objects
Public Const WHITE_BRUSH = 0
Public Const LTGRAY_BRUSH = 1
Public Const GRAY_BRUSH = 2
Public Const DKGRAY_BRUSH = 3
Public Const BLACK_BRUSH = 4
Public Const NULL_BRUSH = 5
Public Const HOLLOW_BRUSH = NULL_BRUSH
Public Const WHITE_PEN = 6
Public Const BLACK_PEN = 7
Public Const NULL_PEN = 8
Public Const OEM_FIXED_FONT = 10
Public Const ANSI_FIXED_FONT = 11
Public Const ANSI_VAR_FONT = 12
Public Const SYSTEM_FONT = 13
Public Const DEVICE_DEFAULT_FONT = 14
Public Const DEFAULT_PALETTE = 15
Public Const SYSTEM_FIXED_FONT = 16
Public Const STOCK_LAST = 16
Private Const CtlMsgWinClass = "CtlFrameWork_ReflectWindow"
Public hFont As Long
'WARNING!!!! WARNING!!!! WARNING!!!! WARNING!!!! WARNING!!!! WARNING!!!!
'
' Do NOT try to step through this function in debug mode!!!!
' You WILL crash!!! Also, do NOT 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!!!! WARNING!!!! WARNING!!!! WARNING!!!! WARNING!!!! WARNING!!!!
Public Function WindowProcLV(ByVal hwnd As Long, ByVal iMsg As Long, _
ByVal wparam As Long,
ByVal lparam As Long) As Long
' this is *our* implimentation of the message handling routine
'Debug.Print "Start WIndowProc"
' determine which message was recieved
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 udtNMHDR As NMHDR
CopyMemory udtNMHDR, ByVal lparam, 12&
With udtNMHDR
If .code = NM_CUSTOMDRAW Then
Debug.Print "Custom Draw message"
' if the code member of the struct is NM_CUSTOMDRAW, copy the
data
' pointed to by lParam into a NMLVCUSTOMDRAW struct
Dim udtNMLVCUSTOMDRAW As NMLVCUSTOMDRAW
' this is now OUR copy of the struct
CopyMemory udtNMLVCUSTOMDRAW, ByVal lparam,
Len(udtNMLVCUSTOMDRAW)
With udtNMLVCUSTOMDRAW.nmcd
' 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
WindowProcLV = CDRF_NOTIFYITEMDRAW
Exit Function
' if it's time to paint an item, check to see if it's
divisible by 3.
' if it is, select the bold font that we borrowed from the
form into the
' hDC of the listview and set the text color to something
*different*.
' then tell windows that we changed the font for this
item.
Case CDDS_ITEMPREPAINT
Debug.Print "CDDS_ITEMPREPAINT"
If (.dwItemSpec Mod 3) = 0 Then
' We don;t need to select a new Font into the
ListView's DC
' just to change the background color of the row!!!!
'Call SelectObject(.hdc, g_hBoldFont)
' we can also set the color for items in the listview.
' we will set the color for every third bolded
item....
If (.dwItemSpec Mod 9) = 0 Then
udtNMLVCUSTOMDRAW.clrText = RGB(0, 0, 255)
udtNMLVCUSTOMDRAW.clrTextBk = RGB(255, 0, 0) ', 255,
255)
Debug.Print "new FOnt":
' copy OUR copy of the struct back to the memory
address pointed to by lParam
CopyMemory ByVal lparam, udtNMLVCUSTOMDRAW,
Len(udtNMLVCUSTOMDRAW)
End If
' tell windows that we changed the font and do not
allow VB to get this message
WindowProcLV = CDRF_NEWFONT
Exit Function
End If
End Select ' .dwDrawStage
End With ' udtNMLVCUSTOMDRAW.nmcd
End If ' .code = NM_CUSTOMDRAW
End With ' udtNMHDR
End Select ' iMsg
' pass all messages on to VB and then return the value to windows
WindowProcLV = CallWindowProc(g_addProcOld, hwnd, iMsg, wparam,
lparam)
End Function
Public Function FindDetailWindow(ByVal frmhWnd As Long) As Long
' The Detail Window is always the second of three
' windows of class OFormSub.
' 1) Form Header
' 2) Detail
' 3) Footer
Dim hWnd_VSB As Long
Dim hwnd As Long
Dim ctr As Long
ctr = 0
hwnd = frmhWnd
' Let's get first Child Window of the FORM
hWnd_VSB = apiGetWindow(hwnd, GW_CHILD)
' Let's walk through every sibling window of the Form
Do
' Thanks to Terry Kreft for explaining
' why the apiGetParent acll is not required.
' Terry is in a Class by himself!
'If apiGetParent(hWnd_VSB) <> hWnd Then Exit Do
If fGetClassName(hWnd_VSB) = "OFormSub" Then
ctr = ctr + 1
If ctr = 2 Then
FindDetailWindow = hWnd_VSB
Exit Function
End If
End If
' Let's get the NEXT SIBLING Window
hWnd_VSB = apiGetWindow(hWnd_VSB, GW_HWNDNEXT)
' Let's Start the process from the Top again
' Really just an error check
Loop While hWnd_VSB <> 0
' SORRY - This is impossible but there is no Detail Window!
FindDetailWindow = 0
End Function
Public Function FindLVFrameWindow(hWndDetail As Long) As Long
' The Reflector Window is a child of the Detail Section window
' find Detail Section First
'hWndMDI = FindWindowEx(Application.hWndAccessApp, 0&, "MDIClient",
vbNullString)
' Find the Debug Window
FindLVFrameWindow = FindWindowEx(hWndDetail, 0&, CtlMsgWinClass, "")
End Function
Private Function FindOKttbxWindow(ByVal frmhWnd As Long) As Long
' The Detail Window always contains
' one window of class OKttbx.
Dim hWnd_VSB As Long
Dim hwnd As Long
Dim ctr As Long
ctr = 0
hwnd = frmhWnd
' Let's get first Child Window of the FORM
hWnd_VSB = apiGetWindow(hwnd, GW_CHILD)
' Let's walk through every sibling window of the Form
Do
If fGetClassName(hWnd_VSB) = "OKttbx" Then
FindOKttbxWindow = hWnd_VSB
Exit Function
End If
' Let's get the NEXT SIBLING Window
hWnd_VSB = apiGetWindow(hWnd_VSB, GW_HWNDNEXT)
' Let's Start the process from the Top again
' Really just an error check
Loop While hWnd_VSB <> 0
' SORRY - This is impossible but there is no TextBox Window!
FindOKttbxWindow = 0
End Function
' From Dev Ashish's Site
' The Access Web
'
http://www.mvps.org/access/
'******* Code Start *********
Private Function fGetClassName(hwnd As Long)
Dim strBuffer As String
Dim lngLen As Long
Const MAX_LEN = 255
strBuffer = Space$(MAX_LEN)
lngLen = apiGetClassName(hwnd, strBuffer, MAX_LEN)
If lngLen > 0 Then fGetClassName = Left$(strBuffer, lngLen)
End Function
'******* Code End *********
--
HTH
Stephen Lebans
http://www.lebans.com
Access Code, Tips and Tricks
Please respond only to the newsgroups so everyone can benefit.
