[Win32forth-cvs] win32forth/demos ListViewDemo.f,NONE,1.1

SourceForge Headquarters 225 Broadway Suite 1600 San Diego, CA 92101 +1 (858) 422-6466

Update of /cvsroot/win32forth/win32forth/demos
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv22065/demos

Added Files:
	ListViewDemo.f 
Log Message:
Jos: A demo to show some interactions with a listview in a splitter window

--- NEW FILE: ListViewDemo.f ---
\ ForthForm generated splitter-window template
\ Modify according to your needs
\ A primarly demo to show some interactions with a ListView

Anew -ListViewDemo

Needs NoConsole.f
Needs gdi/gdi.f
Needs Resources.f
Needs ListView.f

0 value turnkey?
0 value ListViewRightBottom
0 value ListViewLeft
20 constant FontHeight

LV_ITEM LvItem
\ LV_ITEM LvItem

defer OnPosition  ( window -- ) ' drop is OnPosition \ called when window panes are repositioned
defer OnInit    ( window -- ) ' drop is OnInit \ called during window On_init method
\- 2+ : 2+  2 + ;


:Object RightTopPane        <Super Child-Window
int lparmLeft
String: Out$
Font vFont

:M out$:             ( - adrOt$ ) out$  ;M
:M ExWindowStyle:    ( -- style )   ExWindowStyle: Super  WS_EX_CLIENTEDGE or ;M

:M On_Init:     ( -- )
                14 Width: vFont
                FontHeight Height: vFont
                s" Courier" SetFaceName: vFont
                Create: vFont
                 ;M

:M On_Paint:    ( -- )
                Out$ c@ 0<>
                     if  SaveDC: dc                      \ save device context
                         GetSize: Self white Fillarea: dc
                         vFont    SelectObject: dc
                         ltblue   SetTextColor: dc
                         TA_CENTER SetTextAlign: dc drop
                         GetSize: self 10 -  swap 2/ swap 4 / 2dup
                         Out$ zcount pad place
                         s"  lParam:"  pad +place
                         lparmLeft 0  (D.) pad +place pad +null
                         pad count  Textout: dc
                         RestoreDC: dc
                     then
 ;M

:M ShowLeftSelected: ( Z$text Lparm flNew - )
    if     to lparmLeft drop paint: Self
    else   2drop
    then
 ;M

;Object


:Object LeftPane        <Super Child-Window

int SelectedItemLeft

:M ExWindowStyle:    ( -- style )  ExWindowStyle: Super WS_EX_CLIENTEDGE or ;M

:M On_Size:     ( -- )
                gethandle: ListViewLeft
                   if   1 ( repaint flag )
                        tempRect.AddrOf GetClientRect: Self
                        Bottom: tempRect Right: tempRect   0 0
                        gethandle: ListViewLeft Call MoveWindow drop
                   then
                ;M


: GetParmsItem ( nItem  - Z$text Lparm flNew )
        LVIF_TEXT LVIF_PARAM or SetMask: LvItem
        out$: RightTopPane SetpszText: LvItem
        maxstring SetcchTextMax: LvItem
        SetiItem: LvItem
        Addr: LvItem GetItem: ListViewLeft drop  out$: RightTopPane
        GetlParam: LvItem dup SelectedItemLeft <>
            if     dup to SelectedItemLeft true
            else   false
            then
 ;

: HandleListViewLeft   ( msg - )
   LVNI_SELECTED -1 GetNextItem:  ListViewLeft dup  -1 =
    if    drop
    else  GetParmsItem  ShowLeftSelected:  RightTopPane
    then
 ;

:M WM_NOTIFY    ( h m w l -- f )
    dup @ GetHandle: ListViewLeft = \ EnableNotify? and
        if  HandleListViewLeft
        then false
   ;M

:M Start: ( - ) start: super -1 to SelectedItemLeft Self start: ListViewLeft ;M

;Object


:Object RightBottomPane        <Super Child-Window
\ Modify this object according to your needs

:M ExWindowStyle:    ( -- style )   ExWindowStyle: Super WS_EX_CLIENTEDGE or ;M

