Multiline header Listview not working

[Chris Chancellor]

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

Code Select Expand



' 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

Code Select Expand


' 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


[Chris Chancellor]

and this is O2 program  ColorListView_MH.o2bas

Code Select Expand


'====================================================================
' 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

Code Select Expand


' 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

Code Select Expand


' 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




[Chris Chancellor]

here is the zipped file for the problematic O2 program

[José Roca]

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.

[Charles Pegge]

O2 will do all the pointy stuff for you. (And PB's '@' means '*' in FreeBasic and C.)

So this is how it translates:

Code Select Expand


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


[Chris Chancellor]

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

Code Select Expand


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

Code Select Expand


' 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
             


[Chris Chancellor]

Here's the error message during compilation

[Charles Pegge]

Hi Chris,

I would check your rect structure. is it left or nleft?

phdl.pwpos.x = phdl.prc.nLeft

[Chris Chancellor]

Thanxx Charles

where can i check the RECT structure ?

as shown in my codes  it is nleft and not left.

[Chris Chancellor]

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

Code Select Expand


' 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
             


[Chris Chancellor]

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

Code Select Expand


FUNCTION ListView_SubclassProc ( _
   BYVAL hDlg   AS sys, _         
   BYVAL utMsg   AS uint, _             
   BYVAL wParam AS sys, _               
   BYVAL lParam AS  NMHDR PTR  ) AS sys


[Charles Pegge]

lparam should be defined as sys in the prototype, as usual.

Then the address of pnmh can be set from lparam:

@pnmh=lparam

Code Select Expand


      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

...


[Chris Chancellor]

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 ?

[Charles Pegge]

Try compiling it in 32bit first.

console printl prints a leading crlf before the text

[Chris Chancellor]

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?

Code Select Expand


' ========================================================================================
' 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

Code Select Expand


' 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

Code Select Expand


'====================================================================
' 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

Code Select Expand


' 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

Code Select Expand


' 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