Thet is old code for PBWin 9. Anyway, from WinUtils.inc you only need the API_CreateFont function, that I have added.
' ########################################################################################
' Mutiline header ListView example
' The technique used is to process the HDM_LAYOUT message, fill the WINDOWPOS structure
' with the appropriate size and position of the header control, and change the top position
' of the rectangle that the header control will occupy.
' CASE %HDM_LAYOUT
' LOCAL phdl AS HDLAYOUT PTR
' phdl = lParam
' @phdl.@pwpos.hwnd = hwnd
' @phdl.@pwpos.flags = %SWP_FRAMECHANGED
' @phdl.@pwpos.x = @phdl.@prc.nLeft
' @phdl.@pwpos.y = 0
' @phdl.@pwpos.cx = @phdl.@prc.nRight - @phdl.@prc.nLeft
' @phdl.@pwpos.cy = 40 ' --> change me
' @phdl.@prc.nTop = 40 ' --> change me
' FUNCTION = -1
' EXIT FUNCTION
' ########################################################################################
#COMPILE EXE
#DIM ALL
%USEMACROS = 1 ' // Use macros
#INCLUDE ONCE "CWindow.inc" ' // CWindow class
#INCLUDE ONCE "ListViewCtrl.inc" ' // ListView control wrapper functions
#INCLUDE ONCE "HeaderCtrl.inc" ' // Header control wrapper functions
'#INCLUDE ONCE "WinUtils.inc" ' // Miscellaneous wrapper functions
%IDC_LISTVIEW = 101
' ========================================================================================
' Creates a logical font.
' Examples of Use:
' hFont = API_CreateFont("MS Sans Serif", 8, %FW_NORMAL, %FALSE, %FALSE, %FALSE, %DEFAULT_CHARSET)
' hFont = API_CreateFont("Courier New", 10, %FW_BOLD, %FALSE, %FALSE, %FALSE, %DEFAULT_CHARSET)
' hFont = API_CreateFont("Marlett", 8, %FW_NORMAL, %FALSE, %FALSE, %FALSE, %SYMBOL_CHARSET)
' Note: Any font created with API_CreateFont must be destroyed with DeleteObject when no
' longer needed to prevent memory leaks.
' ========================================================================================
#IF %DEF(%USEMACROS)
MACRO FUNCTION API_CreateFont (sFaceName, lPointSize, lWeight, bItalic, bUnderline, bStrikeOut, bCharSet)
MACROTEMP tlf, hDC, szFaceName
LOCAL tlf AS LOGFONT
LOCAL hDC AS DWORD
LOCAL szFaceName AS ASCIIZ * 256
szFaceName = sFaceName
hDC = GetDC(%HWND_DESKTOP)
tlf.lfHeight = -MulDiv(lPointSize, GetDeviceCaps(hDC, %LOGPIXELSY), 72) ' logical font height
tlf.lfWidth = 0 ' average character width
tlf.lfEscapement = 0 ' escapement
tlf.lfOrientation = 0 ' orientation angles
tlf.lfWeight = lWeight ' font weight
tlf.lfItalic = bItalic ' italic(TRUE/FALSE)
tlf.lfUnderline = bUnderline ' underline(TRUE/FALSE)
tlf.lfStrikeOut = bStrikeOut ' strikeout(TRUE/FALSE)
tlf.lfCharSet = bCharset ' character set
tlf.lfOutPrecision = %OUT_TT_PRECIS ' output precision
tlf.lfClipPrecision = %CLIP_DEFAULT_PRECIS ' clipping precision
tlf.lfQuality = %DEFAULT_QUALITY ' output quality
tlf.lfPitchAndFamily = %FF_DONTCARE ' pitch and family
tlf.lfFaceName = szFaceName ' typeface name
ReleaseDC %HWND_DESKTOP, hDC
END MACRO = CreateFontIndirect(tlf)
#ELSE
FUNCTION API_CreateFont ( _
BYREF szFaceName AS ASCIIZ, _ ' __in Typeface name of font
BYVAL lPointSize AS LONG, _ ' __in Point size
BYVAL lWeight AS LONG, _ ' __in Font weight(bold etc.)
BYVAL bItalic AS BYTE, _ ' __in TRUE = italic
BYVAL bUnderline AS BYTE, _ ' __in TRUE = underline
BYVAL bStrikeOut AS BYTE, _ ' __in TRUE = strikeout
BYVAL bCharSet AS BYTE _ ' __in character set
) AS DWORD ' Handle of font or NULL on failure.
LOCAL tlf AS LOGFONT
LOCAL hDC AS DWORD
hDC = GetDC(%HWND_DESKTOP)
tlf.lfHeight = -MulDiv(lPointSize, GetDeviceCaps(hDC, %LOGPIXELSY), 72) ' logical font height
tlf.lfWidth = 0 ' average character width
tlf.lfEscapement = 0 ' escapement
tlf.lfOrientation = 0 ' orientation angles
tlf.lfWeight = lWeight ' font weight
tlf.lfItalic = bItalic ' italic(TRUE/FALSE)
tlf.lfUnderline = bUnderline ' underline(TRUE/FALSE)
tlf.lfStrikeOut = bStrikeOut ' strikeout(TRUE/FALSE)
tlf.lfCharSet = bCharset ' character set
tlf.lfOutPrecision = %OUT_TT_PRECIS ' output precision
tlf.lfClipPrecision = %CLIP_DEFAULT_PRECIS ' clipping precision
tlf.lfQuality = %DEFAULT_QUALITY ' output quality
tlf.lfPitchAndFamily = %FF_DONTCARE ' pitch and family
tlf.lfFaceName = szFaceName ' typeface name
ReleaseDC %HWND_DESKTOP, hDC
FUNCTION = CreateFontIndirect(tlf)
END FUNCTION
#ENDIF
' ========================================================================================
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WINMAIN (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, BYVAL lpszCmdLine AS ASCIIZ PTR, BYVAL nCmdShow AS LONG) AS LONG
' // Create an instance of the class
LOCAL pWindow AS IWindow
pWindow = CLASS "CWindow"
IF ISNOTHING(pWindow) THEN EXIT FUNCTION
' // Create the main window
LOCAL hwnd AS DWORD
hwnd = pWindow.CreateWindow(%NULL, "Multiline Header ListView", 0, 0, 640, 350, -1, -1, CODEPTR(WindowProc))
' // Add a subclassed ListView control
LOCAL hListView AS DWORD
LOCAL rc AS RECT
GetClientRect hwnd, rc
LOCAL dwStyle AS DWORD
dwStyle = %WS_CHILD OR %WS_VISIBLE OR %LVS_REPORT OR %LVS_SINGLESEL OR %LVS_SHOWSELALWAYS
hListView = pWindow.AddListView(hwnd, %IDC_LISTVIEW, "", 0, 0, 0, 0, dwStyle, -1, CODEPTR(ListView_SubclassProc))
' // Add some extended styles
LOCAL dwExStyle AS DWORD
dwExStyle = ListView_GetExtendedListViewStyle(hListView)
dwExStyle = dwExStyle OR %LVS_EX_FULLROWSELECT OR %LVS_EX_GRIDLINES
ListView_SetExtendedListViewStyle(hListView, dwExStyle)
' // Get the handle of the ListView header control and subclass it
LOCAL hLvHeader AS DWORD
hLvHeader = ListView_GetHeader(hListView)
IF hLvHeader THEN SetProp hLvHeader, "OLDWNDPROC", SetWindowLong(hLvHeader, %GWL_WNDPROC, CODEPTR(ListViewHeader_SubclassProc))
' // Add the header's column names
ListView_AddColumn(hListView, 0, "Customer" & $CRLF & "number", 80, 1)
ListView_AddColumn(hListView, 1, "Name" & $CRLF & "First, last", 160, 0)
ListView_AddColumn(hListView, 2, "Telephone" & $CRLF & "number", 160, 0)
ListView_AddColumn(hListView, 3, "Street" & $CRLF & "address", 80, 0)
ListView_AddColumn(hListView, 4, "Action" & $CRLF & "items", 80, 1)
ListView_AddColumn(hListView, 5, "Hobby" & $CRLF & "Kind-of", 80, 0)
' // Populate the ListView with some data
ListView_AddItem(hListView, 0, 0, "1")
ListView_SetItemText(hListView, 0, 1, "Doe, John")
ListView_SetItemText(hListView, 0, 2, "(000) 000-0000")
ListView_SetItemText(hListView, 0, 3, "No name")
ListView_SetItemText(hListView, 0, 4, "Unknown")
ListView_SetItemText(hListView, 0, 5, "Camaro")
ListView_AddItem(hListView, 1, 0, "2")
ListView_SetItemText(hListView, 1, 1, "Smith, Joe")
ListView_SetItemText(hListView, 1, 2, "(111) 111-1111")
ListView_SetItemText(hListView, 1, 3, "No name")
ListView_SetItemText(hListView, 1, 4, "Unknown")
ListView_SetItemText(hListView, 1, 5, "Wife")
ListView_AddItem(hListView, 2, 0, "3")
ListView_SetItemText(hListView, 2, 1, "James, Jessie")
ListView_SetItemText(hListView, 2, 2, "(232) 999-2345")
ListView_SetItemText(hListView, 2, 3, "Victory Place")
ListView_SetItemText(hListView, 2, 4, "Unknown")
ListView_SetItemText(hListView, 2, 5, "R400XP")
ListView_AddItem(hListView, 3, 0, "4")
ListView_SetItemText(hListView, 3, 1, "Paula Vibes")
ListView_SetItemText(hListView, 3, 2, "(542) 123-4556")
ListView_SetItemText(hListView, 3, 3, "Berliner Platz 100")
ListView_SetItemText(hListView, 3, 4, "Known")
ListView_SetItemText(hListView, 3, 5, "Alicia Keys")
ListView_AddItem(hListView, 4, 0, "5")
ListView_SetItemText(hListView, 4, 1, "Tanja Rüscher")
ListView_SetItemText(hListView, 4, 2, "(2542) 654-45-45656")
ListView_SetItemText(hListView, 4, 3, "Sommerallee 1001")
ListView_SetItemText(hListView, 4, 4, "Known")
ListView_SetItemText(hListView, 4, 5, "Horse with no name")
' ... add more data
' // Force the resizing of the ListView by sending a WM_SIZE message
SendMessage hwnd, %WM_SIZE, 0, 0
' // Default message pump (you can replace it with your own)
pWindow.DoEvents
END FUNCTION
' ########################################################################################
' ========================================================================================
' Main callback function.
' ========================================================================================
FUNCTION WindowProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
LOCAL rc AS RECT
SELECT CASE uMsg
CASE %WM_COMMAND
SELECT CASE LO(WORD, wParam)
CASE %IDCANCEL
IF HI(WORD, wParam) = %BN_CLICKED THEN
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END IF
END SELECT
CASE %WM_SIZE
' // Resize the ListView control
IF wParam <> %SIZE_MINIMIZED THEN
GetClientRect hwnd, rc
MoveWindow GetDlgItem(hwnd, %IDC_LISTVIEW), 2, 2, rc.nRight - rc.nLeft + 160, rc.nBottom - rc.nTop + 160, %TRUE
END IF
CASE %WM_DESTROY
' // Close the main window
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
' ========================================================================================
' Processes messages for the subclassed ListView header control.
' ========================================================================================
FUNCTION ListViewHeader_SubclassProc ( _
BYVAL hwnd AS DWORD, _ ' // Control window handle
BYVAL uMsg AS DWORD, _ ' // Type of message
BYVAL wParam AS DWORD, _ ' // First message parameter
BYVAL lParam AS LONG _ ' // Second message parameter
) AS LONG
' // REQUIRED: Get the address of the original window procedure
LOCAL pOldWndProc AS DWORD
pOldWndProc = GetProp(hwnd, "OLDWNDPROC")
SELECT CASE uMsg
CASE %WM_DESTROY
' // REQUIRED: Remove control subclassing
SetWindowLong hwnd, %GWL_WNDPROC, RemoveProp(hwnd, "OLDWNDPROC")
CASE %HDM_LAYOUT
' // Fill the WINDOWPOS structure with the appropriate size and position of the
' // header control and change the top position of the rectangle that the header
' // control will occupy.
LOCAL phdl AS HDLAYOUT PTR
phdl = lParam
@phdl.@pwpos.hwnd = hwnd
@phdl.@pwpos.flags = %SWP_FRAMECHANGED
@phdl.@pwpos.x = @phdl.@prc.nLeft
@phdl.@pwpos.y = 0
@phdl.@pwpos.cx = @phdl.@prc.nRight-80 - @phdl.@prc.nLeft-80
@phdl.@pwpos.cy = 60'40 ' --> change me
@phdl.@prc.nTop = 60'40 ' --> change me
FUNCTION = -1
EXIT FUNCTION
END SELECT
FUNCTION = CallWindowProc(pOldWndProc, hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
' ========================================================================================
' Processes messages for the subclassed ListView control.
' ========================================================================================
FUNCTION ListView_SubclassProc ( _
BYVAL hwnd AS DWORD, _ ' // Control window handle
BYVAL uMsg AS DWORD, _ ' // Type of message
BYVAL wParam AS DWORD, _ ' // First message parameter
BYVAL lParam AS LONG _ ' // Second message parameter
) AS LONG
' // REQUIRED: Get the address of the original window procedure
LOCAL pOldWndProc AS DWORD
pOldWndProc = GetProp(hwnd, "OLDWNDPROC")
SELECT CASE uMsg
CASE %WM_DESTROY
' // REQUIRED: Remove control subclassing
SetWindowLong hwnd, %GWL_WNDPROC, RemoveProp(hwnd, "OLDWNDPROC")
CASE %WM_NOTIFY
LOCAL pnmh AS NMHDR PTR
LOCAL pnmcd AS NMCUSTOMDRAW PTR
LOCAL szText AS ASCIIZ * 260
pnmh = lParam
SELECT CASE @pnmh.code
CASE %NM_CUSTOMDRAW
pnmcd = lParam
' // Check the drawing stage
SELECT CASE @pnmcd.dwDrawStage
' // Prior to painting
CASE %CDDS_PREPAINT
' // Tell Windows we want individual notification of each item being drawn
FUNCTION = %CDRF_NOTIFYITEMDRAW
EXIT FUNCTION
' // Notification of each item being drawn
CASE %CDDS_ITEMPREPAINT
LOCAL hLvHeader AS DWORD
LOCAL nIndex AS DWORD
LOCAL nState AS DWORD
nIndex = @pnmcd.dwItemSpec
nState = @pnmcd.uItemState
' // Get the header item text...
LOCAL hdi AS HDITEM
hdi.mask = %HDI_TEXT
hdi.psztext = VARPTR(szText)
hdi.cchtextmax = SIZEOF(szText)
hLvHeader = ListView_GetHeader(hwnd)
Header_GetItem(hLvHeader, nIndex, hdi)
' // Create a new font
LOCAL hFont AS DWORD
hFont = API_CreateFont("Trebuchet", 10, %FW_BOLD, %FALSE, %FALSE, %FALSE, %DEFAULT_CHARSET)
' // Select the font into the current devide context
LOCAL hOldFont AS DWORD
hOldFont = SelectObject(@pnmcd.hdc, hFont)
' // Draw the button state...
IF (nState AND %CDIS_SELECTED) THEN
DrawFrameControl @pnmcd.hdc, @pnmcd.rc, %DFC_BUTTON, %DFCS_BUTTONPUSH OR %DFCS_PUSHED
ELSE
DrawFrameControl @pnmcd.hdc, @pnmcd.rc, %DFC_BUTTON, %DFCS_BUTTONPUSH
END IF
' // Paint the background
LOCAL hBrush AS DWORD
hBrush = CreateSolidBrush(RGB(200,168,255))'- (228,120,51))
InflateRect @pnmcd.rc, -2, -2
FillRect @pnmcd.hdc, @pnmcd.rc, hBrush
SetBkMode @pnmcd.hdc, %TRANSPARENT
' // Change your text color here...
SetTextColor @pnmcd.hdc, RGB(192,60,140) 'RGB(92,51,23)
' // Offset the text slightly if depressed...
IF (nState AND %CDIS_SELECTED) THEN InflateRect @pnmcd.rc, -2, -2
' // Draw multiline, using CRLF (i.e. szText = "Customer" & $CRLF & "number")
DrawText @pnmcd.hdc, szText, LEN(szText), @pnmcd.rc, %DT_CENTER OR %DT_VCENTER 'OR %DT_WORDBREAK
' // Draw multiline using word wrap (i.e. szText = "Customer number")
'DrawText @pnmcd.hdc, szText, LEN(szText), @pnmcd.rc, %DT_CENTER OR %DT_VCENTER OR %DT_WORDBREAK
' // Sraw single line with ellipsis... (i.e. szText = "Customer number")
'DrawText @pnmcd.hdc, szText, LEN(szText), @pnmcd.rc, %DT_CENTER OR %DT_VCENTER OR %DT_END_ELLIPSIS
' // Cleanup
IF hBrush THEN DeleteObject hBrush
IF hOldFont THEN SelectObject @pnmcd.hdc, hOldFont
IF hFont THEN DeleteObject hFont
' // Tell Windows the item has already been drawn
FUNCTION = %CDRF_SKIPDEFAULT
EXIT FUNCTION
END SELECT
END SELECT
END SELECT
FUNCTION = CallWindowProc(pOldWndProc, hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