:M On_Size:     ( -- )
                gethandle: ListViewRightBottom
                   if   1 ( repaint flag )
                        tempRect.AddrOf GetClientRect: Self
                        Bottom: tempRect Right: tempRect   0 0
                        gethandle: ListViewRightBottom Call MoveWindow drop
                   then
                ;M

:M Start:     start: super     Self start: ListViewRightBottom   ;M
;Object

MENUBAR TestBar
    POPUP "&File"
        MENUITEM     "Bye"    bye ;
ENDBAR


:Object SplitterWindow        <Super Window

0 value toolbarH    \ set to height of toolbar if any
0 value statusbarH  \ set to height of status bar if any
0 value clicked
0 value wline
0 value SeparatorX
0 value SeparatorY

:M ClassInit:     ( -- )
                ClassInit: super
                \ Insert your code here
                ;M

: 0position-windows ( -- ) \ auto adjust windows
                0 toolbarH SeparatorX 1- Height toolbarH - statusbarH - Move: LeftPane
                SeparatorX 2+ dup>r toolbarH Width r@ - SeparatorY 1- toolbarH - Move: RightTopPane
                r@ SeparatorY 2+ Width r> - Height 2 pick - statusbarH - Move: RightBottomPane
                self OnPosition ;

: position-windows ( -- ) \ auto adjust windows
                0 toolbarH SeparatorX 1- Height toolbarH - statusbarH - Move: LeftPane
                SeparatorX 2+ dup>r toolbarH Width r@ - SeparatorY 1- 25 min toolbarH - Move: RightTopPane
                r@ SeparatorY 2+ 25 min Width r> - Height 2 pick - statusbarH - Move: RightBottomPane
                self OnPosition ;

: horizline      ( -- )
               \ SeparatorX 2+ SeparatorY  MoveTo: dc
               \ Width SeparatorY LineTo: dc
                ;

: vertline      ( -- )
                SeparatorX 0 MoveTo: dc
                SeparatorX Height LineTo: dc  ;

: ?line         ( -- )
                wline
                if       vertline
                else     horizline
                then     ;

: on_clicked    ( -- )
                true to clicked
                get-dc
                R2_NOT SetRop2: dc
                black LineColor: dc
                mousex SeparatorX = mousex SeparatorX 1+ = or
                if      vertline true to wline
                else    horizline false to wline
                then    hwnd Call SetCapture drop ;

: On_Mousemove  ( -- )
                mousex SeparatorX =
                mousex SeparatorX 1+ = or
                if      SIZEWE-CURSOR exit
                then    mousey Separatory =
                mousey Separatory 1+ = or
                if      SIZENS-CURSOR 
                else    arrow-cursor
                then    ;

:M WM_MOUSEMOVE ( h w m l -- res )
                WM_MOUSEMOVE WM: super
                on_mousemove ;M

: dosizing      ( -- )
                clicked 0= ?exit
                ?line
                \ a minimum width of 4 pixels for windows are set, but it can be changed
                mousex 2 cells < mousex width 2 cells - > or
                mousey 2 cells < mousey height 2 cells - > or or
                if      position-windows
                        false to clicked
                        release-dc
                        hwnd Call ReleaseCapture ?win-error
                else    wline
                        if      mousex to SeparatorX
                        else    mousey to SeparatorY
                        then    ?line
                then    ;

: on_unclicked  ( -- )
                clicked 0= ?exit
                ?line
                position-windows
                release-dc
                false to clicked
                hwnd Call ReleaseCapture ?win-error ;

:M StartSize:   ( -- w h )
                screen-size >r 2/ r> 2/ ;M

:M On_Size:     ( -- )
                position-windows ;M

