Hello Jose
i have translated your Multiline header listview from PB to O2 , but couldn't get it to run
can you please help me ? its O2 program can be compile without errors but when running it , it will GPF !
this is the PB program LV MHd.bas
' List view with multiline header DDT
' http://www.powerbasic.com/support/pbforums/showthread.php?t=49485&page=2
' Thanks to Jose
' Modified to be without PBForms Oct 22 2018
#COMPILE EXE
#DIM ALL
' Added statusbar
#INCLUDE "Win32API.inc"
#INCLUDE "CommCtrl.inc"
' comment out if do not want multiline column header ***********
#INCLUDE "MultiLineHD2.inc"
%IDC_ListView = 1040
%IDC_Statusbar = 1060
%Unicode=1
GLOBAL CurrentRow,CurrentCol AS LONG
GLOBAL hListView, hDlg AS DWORD
'====================================
FUNCTION PBMAIN() AS LONG
DIALOG NEW PIXELS, 0, "Multiline Header ListView",,,400,360,_
%WS_BORDER OR %WS_SYSMENU OR _
%WS_VISIBLE OR %WS_CLIPCHILDREN OR %SS_GRAYFRAME _
OR %DS_3DLOOK OR %DS_NOFAILCREATE OR %DS_SETFONT _
OR %WS_EX_TRANSPARENT , _
%WS_EX_LEFT OR %WS_EX_LTRREADING OR _
%WS_EX_RIGHTSCROLLBAR, TO hDlg
CONTROL ADD LISTVIEW, hDlg, %IDC_ListView,"", 10,10,360,220 ,_
%WS_TABSTOP OR %WS_VISIBLE OR _
%WS_BORDER OR %LVS_REPORT OR _
%LVS_SINGLESEL OR %LVS_EX_DOUBLEBUFFER, _
%WS_EX_CLIENTEDGE
LISTVIEW SET STYLEXX hDlg, %IDC_ListView, %LVS_EX_GRIDLINES _
OR %LVS_EX_FULLROWSELECT
CONTROL HANDLE hDlg, %IDC_ListView TO hListView
' Shade those unused portions of the main ListView to greenish gray
CONTROL HANDLE hDlg, %IDC_LISTVIEW TO hListView
SendMessage(hListView, %LVM_SETBKCOLOR, 0, RGB(103,196,52))
' comment out if do not want multiline column header ****************
' Subclass the ListView
SetProp hListView, "OLDWNDPROC", _
SetWindowLong(hListView, %GWL_WNDPROC, CODEPTR(ListView_SubclassProc))
' comment out if do not want multiline column header *************
' 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))
END IF
' Draw the headers
' Note that the number after the description string is the column size
LISTVIEW INSERT COLUMN hDlg, %IDC_ListView, 1, "Column1" + $CRLF + "2nd Line", 100, 0
LISTVIEW INSERT COLUMN hDlg, %IDC_ListView, 2, "Column2" + $CRLF + "Special 2nd line", 150, 0
LISTVIEW INSERT COLUMN hDlg, %IDC_ListView, 3, "Column3", 100, 0
' Load sample data.
LOCAL lCol, i AS LONG
FOR i = 1 TO 300
LISTVIEW INSERT ITEM hDlg, %IDC_ListView, i, 0, USING$("Column # Row #", lCol, i)
FOR lCol = 1 TO 3
LISTVIEW SET TEXT hDlg, %IDC_ListView, i, lCol, USING$("Column # Row #", lCol, i)
NEXT lCol
NEXT i
CONTROL ADD STATUSBAR, hdlg, %IDC_StatusBar, "", 0,0,0,0,%CCS_BOTTOM,%WS_EX_WINDOWEDGE
STATUSBAR SET PARTS hDlg, %IDC_StatusBar, 95,99999
DIALOG SHOW MODAL hDlg CALL DlgProc
END FUNCTION
'=============================================
CALLBACK FUNCTION DlgProc() AS LONG
LOCAL LpLvNm AS NM_LISTVIEW PTR
LOCAL NMLV AS NMLISTVIEW
SELECT CASE CB.MSG
CASE %WM_SIZE
' Resize the ListView control and its header
IF CB.WPARAM <> %SIZE_MINIMIZED THEN
' This resolves the scrolling up or non stationary statusbar problem
' Subtract statusbar height from the HI(WORD, CB.LPARAM) height parts
' to compensate for the height of the large multi line header
LOCAL wsb, hsb AS LONG
' get the width and height of the statusbar
CONTROL GET SIZE hdlg, %IDC_StatusBar TO wsb, hsb
MoveWindow hListView, 0, 0, LO(WORD, CB.LPARAM), _
HI(WORD, CB.LPARAM) - hsb, %TRUE
END IF
CASE %WM_NOTIFY
IF CB.NMID = %IDC_LISTVIEW THEN ' ListView Notifications
' Obtain the NM_LISTVIEW UDT
TYPE SET NMLV = CB.NMHDR$(SIZEOF(NMLV))
SELECT CASE NMLV.hdr.code
CASE %NM_CLICK
' click
LpLvNm = CB.LPARAM
CurrentRow = @LpLvNm.iiTem + 1
CurrentCol = @LpLvNm.iSubItem + 1
UpdateStatusBar
END SELECT
END IF
END SELECT
END FUNCTION
'=====================
' The status bar displaying the current position of cursor
' and help text for each column
SUB UpdateStatusBar
STATUSBAR SET TEXT hDlg, %IDC_StatusBar, 1, 0, " Row " + _
FORMAT$(CurrentRow,"##0") + _
" : Col " + FORMAT$(CurrentCol,"#0")
' Help text for each column when a particular column is clicked
SELECT CASE CurrentCol
CASE 1
STATUSBAR SET TEXT hDlg, %IDC_StatusBar, 2, &H0200, " Enter characters only"
CASE 2
STATUSBAR SET TEXT hDlg, %IDC_StatusBar, 2, &H0200, " Enter numbers only "
CASE 3
STATUSBAR SET TEXT hDlg, %IDC_StatusBar, 2, &H0200, " Enter Alphanumeric here"
END SELECT
END SUB
and its MultiLineHD2.inc
' MultiLineHD2.inc
' MultiLine Header routines
' PBForms.inc is now eliminated Oct 22 2018
' as font is created using the API_CreateFont() function
'#INCLUDE "PBForms.inc"
' ========================================================================================
' 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.
'==============================
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
' ========================================================================================
' 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
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 - @phdl.@prc.nLeft
@phdl.@pwpos.cy = 40 ' --> change me
@phdl.@prc.nTop = 40 ' --> change me
FUNCTION = -1
EXIT FUNCTION
END SELECT
FUNCTION = CallWindowProc(GetProp(hwnd, "OLDWNDPROC"), 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 ' ASCIIZ WSTRINGZ * 260 (note that original uses ASCIIZ)
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 HD_ITEM
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 = PBFormsMakeFont("Tahoma", 10, _
' %FW_BOLD, %FALSE, %FALSE, %FALSE, %DEFAULT_CHARSET)
hFont = API_CreateFont("Tahoma", 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
' Color the header background
LOCAL hBrush AS DWORD
hBrush = CreateSolidBrush(RGB(243,250,5)) ' <------------ Change color
InflateRect @pnmcd.rc, -2, -2
FillRect @pnmcd.hdc, @pnmcd.rc, hBrush
SetBkMode @pnmcd.hdc, %TRANSPARENT
' Color the header text
SetTextColor @pnmcd.hdc, RGB(40,45,215) ' <------------ Change color
' Offset the text slightly if depressed...
IF (nState AND %CDIS_SELECTED) THEN
InflateRect @pnmcd.rc, -2, -2
END IF
' Draw multiline, using CRLF (i.e. szText = "Customer" & $CRLF & "number")
DrawText @pnmcd.hdc, szText, LEN(szText), @pnmcd.rc, %DT_CENTER OR %DT_VCENTER
' Cleanup
IF hBrush THEN
DeleteObject hBrush
END IF
IF hOldFont THEN
SelectObject @pnmcd.hdc, hOldFont
END IF
IF hFont THEN
DeleteObject hFont
END IF
' 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
and this is O2 program ColorListView_MH.o2bas
'====================================================================
' Color Listview example modified Nov 4 2018
' which you can change fonts and color of text and background
' with Multi Line Header
'====================================================================
$ filename "ColorListView_MH.exe"
use rtl64
#lookahead
uses dialogs
uses O2Common
'Identifier for ListView
#define IDC_LSV1 4001
' The program logo icon is obtained from the resource file
' the 1000 must corespondence to the 1000 in the rc file
#define IDI_LOGO 1000
% ICON_BIG=1
% WM_SETICON=0x80
macro ListView_InsertColumn(hwnd,iCol,pcol) (SendMessage(hwnd, LVM_INSERTCOLUMN, iCol, pcol))
macro ListView_SetColumnWidth(hwnd,iCol,cx) (SendMessage(hwnd, LVM_SETCOLUMNWIDTH, iCol, cx))
macro ListView_InsertItem(hwnd,pitem) (SendMessage(hwnd, LVM_INSERTITEM,0, pitem))
macro ListView_SetItem(hwnd,pitem) (SendMessage(hwnd, LVM_SETITEM,0, pitem))
% DS_CENTER=0x0800
% DS_MODALFRAME=0x80
% SS_CENTERIMAGE=0x200
% LVS_LIST 0x0003
% LVS_REPORT 0x0001
% LVS_EX_GRIDLINES 1
% LVS_EX_CHECKBOXES 4
% LVS_EX_FULLROWSELECT 0x0020
% LVS_SINGLESEL = 0x0004
% LVS_EX_DOUBLEBUFFER = 0x0010000
% LVSCW_AUTOSIZE -1
% LVSCW_AUTOSIZE_USEHEADER -2
% LVM_INSERTCOLUMN=4123
% LVM_SETCOLUMNWIDTH=4126
% LVM_INSERTITEM=4103
% LVM_SETITEM=4102
% LVCF_FMT 1
% LVCF_WIDTH 2
% LVCF_TEXT=4
% LVCF_SUBITEM 8
% LVCF_ORDER = 20
% LVIF_TEXT=1
% LVM_SETEXTENDEDLISTVIEWSTYLE 0x1036
% LVN_COLUMNCLICK = -108
% LVN_ITEMCHANGED = -101
% LR_LOADFROMFILE=0x0010
% IMAGE_ICON=1
% STM_SETIMAGE=0x172
% SWP_NOZORDER=4
' ListView messages
% LVM_FIRST = &H1000
% LVM_SETBKCOLOR = (LVM_FIRST + 1)
% LVM_SETTEXTCOLOR = LVM_FIRST + 36
% LVM_GETHEADER = LVM_FIRST + 31
% CLR_NONE = &HFFFFFFFF&
% GWLP_WNDPROC= -4
type LVCOLUMN
uint mask
int fmt
int cx
char* pszText
int cchTextMax
int iSubItem
int iImage
int iOrder
int cxMin
int cxDefault
int cxIdeal
end type
typedef LVCOLUMN LV_COLUMN
type LVITEM
uint mask
int iItem
int iSubItem
uint state
uint stateMask
char* pszText
int cchTextMax
int iImage // index of the list view item's icon
sys lParam // 32-bit value to associate with item
int iIndent
int iGroupId
uint cColumns
uint *puColumns
int *piColFmt
int iGroup
end type
typedef LVITEM LV_ITEM
' Number of rows in the ListView
% NumRow = 200
' Number of columns in the ListView meaning 3 +1 = 4 columns
% NumCol = 3
! GetDlgItem lib "user32.dll" (sys hDlg, int nIDDlgItem) as sys
! IsDialogMessage lib "user32.dll" alias"IsDialogMessageA" (sys hDlg, sys lpMsg) as bool
! IsWindow lib "user32.dll" (sys hWnd) as bool
uses MultiLineHDO2
' Handle for the Main Dialog
sys hDlg
' Fonts
sys hFont
'====================================================================
' Main callback function
Function DlgProc( hDlg,uint uMsg, sys wParam, lParam ) as sys callback
int i , j
string txtStr
' Handle for the ListView
sys hListview = GetDlgItem(hDlg, IDC_LSV1)
LV_COLUMN lvc
LV_ITEM lvi
select case uMsg
case WM_INITDIALOG
' display the program icon
sys hInstance = GetModuleHandle(NULL)
sys hIcon = LoadIcon(hInstance, IDI_Logo)
'Set Icon to Main Window
SendMessage(hDlg, WM_SETICON, ICON_BIG, hIcon)
' Setup the fonts for the ListView
SendMessage(hListview,%WM_SETFONT,hFont,0)
' Subclass the ListView
SetProp hListView, "OLDWNDPROC", _
SetWindowLongPtr(hListView, GWLP_WNDPROC, @ListView_SubclassProc)
' Get the handle of the ListView header control and subclass it
sys hLvHeader
hLvHeader = ListView_GetHeader(hListView)
IF hLvHeader THEN
SetProp hLvHeader, "OLDWNDPROC", _
SetWindowLongPtr(hLvHeader, GWLP_WNDPROC, @LVHeader_SubclassProc)
END IF
'Setup the ListView Column Headers
' The first column must have a wider width to accomodate the checkbox
lvc.mask = LVCF_WIDTH or LVCF_ORDER
' Need to add some blanks behind the header string label
' inorder to get a wider column
txtStr="Column #" & str(1) + " " +cr
lvc.pszText = txtStr
lvc.iorder = 0
ListView_InsertColumn(hListview, 0, &lvc)
' All the other columns to have a narrower width
For i = 1 To NumCol
lvc.mask = LVCF_FMT OR LVCF_WIDTH OR LVCF_TEXT OR LVCF_SUBITEM
If i = NumCol then
' Leave the last column header blank as we are NOT putting data
' into this last column ( it act like a buffer )
txtStr = ""
Else
txtStr="Column #" & str(i+1) + cr + " level2 "
txtStr = Trim(txtStr)
End if
lvc.pszText = txtStr
lvc.iorder = i
ListView_InsertColumn(hListview, i, &lvc)
Next i
' Setup the Listview data Rows
For i=1 To NumRow
'First column
lvi.mask = LVIF_TEXT
txtStr = "Row #" & str(200-i+1) ", Col # 1"
lvi.pszText = txtStr
lvi.iSubItem = 0
ListView_InsertItem(hListview, &lvi)
'Remaining columns
for j=2 to NumCol
txtStr = "Row #" & str(200-i+1) ", Col # " & str(j)
lvi.pszText = txtStr
lvi.iSubItem = j-1
ListView_SetItem(hListview, &lvi)
next j
Next i
' Set the column widths according to width of each column header
for i = 0 to NumCol -1
ListView_SetColumnWidth(hListview,i,LVSCW_AUTOSIZE_USEHEADER)
next i
' make the last column a very narrow width as it is only a buffer column
' this would display as a double line
ListView_SetColumnWidth(hListview,NumCol,3)
' Place in the extended style for the listview
SendMessage(hListview, LVM_SETEXTENDEDLISTVIEWSTYLE, 0,
LVS_EX_FULLROWSELECT or LVS_EX_CHECKBOXES or LVS_EX_GRIDLINES )
' Shade those unused background portions of the main ListView to Alice Blue
' while the text color is Navy
SendMessage(hListView, LVM_SETTEXTCOLOR, 0,RGB(0,0,128))
SendMessage(hListView, LVM_SETBKCOLOR, 0,RGB(240,248,255))
case WM_COMMAND
select case loword(wParam)
case IDCANCEL
' exit
DeleteObject(hFont)
DestroyWindow( hDlg )
end select
case WM_NOTIFY
NMHDR pnm at lParam
if pnm.hwndFrom = hListview then
'ListView
select case pnm.code
case LVN_COLUMNCLICK
mbox "LVN_COLUMNCLICK"
case LVN_ITEMCHANGED
end select
end if
case WM_SIZE
RECT rcClient
// Calculate remaining height and size edit
GetClientRect(hDlg, &rcClient)
SetWindowPos(hListview, NULL, 0, rcClient.top, rcClient.right, rcClient.bottom, SWP_NOZORDER)
case WM_CLOSE
DestroyWindow( hDlg )
case WM_DESTROY
PostQuitMessage( null )
end select
return 0
end function
'====================================================================
' Display the Main Dialog
Function DispMainDialog
sys lpdt
MSG wMsg
dyn::init(lpdt)
Dialog( 1, 10,10,250,250, "Listview example 64bits ", lpdt,
WS_OVERLAPPEDWINDOW or DS_CENTER or WS_VISIBLE,
8,"MS Sans Serif" )
' Add in the listview
CONTROL "",IDC_LSV1,"SysListView32", _
WS_VISIBLE or WS_TABSTOP or WS_BORDER or LVS_REPORT or LVS_SINGLESEL or LVS_EX_DOUBLEBUFFER , _
10,10,233,100, WS_EX_CLIENTEDGE
hFont = O2ApiCreateFont("Arial",9, FW_Bold)
hDlg = CreateModelessDialog( 0, @DlgProc, 0, lpdt )
while GetMessage( @wMsg, null, 0, 0 ) <> 0
if IsDialogMessage( hDlg, @wMsg ) = 0 then
TranslateMessage( @wMsg )
DispatchMessage( @wMsg )
end if
wend
End Function
'------------------------------------
' Start of program
init_common_controls()
DispMainDialog
and its MultiLineHDO2.inc
' MultiLineHDO2.inc
' MultiLine Header routines for O2
' Updated : Nov 4 2018
Type WINDOWPOS
hwnd As sys
hWndInsertAfter As sys
x As Long
y As Long
cx As Long
cy As Long
flags As Long
End Type
' // Size = 8 bytes
TYPE HD_LAYOUT
RECT PTR prc ' RECT *prc
WINDOWPOS PTR pwpos ' WINDOWPOS *pwpos
END TYPE
TYPE NMCUSTOMDRAW
hdr AS NMHDR ' NMHDR hdr
dwDrawStage AS sys ' DWORD dwDrawStage
hdc AS sys ' HDC hdc
rc AS RECT ' RECT rc
dwItemSpec AS sys ' DWORD_PTR dwItemSpec // this is control specific, but it's how to specify an item. valid only with CDDS_ITEM bit set
uItemState AS sys ' UINT uItemState
lItemlParam AS LONG ' LPARAM lItemlParam
END TYPE
TYPE HD_ITEM
Mask AS sys ' UINT mask
cxy AS LONG ' int cxy
pszText AS ASCIIZ PTR ' LPSTR pszText
hbm AS sys ' HBITMAP hbm
cchTextMax AS LONG ' int cchTextMax
fmt AS LONG ' int fmt
lParam AS LONG ' LPARAM lParam
iImage AS LONG ' int iImage // index of bitmap in ImageList
iOrder AS LONG ' int iOrder // where to draw this item
pvFilter AS sys ' void * pvFilter // [in] fillter data see above
state AS sys
END TYPE
% SWP_FRAMECHANGED = &H20
% CDRF_NOTIFYITEMDRAW = &H20
% CDRF_SKIPDEFAULT = &H00000004
% HDI_TEXT = &H0002
% CDDS_PREPAINT = &H00000001
% CDDS_ITEM = &H00010000
% CDDS_ITEMPREPAINT = CDDS_ITEM OR CDDS_PREPAINT
% NM_FIRST = 0
% NM_CUSTOMDRAW = NM_FIRST - 12
% HDM_FIRST = &H1200
% HDM_LAYOUT = HDM_FIRST + 5
% HDM_GETITEMW = HDM_FIRST + 11
% DT_CENTER = &H00000001
% DT_VCENTER = &H00000004
'// itemState flags
% CDIS_SELECTED = &H0001
% DFC_BUTTON = 4
% DFCS_BUTTONPUSH = &H0010
% DFCS_PUSHED = &H00000200
' ========================================================================================
' Gets the handle to the header control used by a list-view control.
' ========================================================================================
FUNCTION ListView_GetHeader (BYVAL hwndLV AS sys) AS sys
FUNCTION = SendMessage(hwndLV, LVM_GETHEADER, 0, 0)
END FUNCTION
' ========================================================================================
FUNCTION Header_GetItemW (BYVAL hwndHD AS sys, BYVAL iItem AS sys, BYREF phdi AS HD_ITEM) AS LONG
FUNCTION = SendMessageW( hwndHD, HDM_GETITEMW, iItem, @phdi)
END FUNCTION
' ============================================================================
' Processes messages for the subclassed ListView header control.
FUNCTION LVHeader_SubclassProc( hDlg , uint usMsg , sys wParam , HD_LAYOUT PTR lParam ) AS sys
Long lcx, rcx
SELECT CASE usMsg
CASE WM_DESTROY
' REQUIRED: Remove control subclassing
SetWindowLongPtr hDlg, GWLP_WNDPROC, RemoveProp(hDlg, "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.
HD_LAYOUT PTR phdl
phdl = lParam
@phdl.pwpos.hwnd = hDlg
@phdl.pwpos.flags = SWP_FRAMECHANGED
lcx = 10 ' @phdl.prc.nLeft
rcx = 242 ' @phdl.prc.nRight
@phdl.pwpos.x = lcx
@phdl.pwpos.y = 0
@phdl.pwpos.cx = rcx - lcx
@phdl.pwpos.cy = 40 ' --> change me
' @phdl.prc.nTop = 40 ' --> change me
FUNCTION = -1
EXIT FUNCTION
END SELECT
FUNCTION = CallWindowProc(GetProp(hDlg, "OLDWNDPROC"), hDlg, usMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
' Processes messages for the subclassed ListView control.
FUNCTION ListView_SubclassProc ( _
BYVAL hDlg AS sys, _
BYVAL utMsg AS uint, _
BYVAL wParam AS sys, _
BYVAL lParam AS NMCUSTOMDRAW PTR ) AS sys
' REQUIRED: Get the address of the original window procedure
sys pOldWndProc
pOldWndProc = GetProp(hDlg, "OLDWNDPROC")
SELECT CASE utMsg
CASE WM_DESTROY
' REQUIRED: Remove control subclassing
SetWindowLongPtr hDlg, GWLP_WNDPROC, RemoveProp(hDlg, "OLDWNDPROC")
CASE WM_NOTIFY
NMHDR PTR pnmh
NMCUSTOMDRAW PTR pnmcd
string szText
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
sys hLvHeader
sys nIndex
sys nState
nIndex = @pnmcd.dwItemSpec
nState = @pnmcd.uItemState
' Get the header item text...
HD_ITEM hdi
hdi.mask = HDI_TEXT
hdi.pszText = VARPTR(szText)
hdi.cchtextmax = SIZEOF(szText)
hLvHeader = ListView_GetHeader(hDlg)
Header_GetItemW(hLvHeader, nIndex, hdi)
' Create a new font
sys hFont
hFont = O2ApiCreateFont("Tahoma", 10, FW_BOLD)
' Select the font into the current devide context
sys hOldFont
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
' Color the header background
sys hBrush
hBrush = CreateSolidBrush(RGB(243,250,5)) ' <------------ Change color
InflateRect @pnmcd.rc, -2, -2
FillRect @pnmcd.hdc, @pnmcd.rc, hBrush
SetBkMode @pnmcd.hdc, TRANSPARENT
' Color the header text
SetTextColor @pnmcd.hdc, RGB(40,45,215) ' <------------ Change color
' Offset the text slightly if depressed...
IF (nState AND CDIS_SELECTED) THEN
InflateRect @pnmcd.rc, -2, -2
END IF
' Draw multiline, using CRLF (i.e. szText = "Customer" & $CRLF & "number")
DrawText @pnmcd.hdc, szText, LEN(szText), @pnmcd.rc, DT_CENTER OR DT_VCENTER
' Cleanup
IF hBrush THEN
DeleteObject hBrush
END IF
IF hOldFont THEN
SelectObject @pnmcd.hdc, hOldFont
END IF
IF hFont THEN
DeleteObject hFont
END IF
' Tell Windows the item has already been drawn
FUNCTION = CDRF_SKIPDEFAULT
EXIT FUNCTION
END SELECT
END SELECT
END SELECT
FUNCTION = CallWindowProc(pOldWndProc, hDlg, utMsg, wParam, lParam)
END FUNCTION
And the general common include file O2common.inc
' O2common.inc
' These are the commonly use functions and macros
' Updated : Nov 3 2018
uses Corewin
' Background color for main window
int MainWindBGColor
' Trim function
def Trim ltrim(rtrim(%1))
' Variant pointer
def varptr @ %1
' Carriage return character
string cr = chr(13,10)
' Font Weights
% FW_DONTCARE = 0
% FW_THIN = 100
% FW_EXTRALIGHT = 200
% FW_LIGHT = 300
% FW_NORMAL = 400
% FW_MEDIUM = 500
% FW_SEMIBOLD = 600
% FW_BOLD = 700
% FW_EXTRABOLD = 800
% FW_HEAVY = 900
% LOGPIXELSY 90
% HWND_DESKTOP 0
'===============================
' for displaying the RGB colors
Function RGB(sys red,green,blue) as sys
sys color
color = red
color = color + green*256
color = color + blue*65536
Return color
End Function
'========================================
' draws with color gradient
SUB DrawGradient (BYVAL hDC AS DWORD)
LOCAL rectFill AS RECT, rectClient AS RECT, fStep AS SINGLE
local hBrush AS DWORD, lOnBand AS LONG
GetClientRect WindowFromDC(hDC), rectClient
fStep = rectClient.bottom / 75
FOR lOnBand = 0 TO 50 ' 199
SetRect rectFill, 0, lOnBand * fStep, rectClient.right + 1, (lOnBand + 1) * fStep
' paint the background -- change the first 2 colors R and G
' to vary the color gradient
Select case MainWindBGColor
Case 1
' this gives a light yellow background
hBrush = CreateSolidBrush(rgb(255, 255, 205 - lOnBand))
Case 2
' this gives a cyan background
hBrush = CreateSolidBrush(rgb(0, 248, 255 - lOnBand))
Case 3
' this gives a light green background
hBrush = CreateSolidBrush(rgb(155, 250, 147 - lOnBand))
End Select
Fillrect hDC, rectFill, hBrush
DeleteObject hBrush
NEXT
END SUB
'==============================================================================
Function O2ApiCreateFont(szFaceName As Zstring,Byval lPointSize As long, BYVAL lWeight AS LONG) As sys
Dim tlf As LOGFONT
Dim Fhdc As sys
Dim nNum As long
Fhdc = GetDc(%HWND_DESKTOP)
nNum = GetDeviceCaps(Fhdc, %LOGPIXELSY)
tlf.lfHeight = -MulDiv(lPointSize,nNum , 72)
tlf.lfWidth = 0
tlf.lfEscapement = 0
tlf.lfOrientation = 0
tlf.lfWeight = lWeight
tlf.lfItalic = 0
tlf.lfUnderline = 0
tlf.lfStrikeOut = 0
tlf.lfCharSet = %ANSI_CHARSET
tlf.lfOutPrecision = %OUT_TT_PRECIS
tlf.lfClipPrecision = %CLIP_DEFAULT_PRECIS
tlf.lfQuality = %DEFAULT_QUALITY
tlf.lfPitchAndFamily = %FF_DONTCARE
tlf.lfFaceName = szFaceName
ReleaseDC(%HWND_DESKTOP, Fhdc)
Function = CreateFontIndirect(@tlf)
End Function
here is the zipped file for the problematic O2 program
I alrady have told you that I don't have practice with O2, specially with its unusual use of pointers. Guess that I will have to use the #cpointer directive a lot.
O2 will do all the pointy stuff for you. (And PB's '@' means '*' in FreeBasic and C.)
So this is how it translates:
PB----->>
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 - @phdl.@prc.nLeft
@phdl.@pwpos.cy = 40 ' --> change me
@phdl.@prc.nTop = 40 ' --> change me
FUNCTION = -1
EXIT FUNCTION
O2------->>
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
HDLAYOUT phdl at (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
Thanxx Charles, still not able to compile as error points to phdl.prc.nLeft
which the O2 compiler says it is not defined
could be something to do with these Type codes
TYPE HD_LAYOUT
RECT PTR prc ' RECT *prc
WINDOWPOS PTR pwpos ' WINDOWPOS *pwpos
END TYPE
maybe it cannot handle the RECT PTR prc ?
the amended code for MultiLineHDO2.inc is as below
' MultiLineHDO2.inc
' MultiLine Header routines for O2
' Updated : Nov 4 2018
Type WINDOWPOS
hwnd As sys
hWndInsertAfter As sys
x As Long
y As Long
cx As Long
cy As Long
flags As Long
End Type
' // Size = 8 bytes
TYPE HD_LAYOUT
RECT PTR prc ' RECT *prc
WINDOWPOS PTR pwpos ' WINDOWPOS *pwpos
END TYPE
TYPE NMCUSTOMDRAW
hdr AS NMHDR ' NMHDR hdr
dwDrawStage AS sys ' DWORD dwDrawStage
hdc AS sys ' HDC hdc
rc AS RECT ' RECT rc
dwItemSpec AS sys ' DWORD_PTR dwItemSpec // this is control specific, but it's how to specify an item. valid only with CDDS_ITEM bit set
uItemState AS sys ' UINT uItemState
lItemlParam AS LONG ' LPARAM lItemlParam
END TYPE
TYPE HD_ITEM
Mask AS sys ' UINT mask
cxy AS LONG ' int cxy
pszText AS ASCIIZ PTR ' LPSTR pszText
hbm AS sys ' HBITMAP hbm
cchTextMax AS LONG ' int cchTextMax
fmt AS LONG ' int fmt
lParam AS LONG ' LPARAM lParam
iImage AS LONG ' int iImage // index of bitmap in ImageList
iOrder AS LONG ' int iOrder // where to draw this item
pvFilter AS sys ' void * pvFilter // [in] fillter data see above
state AS sys
END TYPE
% SWP_FRAMECHANGED = &H20
% CDRF_NOTIFYITEMDRAW = &H20
% CDRF_SKIPDEFAULT = &H00000004
% HDI_TEXT = &H0002
% CDDS_PREPAINT = &H00000001
% CDDS_ITEM = &H00010000
% CDDS_ITEMPREPAINT = CDDS_ITEM OR CDDS_PREPAINT
% NM_FIRST = 0
% NM_CUSTOMDRAW = NM_FIRST - 12
% HDM_FIRST = &H1200
% HDM_LAYOUT = HDM_FIRST + 5
% HDM_GETITEMW = HDM_FIRST + 11
% DT_CENTER = &H00000001
% DT_VCENTER = &H00000004
'// itemState flags
% CDIS_SELECTED = &H0001
% DFC_BUTTON = 4
% DFCS_BUTTONPUSH = &H0010
% DFCS_PUSHED = &H00000200
' ========================================================================================
' Gets the handle to the header control used by a list-view control.
' ========================================================================================
FUNCTION ListView_GetHeader (BYVAL hwndLV AS sys) AS sys
FUNCTION = SendMessage(hwndLV, LVM_GETHEADER, 0, 0)
END FUNCTION
' ========================================================================================
FUNCTION Header_GetItemW (BYVAL hwndHD AS sys, BYVAL iItem AS sys, BYREF phdi AS HD_ITEM) AS LONG
FUNCTION = SendMessageW( hwndHD, HDM_GETITEMW, iItem, @phdi)
END FUNCTION
' ============================================================================
' Processes messages for the subclassed ListView header control.
FUNCTION LVHeader_SubclassProc( hDlg , uint usMsg , sys wParam , lParam ) AS sys
Long lcx, rcx
SELECT CASE usMsg
CASE WM_DESTROY
' REQUIRED: Remove control subclassing
SetWindowLongPtr hDlg, GWLP_WNDPROC, RemoveProp(hDlg, "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
HD_LAYOUT phdl at (lparam)
phdl.pwpos.hwnd = hDlg
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
END SELECT
FUNCTION = CallWindowProc(GetProp(hDlg, "OLDWNDPROC"), hDlg, usMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
' Processes messages for the subclassed ListView control.
FUNCTION ListView_SubclassProc ( _
BYVAL hDlg AS sys, _
BYVAL utMsg AS uint, _
BYVAL wParam AS sys, _
BYVAL lParam AS NMCUSTOMDRAW PTR ) AS sys
' REQUIRED: Get the address of the original window procedure
sys pOldWndProc
pOldWndProc = GetProp(hDlg, "OLDWNDPROC")
SELECT CASE utMsg
CASE WM_DESTROY
' REQUIRED: Remove control subclassing
SetWindowLongPtr hDlg, GWLP_WNDPROC, RemoveProp(hDlg, "OLDWNDPROC")
CASE WM_NOTIFY
NMHDR PTR pnmh
NMCUSTOMDRAW PTR pnmcd
string szText
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
sys hLvHeader
sys nIndex
sys nState
nIndex = @pnmcd.dwItemSpec
nState = @pnmcd.uItemState
' Get the header item text...
HD_ITEM hdi
hdi.mask = HDI_TEXT
hdi.pszText = VARPTR(szText)
hdi.cchtextmax = SIZEOF(szText)
hLvHeader = ListView_GetHeader(hDlg)
Header_GetItemW(hLvHeader, nIndex, hdi)
' Create a new font
sys hFont
hFont = O2ApiCreateFont("Tahoma", 10, FW_BOLD)
' Select the font into the current devide context
sys hOldFont
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
' Color the header background
sys hBrush
hBrush = CreateSolidBrush(RGB(243,250,5)) ' <------------ Change color
InflateRect @pnmcd.rc, -2, -2
FillRect @pnmcd.hdc, @pnmcd.rc, hBrush
SetBkMode @pnmcd.hdc, TRANSPARENT
' Color the header text
SetTextColor @pnmcd.hdc, RGB(40,45,215) ' <------------ Change color
' Offset the text slightly if depressed...
IF (nState AND CDIS_SELECTED) THEN
InflateRect @pnmcd.rc, -2, -2
END IF
' Draw multiline, using CRLF (i.e. szText = "Customer" & $CRLF & "number")
DrawText @pnmcd.hdc, szText, LEN(szText), @pnmcd.rc, DT_CENTER OR DT_VCENTER
' Cleanup
IF hBrush THEN
DeleteObject hBrush
END IF
IF hOldFont THEN
SelectObject @pnmcd.hdc, hOldFont
END IF
IF hFont THEN
DeleteObject hFont
END IF
' Tell Windows the item has already been drawn
FUNCTION = CDRF_SKIPDEFAULT
EXIT FUNCTION
END SELECT
END SELECT
END SELECT
FUNCTION = CallWindowProc(pOldWndProc, hDlg, utMsg, wParam, lParam)
END FUNCTION
Here's the error message during compilation
Hi Chris,
I would check your rect structure. is it left or nleft?
phdl.pwpos.x = phdl.prc.nLeft
Thanxx Charles
where can i check the RECT structure ?
as shown in my codes it is nleft and not left.
Hello Charles
i have changed all nleft to left , nright to right , ntop to top
and all @pxxx to pxxx
and the code can be compile without errors
but its exe still GPF ?
here's the latest code
' MultiLineHDO2.inc
' MultiLine Header routines for O2
' Updated : Nov 4 2018
Type WINDOWPOS
hwnd As sys
hWndInsertAfter As sys
x As Long
y As Long
cx As Long
cy As Long
flags As Long
End Type
' // Size = 8 bytes
TYPE HD_LAYOUT
RECT PTR prc ' RECT *prc
WINDOWPOS PTR pwpos ' WINDOWPOS *pwpos
END TYPE
TYPE NMCUSTOMDRAW
hdr AS NMHDR ' NMHDR hdr
dwDrawStage AS sys ' DWORD dwDrawStage
hdc AS sys ' HDC hdc
rc AS RECT ' RECT rc
dwItemSpec AS sys ' DWORD_PTR dwItemSpec // this is control specific, but it's how to specify an item. valid only with CDDS_ITEM bit set
uItemState AS sys ' UINT uItemState
lItemlParam AS LONG ' LPARAM lItemlParam
END TYPE
TYPE HD_ITEM
Mask AS sys ' UINT mask
cxy AS LONG ' int cxy
pszText AS ASCIIZ PTR ' LPSTR pszText
hbm AS sys ' HBITMAP hbm
cchTextMax AS LONG ' int cchTextMax
fmt AS LONG ' int fmt
lParam AS LONG ' LPARAM lParam
iImage AS LONG ' int iImage // index of bitmap in ImageList
iOrder AS LONG ' int iOrder // where to draw this item
pvFilter AS sys ' void * pvFilter // [in] fillter data see above
state AS sys
END TYPE
% SWP_FRAMECHANGED = &H20
% CDRF_NOTIFYITEMDRAW = &H20
% CDRF_SKIPDEFAULT = &H00000004
% HDI_TEXT = &H0002
% CDDS_PREPAINT = &H00000001
% CDDS_ITEM = &H00010000
% CDDS_ITEMPREPAINT = CDDS_ITEM OR CDDS_PREPAINT
% NM_FIRST = 0
% NM_CUSTOMDRAW = NM_FIRST - 12
% HDM_FIRST = &H1200
% HDM_LAYOUT = HDM_FIRST + 5
% HDM_GETITEMW = HDM_FIRST + 11
% DT_CENTER = &H00000001
% DT_VCENTER = &H00000004
'// itemState flags
% CDIS_SELECTED = &H0001
% DFC_BUTTON = 4
% DFCS_BUTTONPUSH = &H0010
% DFCS_PUSHED = &H00000200
' ========================================================================================
' Gets the handle to the header control used by a list-view control.
' ========================================================================================
FUNCTION ListView_GetHeader (BYVAL hwndLV AS sys) AS sys
FUNCTION = SendMessage(hwndLV, LVM_GETHEADER, 0, 0)
END FUNCTION
' ========================================================================================
FUNCTION Header_GetItemW (BYVAL hwndHD AS sys, BYVAL iItem AS sys, BYREF phdi AS HD_ITEM) AS LONG
' FUNCTION = SendMessageW( hwndHD, HDM_GETITEMW, iItem, @phdi)
FUNCTION = SendMessageW( hwndHD, HDM_GETITEMW, iItem, phdi)
END FUNCTION
' ============================================================================
' Processes messages for the subclassed ListView header control.
FUNCTION LVHeader_SubclassProc( hDlg , uint usMsg , sys wParam , lParam ) AS sys
Long lcx, rcx
SELECT CASE usMsg
CASE WM_DESTROY
' REQUIRED: Remove control subclassing
SetWindowLongPtr hDlg, GWLP_WNDPROC, RemoveProp(hDlg, "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
HD_LAYOUT phdl at (lparam)
phdl.pwpos.hwnd = hDlg
phdl.pwpos.flags = SWP_FRAMECHANGED
phdl.pwpos.x = phdl.prc.Left
phdl.pwpos.y = 0
phdl.pwpos.cx = phdl.prc.Right - phdl.prc.Left
phdl.pwpos.cy = 40 ' --> change me
phdl.prc.Top = 40 ' --> change me
FUNCTION = -1
EXIT FUNCTION
END SELECT
FUNCTION = CallWindowProc(GetProp(hDlg, "OLDWNDPROC"), hDlg, usMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
' Processes messages for the subclassed ListView control.
FUNCTION ListView_SubclassProc ( _
BYVAL hDlg AS sys, _
BYVAL utMsg AS uint, _
BYVAL wParam AS sys, _
BYVAL lParam AS NMHDR PTR ) AS sys
' REQUIRED: Get the address of the original window procedure
sys pOldWndProc
pOldWndProc = GetProp(hDlg, "OLDWNDPROC")
SELECT CASE utMsg
CASE WM_DESTROY
' REQUIRED: Remove control subclassing
SetWindowLongPtr hDlg, GWLP_WNDPROC, RemoveProp(hDlg, "OLDWNDPROC")
CASE WM_NOTIFY
NMHDR PTR pnmh ' at (lParam)
NMCUSTOMDRAW PTR pnmcd
string szText
pnmh = lParam
' SELECT CASE @pnmh.code
SELECT CASE pnmh.code
CASE NM_CUSTOMDRAW
pnmcd = lParam
' Check the drawing stage
' SELECT CASE @pnmcd.dwDrawStage
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
sys hLvHeader
sys nIndex
sys nState
' nIndex = @pnmcd.dwItemSpec
' nState = @pnmcd.uItemState
nIndex = pnmcd.dwItemSpec
nState = pnmcd.uItemState
' Get the header item text...
HD_ITEM hdi
hdi.mask = HDI_TEXT
hdi.pszText = szText 'VARPTR(szText)
hdi.cchtextmax = SIZEOF(szText)
hLvHeader = ListView_GetHeader(hDlg)
Header_GetItemW(hLvHeader, nIndex, hdi)
' Create a new font
sys hFont
hFont = O2ApiCreateFont("Tahoma", 10, FW_BOLD)
' Select the font into the current devide context
sys hOldFont
' hOldFont = SelectObject(@pnmcd.hdc, hFont)
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
DrawFrameControl pnmcd.hdc, pnmcd.rc, _
DFC_BUTTON, DFCS_BUTTONPUSH OR DFCS_PUSHED
ELSE
' DrawFrameControl @pnmcd.hdc, @pnmcd.rc, _
' DFC_BUTTON, DFCS_BUTTONPUSH
DrawFrameControl pnmcd.hdc, pnmcd.rc, _
DFC_BUTTON, DFCS_BUTTONPUSH
END IF
' Color the header background
sys hBrush
hBrush = CreateSolidBrush(RGB(243,250,5)) ' <------------ Change color
' InflateRect @pnmcd.rc, -2, -2
' FillRect @pnmcd.hdc, @pnmcd.rc, hBrush
InflateRect pnmcd.rc, -2, -2
FillRect pnmcd.hdc, pnmcd.rc, hBrush
' SetBkMode @pnmcd.hdc, TRANSPARENT
SetBkMode pnmcd.hdc, TRANSPARENT
' Color the header text
' SetTextColor @pnmcd.hdc, RGB(40,45,215) ' <------------ Change color
SetTextColor pnmcd.hdc, RGB(40,45,215) ' <------------ Change color
' Offset the text slightly if depressed...
IF (nState AND CDIS_SELECTED) THEN
' InflateRect @pnmcd.rc, -2, -2
InflateRect pnmcd.rc, -2, -2
END IF
' Draw multiline, using CRLF (i.e. szText = "Customer" & $CRLF & "number")
' DrawText @pnmcd.hdc, szText, LEN(szText), @pnmcd.rc, DT_CENTER OR DT_VCENTER
DrawText pnmcd.hdc, szText, LEN(szText), pnmcd.rc, DT_CENTER OR DT_VCENTER
' Cleanup
IF hBrush THEN
DeleteObject hBrush
END IF
IF hOldFont THEN
' SelectObject @pnmcd.hdc, hOldFont
SelectObject pnmcd.hdc, hOldFont
END IF
IF hFont THEN
DeleteObject hFont
END IF
' Tell Windows the item has already been drawn
FUNCTION = CDRF_SKIPDEFAULT
EXIT FUNCTION
END SELECT
END SELECT
END SELECT
FUNCTION = CallWindowProc(pOldWndProc, hDlg, utMsg, wParam, lParam)
END FUNCTION
if you look at the Function ListView_SubclassProc
you would see that i have specified BYVAL lParam AS NMHDR PTR
so that it could be compile without error
but if i specified as BYVAL lParam AS sys
it then produces an error during compilation ? as shown below
Unable to assign types sys to lparam
FUNCTION ListView_SubclassProc ( _
BYVAL hDlg AS sys, _
BYVAL utMsg AS uint, _
BYVAL wParam AS sys, _
BYVAL lParam AS NMHDR PTR ) AS sys
lparam should be defined as sys in the prototype, as usual.
Then the address of pnmh can be set from lparam:
@pnmh=lparam
CASE WM_NOTIFY
NMHDR PTR pnmh ' at (lParam)
NMCUSTOMDRAW PTR pnmcd
string szText
@pnmh = lParam
SELECT CASE pnmh.code
CASE NM_CUSTOMDRAW
@pnmcd = lParam
' Check the drawing stage
SELECT CASE pnmcd.dwDrawStage
...
Thanxx Charles
but unfortunately the compile exe still GPF
i,m checking all other codes that may contribute to this problem and i will be using % review
BTW what's the difference between print and printl ?
Try compiling it in 32bit first.
console printl prints a leading crlf before the text
Thanxx Charles
i also compile it to 32bits and it still doesn't work but i was able to debug trace the point where it GPF
at this function ListView_GetHeader()
not sure why it GPF
any chance that we can replace this function with a kind of macro or something?
' ========================================================================================
' Gets the handle to the header control used by a list-view control.
' ========================================================================================
FUNCTION ListView_GetHeader (BYVAL hwndLV AS sys) AS sys
FUNCTION = SendMessage(hwndLV, LVM_GETHEADER, 0, 0)
END FUNCTION
where the ListView messages constants are defined as below
which are taken from Jose includes for PB
' ListView messages
% LVM_FIRST = &H1000
% LVM_SETBKCOLOR = (LVM_FIRST + 1)
% LVM_SETTEXTCOLOR = LVM_FIRST + 36
% LVM_GETHEADER = LVM_FIRST + 31
the latest main code ColorListView_MH.o2bas is
'====================================================================
' Color Listview example modified Nov 4 2018
' which you can change fonts and color of text and background
' with Multi Line Header
'====================================================================
$ filename "ColorListView_MH.exe"
use rtl64
'use rtl32
#lookahead
% review
uses dialogs
uses O2Common
'Identifier for ListView
#define IDC_LSV1 4001
' The program logo icon is obtained from the resource file
' the 1000 must corespondence to the 1000 in the rc file
#define IDI_LOGO 1000
% ICON_BIG=1
% WM_SETICON=0x80
macro ListView_InsertColumn(hwnd,iCol,pcol) (SendMessage(hwnd, LVM_INSERTCOLUMN, iCol, pcol))
macro ListView_SetColumnWidth(hwnd,iCol,cx) (SendMessage(hwnd, LVM_SETCOLUMNWIDTH, iCol, cx))
macro ListView_InsertItem(hwnd,pitem) (SendMessage(hwnd, LVM_INSERTITEM,0, pitem))
macro ListView_SetItem(hwnd,pitem) (SendMessage(hwnd, LVM_SETITEM,0, pitem))
% DS_CENTER=0x0800
% DS_MODALFRAME=0x80
% SS_CENTERIMAGE=0x200
% LVS_LIST 0x0003
% LVS_REPORT 0x0001
% LVS_EX_GRIDLINES 1
% LVS_EX_CHECKBOXES 4
% LVS_EX_FULLROWSELECT 0x0020
% LVS_SINGLESEL = 0x0004
% LVS_EX_DOUBLEBUFFER = 0x0010000
% LVSCW_AUTOSIZE -1
% LVSCW_AUTOSIZE_USEHEADER -2
% LVM_INSERTCOLUMN=4123
% LVM_SETCOLUMNWIDTH=4126
% LVM_INSERTITEM=4103
% LVM_SETITEM=4102
% LVCF_FMT 1
% LVCF_WIDTH 2
% LVCF_TEXT=4
% LVCF_SUBITEM 8
% LVCF_ORDER = 20
% LVIF_TEXT=1
% LVM_SETEXTENDEDLISTVIEWSTYLE 0x1036
% LVN_COLUMNCLICK = -108
% LVN_ITEMCHANGED = -101
% LR_LOADFROMFILE=0x0010
% IMAGE_ICON=1
% STM_SETIMAGE=0x172
% SWP_NOZORDER=4
' ListView messages
% LVM_FIRST = &H1000
% LVM_SETBKCOLOR = (LVM_FIRST + 1)
% LVM_SETTEXTCOLOR = LVM_FIRST + 36
% LVM_GETHEADER = LVM_FIRST + 31
% CLR_NONE = &HFFFFFFFF&
% GWLP_WNDPROC= -4
type LVCOLUMN
uint mask
int fmt
int cx
char* pszText
int cchTextMax
int iSubItem
int iImage
int iOrder
int cxMin
int cxDefault
int cxIdeal
end type
typedef LVCOLUMN LV_COLUMN
type LVITEM
uint mask
int iItem
int iSubItem
uint state
uint stateMask
char* pszText
int cchTextMax
int iImage // index of the list view item's icon
sys lParam // 32-bit value to associate with item
int iIndent
int iGroupId
uint cColumns
uint *puColumns
int *piColFmt
int iGroup
end type
typedef LVITEM LV_ITEM
' Number of rows in the ListView
% NumRow = 200
' Number of columns in the ListView meaning 3 +1 = 4 columns
% NumCol = 3
! GetDlgItem lib "user32.dll" (sys hDlg, int nIDDlgItem) as sys
! IsDialogMessage lib "user32.dll" alias"IsDialogMessageA" (sys hDlg, sys lpMsg) as bool
! IsWindow lib "user32.dll" (sys hWnd) as bool
uses MultiLineHDO2
' Handle for the Main Dialog
sys hDlg
' Fonts
sys hFont
sys hListview
'====================================================================
' Main callback function
Function DlgProc( hDlg,uint uMsg, sys wParam, lParam ) as sys callback
int i , j
string txtStr
' Handle for the ListView
hListview = GetDlgItem(hDlg, IDC_LSV1)
LV_COLUMN lvc
LV_ITEM lvi
select case uMsg
case WM_INITDIALOG
' display the program icon
sys hInstance = GetModuleHandle(NULL)
sys hIcon = LoadIcon(hInstance, IDI_Logo)
'Set Icon to Main Window
SendMessage(hDlg, WM_SETICON, ICON_BIG, hIcon)
' Setup the fonts for the ListView
SendMessage(hListview,%WM_SETFONT,hFont,0)
'Setup the ListView Column Headers
' The first column must have a wider width to accomodate the checkbox
lvc.mask = LVCF_WIDTH or LVCF_ORDER
' Need to add some blanks behind the header string label
' inorder to get a wider column
txtStr="Column #" & str(1) + " " +cr
lvc.pszText = txtStr
lvc.iorder = 0
ListView_InsertColumn(hListview, 0, &lvc)
' All the other columns to have a narrower width
For i = 1 To NumCol
lvc.mask = LVCF_FMT OR LVCF_WIDTH OR LVCF_TEXT OR LVCF_SUBITEM
If i = NumCol then
' Leave the last column header blank as we are NOT putting data
' into this last column ( it act like a buffer )
txtStr = ""
Else
txtStr="Column #" & str(i+1) + cr + " level2 "
txtStr = Trim(txtStr)
End if
lvc.pszText = txtStr
lvc.iorder = i
ListView_InsertColumn(hListview, i, &lvc)
Next i
' Setup the Listview data Rows
For i=1 To NumRow
'First column
lvi.mask = LVIF_TEXT
txtStr = "Row #" & str(200-i+1) ", Col # 1"
lvi.pszText = txtStr
lvi.iSubItem = 0
ListView_InsertItem(hListview, &lvi)
'Remaining columns
for j=2 to NumCol
txtStr = "Row #" & str(200-i+1) ", Col # " & str(j)
lvi.pszText = txtStr
lvi.iSubItem = j-1
ListView_SetItem(hListview, &lvi)
next j
Next i
' Set the column widths according to width of each column header
for i = 0 to NumCol -1
ListView_SetColumnWidth(hListview,i,LVSCW_AUTOSIZE_USEHEADER)
next i
' make the last column a very narrow width as it is only a buffer column
' this would display as a double line
ListView_SetColumnWidth(hListview,NumCol,3)
' Place in the extended style for the listview
SendMessage(hListview, LVM_SETEXTENDEDLISTVIEWSTYLE, 0,
LVS_EX_FULLROWSELECT or LVS_EX_CHECKBOXES or LVS_EX_GRIDLINES )
' Shade those unused background portions of the main ListView to Alice Blue
' while the text color is Navy
SendMessage(hListView, LVM_SETTEXTCOLOR, 0,RGB(0,0,128))
SendMessage(hListView, LVM_SETBKCOLOR, 0,RGB(240,248,255))
' Subclass the ListView
printl "1 " hListView
SetProp hListView, "OLDWNDPROC", _
SetWindowLongPtr(hListView, GWLP_WNDPROC, @ListView_SubclassProc)
printl "2"
' Get the handle of the ListView header control and subclass it
sys hLvHeader
printl "2a " hLvHeader
hLvHeader = ListView_GetHeader(hListView)
printl "2b " hLvHeader
printl " hLvHeader " hLvHeader
IF hLvHeader THEN
printl "3"
SetProp hLvHeader, "OLDWNDPROC", _
SetWindowLongPtr(hLvHeader, GWLP_WNDPROC, @LVHeader_SubclassProc)
END IF
printl "3b"
case WM_COMMAND
select case loword(wParam)
case IDCANCEL
' exit
DeleteObject(hFont)
DestroyWindow( hDlg )
end select
case WM_NOTIFY
NMHDR pnm at lParam
if pnm.hwndFrom = hListview then
'ListView
select case pnm.code
case LVN_COLUMNCLICK
mbox "LVN_COLUMNCLICK"
case LVN_ITEMCHANGED
end select
end if
case WM_SIZE
RECT rcClient
// Calculate remaining height and size edit
GetClientRect(hDlg, &rcClient)
SetWindowPos(hListview, NULL, 0, rcClient.top, rcClient.right, rcClient.bottom, SWP_NOZORDER)
case WM_CLOSE
DestroyWindow( hDlg )
case WM_DESTROY
PostQuitMessage( null )
end select
return 0
end function
'====================================================================
' Display the Main Dialog
Function DispMainDialog
sys lpdt
MSG wMsg
dyn::init(lpdt)
Dialog( 1, 10,10,250,250, "Listview example 64bits ", lpdt,
WS_OVERLAPPEDWINDOW or DS_CENTER or WS_VISIBLE,
8,"MS Sans Serif" )
' Add in the listview
CONTROL "",IDC_LSV1,"SysListView32", _
WS_VISIBLE or WS_TABSTOP or WS_BORDER or LVS_REPORT or LVS_SINGLESEL or LVS_EX_DOUBLEBUFFER , _
10,10,233,100, WS_EX_CLIENTEDGE
hFont = O2ApiCreateFont("Arial",9, FW_Bold)
hDlg = CreateModelessDialog( 0, @DlgProc, 0, lpdt )
while GetMessage( @wMsg, null, 0, 0 ) <> 0
if IsDialogMessage( hDlg, @wMsg ) = 0 then
TranslateMessage( @wMsg )
DispatchMessage( @wMsg )
end if
wend
End Function
'------------------------------------
' Start of program
init_common_controls()
DispMainDialog
latest MultilineHDO2.inc
' MultiLineHDO2.inc
' MultiLine Header routines for O2
' Updated : Nov 4 2018
Type WINDOWPOS
hwnd As sys
hWndInsertAfter As sys
x As Long
y As Long
cx As Long
cy As Long
flags As Long
End Type
' // Size = 8 bytes
TYPE HD_LAYOUT
RECT PTR prc ' RECT *prc
WINDOWPOS PTR pwpos ' WINDOWPOS *pwpos
END TYPE
TYPE NMCUSTOMDRAW
hdr AS NMHDR ' NMHDR hdr
dwDrawStage AS sys ' DWORD dwDrawStage
hdc AS sys ' HDC hdc
rc AS RECT ' RECT rc
dwItemSpec AS sys ' DWORD_PTR dwItemSpec // this is control specific, but it's how to specify an item. valid only with CDDS_ITEM bit set
uItemState AS uint ' UINT uItemState
lItemlParam AS sys ' LPARAM lItemlParam
END TYPE
TYPE HD_ITEM
Mask AS uint ' UINT mask
cxy AS LONG ' int cxy
pszText AS ASCIIZ PTR ' LPSTR pszText
hbm AS sys ' HBITMAP hbm
cchTextMax AS LONG ' int cchTextMax
fmt AS LONG ' int fmt
lParam AS sys ' LPARAM lParam
iImage AS LONG ' int iImage // index of bitmap in ImageList
iOrder AS LONG ' int iOrder // where to draw this item
pvFilter AS sys ' void * pvFilter // [in] fillter data see above
state AS sys
END TYPE
% SWP_FRAMECHANGED = &H20
% CDRF_NOTIFYITEMDRAW = &H20
% CDRF_SKIPDEFAULT = &H00000004
% HDI_TEXT = &H0002
% CDDS_PREPAINT = &H00000001
% CDDS_ITEM = &H00010000
% CDDS_ITEMPREPAINT = CDDS_ITEM OR CDDS_PREPAINT
% NM_FIRST = 0
% NM_CUSTOMDRAW = NM_FIRST - 12
% HDM_FIRST = &H1200
% HDM_LAYOUT = HDM_FIRST + 5
% HDM_GETITEMW = HDM_FIRST + 11
% DT_CENTER = &H00000001
% DT_VCENTER = &H00000004
'// itemState flags
% CDIS_SELECTED = &H0001
% DFC_BUTTON = 4
% DFCS_BUTTONPUSH = &H0010
% DFCS_PUSHED = &H00000200
' ========================================================================================
' Gets the handle to the header control used by a list-view control.
' ========================================================================================
FUNCTION ListView_GetHeader (BYVAL hwndLV AS sys) AS sys
FUNCTION = SendMessage(hwndLV, LVM_GETHEADER, 0, 0)
END FUNCTION
' ========================================================================================
FUNCTION Header_GetItemW (BYVAL hwndHD AS sys, BYVAL iItem AS sys, BYREF phdi AS HD_ITEM) AS LONG
FUNCTION = SendMessageW( hwndHD, HDM_GETITEMW, iItem, @phdi)
' FUNCTION = SendMessageW( hwndHD, HDM_GETITEMW, iItem, phdi)
END FUNCTION
' ============================================================================
' Processes messages for the subclassed ListView header control.
FUNCTION LVHeader_SubclassProc( BYVAL hwnd AS sys , BYVAL usMsg AS uint ,
BYVAL wParam AS sys, BYVAL lParam AS sys ) AS sys
SELECT CASE usMsg
CASE WM_DESTROY
' REQUIRED: Remove control subclassing
SetWindowLongPtr hWnd, GWLP_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.
HD_LAYOUT phdl at (lparam)
' HD_LAYOUT phdl at lparam
phdl.pwpos.hwnd = hWnd
phdl.pwpos.flags = SWP_FRAMECHANGED
phdl.pwpos.x = phdl.prc.Left
phdl.pwpos.y = 0
phdl.pwpos.cx = phdl.prc.Right - phdl.prc.Left
phdl.pwpos.cy = 40 ' --> change me
phdl.prc.Top = 40 ' --> change me
FUNCTION = -1
EXIT FUNCTION
END SELECT
FUNCTION = CallWindowProc(GetProp(hWnd, "OLDWNDPROC"), hWnd, usMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
' Processes messages for the subclassed ListView control.
FUNCTION ListView_SubclassProc ( _
BYVAL hWnd AS sys, _
BYVAL utMsg AS uint, _
BYVAL wParam AS sys, _
BYVAL lParam AS sys ) AS sys
' REQUIRED: Get the address of the original window procedure
sys pOldWndProc
pOldWndProc = GetProp(hWnd, "OLDWNDPROC")
SELECT CASE utMsg
CASE WM_DESTROY
' REQUIRED: Remove control subclassing
' SetWindowLongPtr hWnd, GWLP_WNDPROC, RemoveProp(hWnd, "OLDWNDPROC")
RemoveProp(hWnd, "OLDWNDPROC", GetWindowLongPtr(hWnd, GWLP_WNDPROC, @ListView_SubclassProc))
CASE WM_NOTIFY
NMHDR PTR pnmh
NMCUSTOMDRAW PTR pnmcd
' string szText
ASCIIZ*260 szText
@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
sys hLvHeader
sys nIndex
sys nState
nIndex = @pnmcd.dwItemSpec
nState = @pnmcd.uItemState
' nIndex = pnmcd.dwItemSpec
' nState = pnmcd.uItemState
' Get the header item text...
HD_ITEM hdi
hdi.mask = HDI_TEXT
hdi.pszText = VARPTR(szText)
hdi.cchtextmax = SIZEOF(szText)
hLvHeader = ListView_GetHeader(hWnd)
Header_GetItemW(hLvHeader, nIndex, hdi)
' Create a new font
sys hFont
hFont = O2ApiCreateFont("Tahoma", 10, FW_BOLD)
' Select the font into the current devide context
sys hOldFont
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
' DrawFrameControl pnmcd.hdc, pnmcd.rc, _
' DFC_BUTTON, DFCS_BUTTONPUSH OR DFCS_PUSHED
ELSE
DrawFrameControl @pnmcd.hdc, @pnmcd.rc, _
DFC_BUTTON, DFCS_BUTTONPUSH
' DrawFrameControl pnmcd.hdc, pnmcd.rc, _
' DFC_BUTTON, DFCS_BUTTONPUSH
END IF
' Color the header background
sys hBrush
hBrush = CreateSolidBrush(RGB(243,250,5)) ' <------------ Change color
InflateRect @pnmcd.rc, -2, -2
FillRect @pnmcd.hdc, @pnmcd.rc, hBrush
' InflateRect pnmcd.rc, -2, -2
' FillRect pnmcd.hdc, pnmcd.rc, hBrush
SetBkMode @pnmcd.hdc, TRANSPARENT
' SetBkMode pnmcd.hdc, TRANSPARENT
' Color the header text
SetTextColor @pnmcd.hdc, RGB(40,45,215) ' <------------ Change color
' SetTextColor pnmcd.hdc, RGB(40,45,215) ' <------------ Change color
' Offset the text slightly if depressed...
IF (nState AND CDIS_SELECTED) THEN
InflateRect @pnmcd.rc, -2, -2
' InflateRect pnmcd.rc, -2, -2
END IF
' Draw multiline, using CRLF (i.e. szText = "Customer" & $CRLF & "number")
DrawText @pnmcd.hdc, szText, LEN(szText), @pnmcd.rc, DT_CENTER OR DT_VCENTER
' DrawText pnmcd.hdc, szText, LEN(szText), pnmcd.rc, DT_CENTER OR DT_VCENTER
' Cleanup
IF hBrush THEN
DeleteObject hBrush
END IF
IF hOldFont THEN
SelectObject @pnmcd.hdc, hOldFont
' SelectObject pnmcd.hdc, hOldFont
END IF
IF hFont THEN
DeleteObject hFont
END IF
' Tell Windows the item has already been drawn
FUNCTION = CDRF_SKIPDEFAULT
EXIT FUNCTION
END SELECT
END SELECT
END SELECT
FUNCTION = CallWindowProc(pOldWndProc, hWnd, utMsg, wParam, lParam)
END FUNCTION
and the latest O2Common.inc is
' O2common.inc
' These are the commonly use functions and macros
' Updated : Nov 3 2018
uses Corewin
' Background color for main window
int MainWindBGColor
' Trim function
def Trim ltrim(rtrim(%1))
' Variant pointer
def varptr @ %1
' Carriage return character
string cr = chr(13,10)
' Font Weights
% FW_DONTCARE = 0
% FW_THIN = 100
% FW_EXTRALIGHT = 200
% FW_LIGHT = 300
% FW_NORMAL = 400
% FW_MEDIUM = 500
% FW_SEMIBOLD = 600
% FW_BOLD = 700
% FW_EXTRABOLD = 800
% FW_HEAVY = 900
% LOGPIXELSY 90
% HWND_DESKTOP 0
'===============================
' for displaying the RGB colors
Function RGB(sys wred,wgreen,wblue) as sys
sys wcolor
wcolor = wred
wcolor = wcolor + wgreen*256
wcolor = wcolor + wblue*65536
Return wcolor
End Function
'========================================
' draws with color gradient
SUB DrawGradient (BYVAL hDC AS DWORD)
LOCAL rectFill AS RECT, rectClient AS RECT, fStep AS SINGLE
local hBrush AS DWORD, lOnBand AS LONG
GetClientRect WindowFromDC(hDC), rectClient
fStep = rectClient.bottom / 75
FOR lOnBand = 0 TO 50 ' 199
SetRect rectFill, 0, lOnBand * fStep, rectClient.right + 1, (lOnBand + 1) * fStep
' paint the background -- change the first 2 colors R and G
' to vary the color gradient
Select case MainWindBGColor
Case 1
' this gives a light yellow background
hBrush = CreateSolidBrush(rgb(255, 255, 205 - lOnBand))
Case 2
' this gives a cyan background
hBrush = CreateSolidBrush(rgb(0, 248, 255 - lOnBand))
Case 3
' this gives a light green background
hBrush = CreateSolidBrush(rgb(155, 250, 147 - lOnBand))
End Select
Fillrect hDC, rectFill, hBrush
DeleteObject hBrush
NEXT
END SUB
'==============================================================================
Function O2ApiCreateFont(szFaceName As Zstring,Byval lPointSize As long, BYVAL lWeight AS LONG) As sys
Dim tlf As LOGFONT
Dim Fhdc As sys
Dim nNum As long
Fhdc = GetDc(%HWND_DESKTOP)
nNum = GetDeviceCaps(Fhdc, %LOGPIXELSY)
tlf.lfHeight = -MulDiv(lPointSize,nNum , 72)
tlf.lfWidth = 0
tlf.lfEscapement = 0
tlf.lfOrientation = 0
tlf.lfWeight = lWeight
tlf.lfItalic = 0
tlf.lfUnderline = 0
tlf.lfStrikeOut = 0
tlf.lfCharSet = %ANSI_CHARSET
tlf.lfOutPrecision = %OUT_TT_PRECIS
tlf.lfClipPrecision = %CLIP_DEFAULT_PRECIS
tlf.lfQuality = %DEFAULT_QUALITY
tlf.lfPitchAndFamily = %FF_DONTCARE
tlf.lfFaceName = szFaceName
ReleaseDC(%HWND_DESKTOP, Fhdc)
Function = CreateFontIndirect(@tlf)
End Function