Menu
▾
▴
win32forth-cvs
|
From: Jos v.d.V. <jo...@us...> - 2006-05-02 09:55:45
|
Update of /cvsroot/win32forth/win32forth/src/lib In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv20634/src/lib Added Files: Listview.f Log Message: Jos: Added a Listview. --- NEW FILE: Listview.f --- anew -ListView ( -------------------------------------------------------------------) ( Point ) :Class Point <Super Object Record: _Point int x int y ;RecordSize: /Point :M Addr: ( -- a ) _Point ;M :M Sizeof: ( -- n ) /Point ;M :M Getpt: ( -- x y ) x y ;M :M Setpt: ( x y -- ) to y to x ;M ;Class ( -------------------------------------------------------------------) ( NMHDR ) :Class NMHDR <Super Object Record: _NMHDR int hwndFrom int idFrom int code ;RecordSize: /NMHDR :M Addr: ( -- a ) _NMHDR ;M :M Sizeof: ( -- n ) /NMHDR ;M :M GethwndFrom: ( -- ) hwndFrom ;M :M GetidFrom: ( -- ) idFrom ;M :M Getcode: ( -- ) code ;M :M SethwndFrom: ( -- ) to hwndFrom ;M :M SetidFrom: ( -- ) to idFrom ;M :M Setcode: ( -- ) to code ;M ;Class ( -------------------------------------------------------------------) ( LV_ITEM ) :Class LV_ITEM <Super Object Record: _LV_ITEM int mask int iItem int iSubItem int state int stateMask int pszText int cchTextMax int iImage int lParam ;RecordSize: /LV_ITEM :M Addr: ( -- a ) _LV_ITEM ;M :M Sizeof: ( -- n ) /LV_ITEM ;M :M GetMask: ( -- ) mask ;M :M GetiItem: ( -- ) iItem ;M :M GetiSubItem: ( -- ) iSubItem ;M :M Getstate: ( -- ) state ;M :M GetstateMask: ( -- ) stateMask ;M :M GetpszText: ( -- ) pszText ;M :M GetcchTextMax: ( -- ) cchTextMax ;M :M GetiImage: ( -- ) iImage ;M :M GetlParam: ( -- ) lParam ;M :M SetMask: ( -- ) _LV_ITEM /LV_ITEM erase to mask ;M :M SetiItem: ( -- ) to iItem ;M :M SetiSubItem: ( -- ) to iSubItem ;M :M Setstate: ( -- ) to state ;M :M SetstateMask: ( -- ) to stateMask ;M :M SetpszText: ( -- ) to pszText ;M :M SetcchTextMax: ( -- ) to cchTextMax ;M :M SetiImage: ( -- ) to iImage ;M :M SetlParam: ( -- ) to lParam ;M ;Class ( -------------------------------------------------------------------) ( LV_DISPINFO ) :Class LV_DISPINFO <Super NMHDR Record: _LV_DISPINFO int mask int iItem int iSubItem int state int stateMask int pszText int cchTextMax int iImage int lParam ;RecordSize: /LV_DISPINFO :M Addr: ( -- a ) _LV_DISPINFO ;M :M Sizeof: ( -- n ) /LV_DISPINFO ;M :M GetMask: ( -- ) mask ;M :M GetiItem: ( -- ) iItem ;M :M GetiSubItem: ( -- ) iSubItem ;M :M Getstate: ( -- ) state ;M :M GetstateMask: ( -- ) stateMask ;M :M GetpszText: ( -- ) pszText ;M :M GetcchTextMax: ( -- ) cchTextMax ;M :M GetiImage: ( -- ) iImage ;M :M GetlParam: ( -- ) lParam ;M :M SetMask: ( -- ) _LV_DISPINFO /LV_DISPINFO erase to mask ;M :M SetiItem: ( -- ) to iItem ;M :M SetiSubItem: ( -- ) to iSubItem ;M :M Setstate: ( -- ) to state ;M :M SetstateMask: ( -- ) to stateMask ;M :M SetpszText: ( -- ) to pszText ;M :M SetcchTextMax: ( -- ) to cchTextMax ;M :M SetiImage: ( -- ) to iImage ;M :M SetlParam: ( -- ) to lParam ;M ;Class ( -------------------------------------------------------------------) ( LV_COLUMN ) :Class LV_COLUMN <Super Object Record: _LV_COLUMN int mask int fmt int cx int pszText int cchTextMax int iSubItem ;RecordSize: /LV_COLUMN :M Addr: ( -- a ) _LV_COLUMN ;M :M Sizeof: ( -- n ) /LV_COLUMN ;M :M Getmask: ( -- ) mask ;M :M Getfmt: ( -- ) fmt ;M :M Getcx: ( -- ) cx ;M :M GetpszText: ( -- ) pszText ;M :M GetcchTextMax: ( -- ) cchTextMax ;M :M GetiSubItem: ( -- ) iSubItem ;M :M Setmask: ( -- ) _LV_COLUMN /LV_COLUMN erase to mask ;M :M Setfmt: ( -- ) to fmt ;M :M Setcx: ( -- ) to cx ;M :M SetpszText: ( -- ) to pszText ;M :M SetcchTextMax: ( -- ) to cchTextMax ;M :M SetiSubItem: ( -- ) to iSubItem ;M ;Class ( -------------------------------------------------------------------) ( LV_FINDINFO ) :Class _LV_FINDINFO <Super Object Record: LV_FINDINFO int flags int psz int lParam int x int y int vkDirection ;RecordSize: /LV_FINDINFO :M Addr: ( -- a ) _LV_FINDINFO ;M :M Sizeof: ( -- n ) /LV_FINDINFO ;M :M Getflags: ( -- ) flags ;M :M Getpsz: ( -- ) psz ;M :M GetlParam: ( -- ) lparam ;M :M GetvkDirection: ( -- ) vkDirection ;M :M Setflags: ( -- ) to flags ;M :M Setpsz: ( -- ) to psz ;M :M SetlParam: ( -- ) to lparam ;M :M SetvkDirection: ( -- ) to vkDirection ;M :M Getpt: ( -- x y ) x y ;M :M Setpt: ( x y -- ) to y to x ;M ;Class ( -------------------------------------------------------------------) ( LV_HITTESTINFO ) :Class LV_HITTESTINFO <Super Object Record: _LV_HITTESTINFO int x int y int flags int iItem ;RecordSize: /LV_HITTESTINFO :M Addr: ( -- a ) _LV_HITTESTINFO ;M :M Sizeof: ( -- n ) /LV_HITTESTINFO ;M :M Getflags: ( -- ) flags ;M :M GetiItem: ( -- ) iItem ;M :M Setflags: ( -- ) to flags ;M :M SetiItem: ( -- ) to iItem ;M :M Getpt: ( -- x y ) x y ;M :M Setpt: ( x y -- ) to y to x ;M ;Class ( -------------------------------------------------------------------) ( LV_KEYDOWN ) :Class LV_KEYDOWN <Super NMHDR Record: _LV_KEYDOWN int wVKey int flags ;RecordSize: /LV_KEYDOWN :M Addr: ( -- a ) _LV_KEYDOWN ;M :M Sizeof: ( -- n ) /LV_KEYDOWN ;M :M GetwvKey: ( -- ) wVKey ;M :M Getflags: ( -- ) flags ;M :M SetwvKey: ( -- ) to wVKey ;M :M Setflags: ( -- ) to flags ;M ;Class ( -------------------------------------------------------------------) ( NM_LISTVIEW ) :Class NM_LISTVIEW <Super NMHDR Record: _NM_LISTVIEW int iItem int iSubItem INT uNewState INT uOldState INT uChanged int x int y int lParam ;RecordSize: /NM_LISTVIEW :M Addr: ( -- a ) _NM_LISTVIEW ;M :M Sizeof: ( -- n ) /NM_LISTVIEW ;M :M GetiItem: ( -- ) iItem ;M :M GetiSubItem: ( -- ) iSubItem ;M :M GetuNewState: ( -- ) uNewState ;M :M GetuOldState: ( -- ) uOldState ;M :M GetuChanged: ( -- ) uChanged ;M :M GetlParam: ( -- ) lParam ;M :M SetiItem: ( -- ) to iItem ;M :M SetiSubItem: ( -- ) to iSubItem ;M :M SetuNewState: ( -- ) to uNewState ;M :M SetuOldState: ( -- ) to uOldState ;M :M SetuChanged: ( -- ) to uChanged ;M :M SetlParam: ( -- ) to lParam ;M :M Getpt: ( -- x y ) x y ;M :M Setpt: ( x y -- ) to y to x ;M ;Class ( -------------------------------------------------------------------) ( ListView Control ) :Class ListView <Super Window int hwndLV ( list view window handle ) int PObj ( parent object ) int nmhdr // NMHDR nmhdr int nmlv // NM_LISTVIEW nmlv int lvdi // LV_DISPINFO lvdi int lvkd // LV_KEYDOWN lvkd int _style :M GetHandle: ( - handle ) hwndLV ;M :M WindowStyle: ( -- style ) _style ;M :M SetStyleListView: ( Style -- ) to _style ;M :M ClassInit: ( -- ) here 8 , ICC_LISTVIEW_CLASSES , Call InitCommonControlsEx not if ." Couldn't initialise common controls" then cr Classinit: Super ;M :M ~: ( -- ) hwndLV Call DestroyWindow ~: Super ;M : create-listview ( -- hWnd ) 0 \ creation parameters appInst \ program instance 0 \ child id Gethandle: PObj \ parent window handle CW_USEDEFAULT CW_USEDEFAULT \ height, width CW_USEDEFAULT CW_USEDEFAULT \ y, x starting position WindowStyle: [ self ] \ the window style WindowTitle: [ self ] \ the window title s" SysListView32" WindowClassName place WindowClassName +NULL WindowClassName 1+ \ class name ExWindowStyle: [ self ] \ extended window style Call CreateWindowEx ; :M Start: ( hwnd -- ) to PObj create-listview to hWndLV ;M ( -------------------------------------------------------------------) ( Items and SubItems ) :M DeleteAllItems: ( -- f ) 0 0 LVM_DELETEALLITEMS hwndLV Call SendMessage ;M :M DeleteItem: ( iitem -- f ) 0 swap LVM_DELETEITEM hwndLV Call SendMessage ;M :M GetItem: ( ptem -- f ) 0 LVM_GETITEM hwndLV Call SendMessage ;M :M GetItemCount: ( -- n ) 0 0 LVM_GETITEMCOUNT hwndLV Call SendMessage ;M :M GetItemSpacing: ( fsmall -- f ) 0 swap LVM_GETITEMSPACING hwndLV Call SendMessage ;M :M GetItemState: ( mask i -- f ) LVM_GETITEMSTATE hwndLV Call SendMessage ;M :M GetItemText: ( pitem iItem -- ) LVM_GETITEMTEXT hwndLV Call SendMessage drop ;M :M GetSelectedCount: ( -- n ) 0 0 LVM_GETSELECTEDCOUNT hwndLV Call SendMessage ;M :M InsertItem: ( pitem -- index | -1 ) 0 LVM_INSERTITEM hwndLV Call SendMessage ;M :M SetItem: ( pitem -- index | -1 ) 0 LVM_SETITEM hwndLV Call SendMessage ;M :M SetItemCount: ( cItems -- ) 0 swap LVM_SETITEMCOUNT hwndLV Call SendMessage ;M :M SetItemState: ( pitem i -- f ) LVM_SETITEMSTATE hwndLV Call SendMessage ;M :M SetItemText: ( pitem i -- f ) LVM_SETITEMTEXT hwndLV Call SendMessage ;M ( -------------------------------------------------------------------) ( Callback Items ) :M GetCallBackMask: ( -- mask ) 0 0 LVM_GETCALLBACKMASK hwndLV Call SendMessage ;M :M ReDrawItems: ( iLast iFirst -- f ) LVM_REDRAWITEMS hwndLV Call SendMessage ;M :M SetCallBackMask: ( mask -- f ) 0 swap LVM_SETCALLBACKMASK hwndLV Call SendMessage ;M :M Update: ( iItem -- f ) 0 swap LVM_UPDATE hwndLV Call SendMessage ;M ( -------------------------------------------------------------------) ( Columns ) :M DeleteColumn: ( icol -- f ) 0 swap LVM_DELETECOLUMN hwndLV Call SendMessage ;M :M GetColumn: ( pcol icol -- f ) LVM_GETCOLUMN hwndLV Call SendMessage ;M :M GetColumnWidth: ( icol -- width|0 ) 0 swap LVM_GETCOLUMNWIDTH hwndLV Call SendMessage ;M :M GetStringWidth: ( psz -- width|0 ) 0 LVM_GETSTRINGWIDTH hwndLV Call SendMessage ;M :M InsertColumn: ( pcol icol -- index|-1 ) LVM_INSERTCOLUMN hwndLV Call SendMessage ;M :M SetColumn: ( pcol icol -- f ) LVM_SETCOLUMN hwndLV Call SendMessage ;M :M SetColumnWidth: ( cx -- ) -1 LVM_SETCOLUMNWIDTH hwndLV Call SendMessage drop ;M ( -------------------------------------------------------------------) ( Arranging, Sorting and Finding ) :M Arrange: ( code -- f ) 0 swap LVM_ARRANGE hwndLV Call SendMessage ;M :M FindItem: ( plvfi iStart -- index|-1 ) LVM_FINDITEM hwndLV Call SendMessage ;M :M GetNextItem: ( flags iStart -- index|-1 ) LVM_GETNEXTITEM hwndLV Call SendMessage ;M :M SortItems: ( pfnCompare lParamsort -- f ) LVM_SORTITEMS hwndLV Call SendMessage ;M ( -------------------------------------------------------------------) ( Items Positions and Scrolling ) :M EnsureVisible: ( fPartialOK i -- f ) LVM_ENSUREVISIBLE hwndLV Call SendMessage ;M :M GetCountPerPage: ( -- n ) 0 0 LVM_GETCOUNTPERPAGE hwndLV Call SendMessage ;M :M GetItemPosition: ( ppt i -- f ) LVM_GETITEMPOSITION hwndLV Call SendMessage ;M :M GetItemRect: ( prc i -- f ) LVM_GETITEMRECT hwndLV Call SendMessage ;M :M GetOrigin: ( lpptOrg -- f ) 0 LVM_GETORIGIN hwndLV Call SendMessage ;M :M GetTopIndex: ( -- index|0 ) 0 0 LVM_GETTOPINDEX hwndLV Call SendMessage ;M :M GetViewRect: ( prc -- f ) 0 LVM_GETVIEWRECT hwndLV Call SendMessage ;M :M HitTest: ( pinfo -- index|-1 ) 0 LVM_HITTEST hwndLV Call SendMessage ;M :M Scroll: ( dy dx -- f ) LVM_SCROLL hwndLV Call SendMessage ;M :M SetItemPosition: ( x y i -- f ) >r word-join r> LVM_SETITEMPOSITION hwndLV Call SendMessage ;M :M SetItemPosition32: ( lpptNewPos iItem -- f ) LVM_SETITEMPOSITION32 hwndLV Call SendMessage ;M ( -------------------------------------------------------------------) ( Colours ) :M GetBkColor: ( -- col ) 0 0 LVM_GETBKCOLOR hwndLV Call SendMessage ;M :M GetTextBkColor: ( -- col ) 0 0 LVM_GETTEXTBKCOLOR hwndLV Call SendMessage ;M :M GetTextColor: ( -- col ) 0 0 LVM_GETTEXTCOLOR hwndLV Call SendMessage ;M :M SetBkColor: ( clrBk -- f ) 0 LVM_SETBKCOLOR hwndLV Call SendMessage ;M :M SetTextBkColor: ( clrText -- f ) 0 LVM_SETTEXTBKCOLOR hwndLV Call SendMessage ;M :M SetTextColor: ( clrText -- f ) 0 LVM_SETTEXTCOLOR hwndLV Call SendMessage ;M ( -------------------------------------------------------------------) ( Miscellaneous ) :M CreateDragImage: ( lpptUpLeft iItem -- hndl|NULL ) LVM_CREATEDRAGIMAGE hwndLV Call SendMessage ;M :M EditLabel: ( iItem -- hndl|NULL ) 0 swap LVM_EDITLABEL hwndLV Call SendMessage ;M :M GetEditControl: ( -- ) 0 0 LVM_GETEDITCONTROL hwndLV Call SendMessage ;M :M GetImageList: ( iImageList -- hndl|NULL ) 0 swap LVM_GETIMAGELIST hwndLV Call SendMessage ;M :M SetImageList: ( himl iImageList -- hndl|NULL ) LVM_SETIMAGELIST hwndLV Call SendMessage ;M ( -------------------------------------------------------------------) ( -Window Message Processing performed by a list contol- ) :M WM_CHAR: ( -- ) ;M :M WM_COMMAND: ( -- ) ;M :M WM_CREATE: ( -- ) ;M :M WM_DESTROY: ( -- ) ;M :M WM_ERASEBKGND: ( -- ) ;M :M WM_GETDLGCODE: ( -- ) ;M :M WM_GETFONT: ( -- ) ;M :M WM_HSCROLL: ( -- ) ;M :M WM_KEYDOWN: ( -- ) ;M :M WM_KILLFOCUS: ( -- ) ;M :M WM_LBUTTONDBLCLK: ( -- ) ;M :M WM_LBUTTONDOWN: ( -- ) ;M :M WM_NCCREATE: ( -- ) ;M :M WM_NOTIFY: ( h m w l -- ) dup @ to nmhdr Getcode: nmhdr ( A list view control sends notification ( messages to its owner window when events occur in the control. ) case LVN_BEGINDRAG OF @ to nmlv ENDOF // NM_LISTVIEW LVN_BEGINLABELEDITA OF @ to lvdi ENDOF // LV_DISPINFO LVN_BEGINRDRAG OF @ to nmlv ENDOF // NM_LISTVIEW LVN_COLUMNCLICK OF @ to nmlv ENDOF // NM_LISTVIEW LVN_DELETEALLITEMS OF @ to nmlv ENDOF // NM_LISTVIEW LVN_DELETEITEM OF @ to nmlv ENDOF // NM_LISTVIEW LVN_ENDLABELEDITA OF @ to lvdi ENDOF // LV_DISPINFO LVN_GETDISPINFOA OF @ to lvdi ENDOF // LV_DISPINFO LVN_INSERTITEM OF @ to nmlv ENDOF // NM_LISTVIEW LVN_ITEMCHANGED OF @ to nmlv ENDOF // NM_LISTVIEW LVN_ITEMCHANGING OF @ to nmlv ENDOF // NM_LISTVIEW LVN_KEYDOWN OF @ to lvkd ENDOF // LV_KEYDOWN LVN_SETDISPINFOA OF @ to lvdi ENDOF // LV_DISPINFO endcase ;M :M WM_NCCREATE: ( -- ) ;M :M WM_NCDESTROY: ( -- ) ;M :M WM_PAINT: ( -- ) ;M :M WM_RBUTTONDOWN: ( -- ) ;M :M WM_SETFOCUS: ( -- ) ;M :M WM_SETFONT: ( -- ) ;M :M WM_SETREDRAW: ( -- ) ;M :M WM_TIMER: ( -- ) ;M :M WM_VSCROLL: ( -- ) ;M :M WM_WINDOWPOSCHANGED: ( -- ) ;M :M WM_WININICHANGE: ( -- ) ;M ;Class \ s A simple demo: ( -------------------------------------------------------------------) ( -------------------------------------------------------------------) ( Example ) ( Get it all started just to see if it works ) 0 value bb :Object aa <super Window ColorObject FrmColor \ the background color :M ClassInit: ( -- ) ClassInit: super ;M :M WindowStyle: ( -- style ) WS_OVERLAPPEDWINDOW ;M :M StartSize: ( -- width height ) 400 200 ;M :M StartPos: ( -- x y ) 0 0 ;M :M On_Size: ( -- ) gethandle: bb if 1 ( repaint flag ) tempRect.AddrOf GetClientRect: Self Bottom: tempRect Right: tempRect 0 0 gethandle: bb Call MoveWindow drop then ;M :M On_Done: ( h m w l -- res ) On_Done: super 0 ;M ;Object :Class Test <Super Object \ int aa ( window ) \ int bb ( Listview ) int hiconItem // HICON hiconItem; // icon for list view items int himlLarge // HIMAGELIST himlLarge; // image list for icon view int himlSmall // HIMAGELIST himlSmall; // image list for other views :M ClassInit: ( -- ) ;M :M ~: ( -- ) ;M LV_COLUMN lvc : InitListViewColumns ( -- ) LVCF_FMT LVCF_WIDTH LVCF_TEXT LVCF_SUBITEM or or or Setmask: lvc LVCFMT_LEFT Setfmt: lvc 120 Setcx: lvc z" Columns 1" SetpszText: lvc Addr: lvc 1 InsertColumn: bb -1 = if ." Not Successful " cr then z" Columns 2" SetpszText: lvc Addr: lvc 2 InsertColumn: bb -1 = if ." Not Successful " cr then z" Columns 3" SetpszText: lvc Addr: lvc 3 InsertColumn: bb -1 = if ." Not Successful " cr then z" Columns 4" SetpszText: lvc Addr: lvc 4 InsertColumn: bb -1 = if ." Not Successful " cr then ; LV_ITEM lv1 LV_ITEM lv2 LV_ITEM lv3 LV_ITEM lv4 : InitListViewItems ( -- ) LVIF_TEXT SetMask: lv1 0 SetiItem: lv1 z" subitem 1" SetpszText: lv1 LVIF_TEXT SetMask: lv2 1 SetiItem: lv2 z" subitem 2" SetpszText: lv2 LVIF_TEXT SetMask: lv3 2 SetiItem: lv3 z" subitem 3" SetpszText: lv3 LVIF_TEXT SetMask: lv4 3 SetiItem: lv4 z" subitem 4" SetpszText: lv4 Addr: lv1 InsertItem: bb drop Addr: lv2 InsertItem: bb drop Addr: lv3 InsertItem: bb drop Addr: lv4 InsertItem: bb drop LVIF_TEXT SetMask: lv2 1 SetiItem: lv2 2 SetiSubItem: lv2 z" s0" SetpszText: lv2 Addr: lv2 SetItem: bb ; :M Start: ( -- ) \ new> Window to aa new> listview to bb WS_CHILD WS_VISIBLE or LVS_REPORT or LVS_EDITLABELS or WS_BORDER or SetStyleListView: bb \ Set the syle for the listview start: aa aa start: bb InitListViewColumns ." Done Ok" cr InitListViewItems ." Done Ok" cr 0 0 GetSize: aa Move: aa \ To force the listview to be seen ;M Point ppt Record: _Rect int left int top int right int bottom ;RecordSize: /Rect :M Test1: ( -- ) GetBkColor: bb ." The background colour is = " . cr GetTextBkColor: bb ." The text background colour is = " . cr GetTextColor: bb ." The text colour is = " . cr GetCountPerPage: bb ." Count per page " . cr Addr: ppt 1 GetItemPosition: bb if ." Item position " getpt: ppt swap . . cr then LVIR_BOUNDS _Rect GetItemRect: bb if ." Bounds: Item Rect (l,t,r,b) " left . top . right . bottom . cr then LVIR_ICON _Rect GetItemRect: bb if ." Icon: Item Rect (l,t,r,b) " left . top . right . bottom . cr then LVIR_LABEL _Rect GetItemRect: bb if ." Label: Item Rect (l,t,r,b) " left . top . right . bottom . cr then LVIR_SELECTBOUNDS _Rect GetItemRect: bb if ." Select: Item Rect (l,t,r,b) " left . top . right . bottom . cr then Addr: ppt GetOrigin: bb if ." Origin " getpt: ppt swap . . cr then GetTopIndex: bb ." Top Index " . cr _Rect GetViewRect: bb if ." View Rect (l,t,r,b) " left . top . right . bottom . cr then ;M ;Class Test tt Start: tt Test1: tt ( -------------------------------------------------------------------) |
×
Want the latest updates on software, tech news, and AI?
Get latest updates about software, tech news, and AI from SourceForge directly in your inbox once a month.
Thanks for helping keep SourceForge clean.
X