:M On_Init:     ( -- )
                ['] dosizing to track-func
                ['] on_clicked to click-func
                ['] on_unclicked to unclick-func

                395  Setid: LeftPane
                self Start: LeftPane
                396  Setid: RightTopPane
                self Start: RightTopPane
                397  Setid: RightBottomPane
                self Start: RightBottomPane

                self OnInit    \ perform user function

                Startsize: self 2 / to SeparatorY 5 / to SeparatorX
        TestBar  SetMenuBar:  self

                position-windows ;M

:M InitListViewItems: ( -- )

        LVIF_TEXT LVIF_PARAM or SetMask:    LvItem  \ SetMask: Also erases old parameters
        0                       SetiItem:   LvItem
        31                      SetlParam:  LvItem
        z" Sweden"              SetpszText: LvItem
        Addr: LvItem            InsertItem: ListViewLeft

        LVIF_TEXT LVIF_PARAM or SetMask:    LvItem
        1+                      SetiItem:   LvItem
        32                      SetlParam:  LvItem
        z" Germany"             SetpszText: LvItem
        Addr: LvItem            InsertItem: ListViewLeft

        LVIF_TEXT               SetMask:    LvItem
        1+                      SetiItem:   LvItem
        z" America"             SetpszText: LvItem
        Addr: LvItem            InsertItem: ListViewLeft drop


        LVIF_TEXT LVIF_PARAM or SetMask:    LvItem
        0                       SetiItem:   LvItem
        41                      SetlParam:  LvItem
        z" Gordon"              SetpszText: LvItem
        Addr: LvItem            InsertItem: ListViewRightBottom


        LVIF_TEXT LVIF_PARAM or SetMask:    LvItem
        1+                      SetiItem:   LvItem
        42                      SetlParam:  LvItem
        z" Jack"                SetpszText: LvItem
        Addr: LvItem            InsertItem: ListViewRightBottom


        LVIF_TEXT               SetMask:     LvItem  \ Inserting a subitem
                                SetiItem:    LvItem  \ Uses the index from "Jack"
        2                       SetiSubItem: LvItem
        z" 2043 VD"             SetpszText:  LvItem
        Addr: LvItem            SetItem:     ListViewRightBottom


        LVIF_TEXT LVIF_PARAM or SetMask:    LvItem
        1+                      SetiItem:   LvItem
        43                      SetlParam:  LvItem
        z" Vern"                SetpszText: LvItem
        Addr: LvItem            InsertItem: ListViewRightBottom drop

;M

:M On_Done:     ( h m w l -- res )
        Close: self
        0 call PostQuitMessage drop
        On_Done: super 0 ;M


;Object


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" Location"              SetpszText: lvc
      Addr: lvc 1               InsertColumn: ListViewLeft

      z" Contact"               SetpszText: lvc
      Addr: lvc swap            InsertColumn: ListViewRightBottom

      z" Street and number"     SetpszText: lvc
      Addr: lvc swap            InsertColumn: ListViewRightBottom

      z" Postal code"           SetpszText: lvc
      Addr: lvc swap            InsertColumn: ListViewRightBottom

      z" Place"                 SetpszText: lvc
      Addr: lvc swap            InsertColumn: ListViewRightBottom  drop
;


:Class ListViewClass <Super Object

:M ClassInit: ( -- ) ;M
:M ~: ( -- ) ;M


:M Start: ( -- )

\ new> Window to aa
new> listview to ListViewRightBottom
new> listview to ListViewLeft

        WS_CHILD
        WS_VISIBLE or
        LVS_REPORT or
        LVS_EDITLABELS or
        WS_BORDER or
        SetStyleListView: ListViewRightBottom  \ Set the syle for the listview

        WS_CHILD
        WS_VISIBLE or
        LVS_REPORT or
        LVS_SORTASCENDING or  \ Automatic sorting
        LVS_EDITLABELS or
        WS_BORDER or
        SetStyleListView: ListViewLeft  \ Set the syle for the listview

        start: SplitterWindow
        InitListViewColumns
        InitListViewItems: SplitterWindow

        0 0 GetSize: SplitterWindow  Move: SplitterWindow  \ To force the listview to be seen

;M

Point ppt

        Record: _Rect
        int left
        int top
        int right
        int bottom
        ;RecordSize: /Rect

;Class

ListViewClass tt

: main  ( - ) Start: tt   turnkey?   if   MessageLoop bye   then  ;

turnkey? [if]
        NoConsoleIO  NoConsoleInImage
        ' main turnkey Qds.exe
\        s" WIN32FOR.ICO" s" Qds.exe" AddAppIcon
        1 pause-seconds bye
[else]
         main
\        s" WIN32FOR.ICO" s" Qds.exe" AddAppIcon

[then]
\s