win32forth-cvs — CVS Commit List

[Win32forth-cvs] win32forth-stc/src Utils.f,1.2,1.3

[George H. <geo...@us...>]

Update of /cvsroot/win32forth/win32forth-stc/src
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv30780/win32forth-stc/src

Modified Files:
	Utils.f 
Log Message:
gah:Modified random to use fm/mod since it relies on floored division

Index: Utils.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/Utils.f,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** Utils.f	3 May 2007 09:00:02 -0000	1.2
--- Utils.f	9 May 2007 07:28:44 -0000	1.3
***************
*** 662,669 ****
  \ *G Get a pseudo random number between 0 and n1 as n2. n2 has the same sign as n1.
                  dup 0= if 1+ then
!                 SEED1 177 /MOD  2*    SWAP  171 *  SWAP  - DUP  to SEED1
!                 SEED2 176 /MOD  35 *  SWAP  172 *  SWAP  - DUP  to SEED2
!                 SEED3 178 /MOD  63 *  SWAP  170 *  SWAP  - DUP  to SEED3
!                 +  + SWAP  MOD  ;
  
  : RANDOM-INIT   ( -- )          \ W32F  Utils
--- 662,669 ----
  \ *G Get a pseudo random number between 0 and n1 as n2. n2 has the same sign as n1.
                  dup 0= if 1+ then
!                 SEED1 s>d 177 fm/MOD  2*    SWAP  171 *  SWAP  - DUP  to SEED1
!                 SEED2 s>d 176 fm/MOD  35 *  SWAP  172 *  SWAP  - DUP  to SEED2
!                 SEED3 s>d 178 fm/MOD  63 *  SWAP  170 *  SWAP  - DUP  to SEED3
!                 +  + s>d rot fm/MOD drop  ;
  
  : RANDOM-INIT   ( -- )          \ W32F  Utils

[Win32forth-cvs] win32forth-stc/src BUTTON.F, NONE, 1.1 CHILDWND.F, 1.1, 1.2 Class.f, 1.5, 1.6 Menu.f, 1.2, 1.3

[George H. <geo...@us...>]

Update of /cvsroot/win32forth/win32forth-stc/src
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv23229/win32forth-stc/src

Modified Files:
	CHILDWND.F Class.f Menu.f 
Added Files:
	BUTTON.F 
Log Message:
gah:Added button.f and a few bug fixes.

--- NEW FILE: BUTTON.F ---
\ $Id: BUTTON.F,v 1.1 2007/05/08 08:34:39 georgeahubert Exp $
\ button.f

Require controls.f
REquire childwnd.f

cr .( Loading Button and ToolBar...)

125 value defbwidth     \ should be an ODD number for things to work well
 25 value defbheight

INTERNAL        \ definitions accessible while defining a buttonbar

:Class Button           <super Control

int bprev
int bfunc
int bheight
int bwidth

:M ClassInit:   ( -- )
                ClassInit: super
                s" Button" binfo place
                defbwidth  to bwidth
                defbheight to bheight
                ;M

:M SetPrev:     ( bprev -- ) to bprev ;M
:M GetPrev:     ( -- bprev ) bprev ;M

:M GetBwidth:   ( -- button_width )
                bwidth
                ;M

:M SetBwidth:   ( button_width -- )
                to bwidth
                ;M

:M GetBheight:  ( -- button_height )
                bheight
                ;M

:M SetBheight:  ( button_height -- )
                to bheight
                ;M

:M WindowStyle: ( -- style )
                WindowStyle: SUPER
                BS_PUSHBUTTON   or ;M

:M Start:       ( parent -- )
                to parent
                z" BUTTON" create-control
                ;M

:M amForground?: ( -- f1 )
                Call GetForegroundWindow
                GetHandle: [ GetParent: parent ] =      \ foreground window?
                ;M

:M RemoveFocus: ( -- f1 )
                TRUE
                ;M

:M DoButton:    ( -- )
                clear-info
                hWnd get-mouse-xy hWnd in-button?
                if      bfunc execute
                then
                ;M

:M On_LButtonUp: ( h m w l -- )
                old-wndproc CallWindowProc drop
                 ;M

:M WM_LBUTTONUP ( h m w l -- res )
                FALSE to mouse-is-down?
                On_LButtonUp: [ self ]
                0 ;M

:M WM_LBUTTONDOWN ( h m w l -- res )
                TRUE to mouse-is-down?
                old-wndproc CallWindowProc
                 ;M

;Class

EXTERNAL        \ always user accessible definitions

  0 value BuildBar

\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\       Define a Generic Push Button Bar class
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

:CLASS Generic-ButtonBar  <Super Child-Window

\ -------------------- Instance Variables --------------------

int hbb         \ Handle to the button bar
int hb          \ handle to current button
int bid         \ button id counter
int bcnt        \ count of buttons in bar

int floatBar

\ -------------------- Methods --------------------

:M ClassInit:   ( -- )
                ClassInit: super
                self to BuildBar
                  0 to hbb
                  0 to hb
                100 to bid
                  0 to bcnt
                  0 to floatBar
\in-system-ok   also hidden
                ;M

:M GetBar:      ( -- hbb )  hbb  ;M
:M PutBar:      ( hbb -- )  to hbb  ;M

:M GetBCnt:     ( -- bcnt ) bcnt ;M
:M PutBCnt:     ( bcnt -- ) to bcnt ;M

:M NextBid:      ( -- bid )
                bid dup 1+ to bid ;M

:M SetButtonWidth:  ( width --  )       to defbwidth ;M
:M SetButtonHeight: ( height -- )       to defbheight ;M

:M On_Button:   { bidl \ hbl -- }
                hbb to hbl                   \ init the chain
                begin   hbl
                while   bidl GetID: hbl =
                        if      RemoveFocus: hbl
                                IF      SetFocus: parent
                                THEN
                                DoButton: hbl
                                0 to hbl
                        else    GetPrev: hbl to hbl
                        then
                repeat
                ;M

:M OnWmCommand: ( hwnd msg wparam lparam -- hwnd msg wparam lparam )
                OnWmCommand: Super
                over LOWORD ( ID ) On_Button: self
                ;M

:M On_Init:     { \ hbl -- }         \ initialize the class
                On_Init: Super
                hbb to hbl                      \ init the chain
                begin   hbl
                while   self                    \ the window handle
                        Start: hbl              \ start the button
                        GetPrev: hbl to hbl     \ select the next button
                repeat  drop
                ;M

:M On_Done:     { \ hbl -- }         \ initialize the class
                hbb to hbl                      \ init the chain
                begin   hbl
                while   self                    \ the window handle
                        Close: hbl              \ start the button
                        GetPrev: hbl to hbl     \ select the next button
                repeat  drop
                On_Done: Super
                ;M


:M WM_LBUTTONUP ( h m w l -- res )
                SetFocus: parent
                WM_LBUTTONUP WM: Super
                ;M

:M WindowStyle: ( -- style )            \ return the window style
                floatBar
                IF
                        WS_OVERLAPPEDWINDOW
                ELSE    WindowStyle: super
                THEN
                ;M

:M Start:       ( parent -- )
                floatBar
                IF      drop
                        register-frame-window drop
                        create-frame-window to hWnd
                        SW_SHOWNORMAL Show: self
                        Update: self
                ELSE    Start: Super
                THEN
                ;M

;CLASS


\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\       Define a Vertical Push Button Bar
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

:CLASS VButtonBar       <Super  Generic-ButtonBar       \ RIGHT VERTICAL


int bvoffset    \ Vertical offset


:M StartSize:   ( -- width height )     \ starting window size
                hbb to hb                       \ init the chain
                0
                begin   hb
                while   GetBwidth: hb max
                        GetPrev: hb to hb
                repeat  4 +                     \ total height of buttons
                hbb to hb                       \ init the chain
                0
                begin   hb
                while   GetBheight: hb 2 + +
                        GetPrev: hb to hb
                repeat  2 +                     \ total height of buttons
                ;M

:M StartPos:    ( -- x y )              \ Starting Position
                GetSize: parent >r
                StartSize: self drop - r>
                ;M

: button+v      ( -- n1 )
                bvoffset
                dup
                GetBheight: hb + 2 + to bvoffset ;

:M On_Size:     ( -- )                  \ handle resize message
                hbb to hb                       \ init the chain
                2 to bvoffset
                begin   hb
                while   2 button+v GetBwidth: hb GetBheight: hb Move: hb
                        GetPrev: hb to hb
                repeat
                ;M

;CLASS

\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\       Define a Horizontal Push Button Bar
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

:CLASS BHButtonBar      <Super  Generic-ButtonBar       \ BOTTOM HORIZONTAL


int bhoffset    \ horizontal offset

:M StartSize:   ( -- width height )     \ starting window size
                hbb to hb                       \ init the chain
                0
                begin   hb
                while   GetBwidth: hb 2 + +
                        GetPrev: hb to hb
                repeat  2 +                     \ total width of buttons
                hbb to hb                       \ init the chain
                0
                begin   hb
                while   GetBheight: hb max
                        GetPrev: hb to hb
                repeat  4 +                     \ tallest button controls height
                ;M

:M StartPos:    ( -- x y )              \ Starting Position
                GetSize: parent
                StartSize: self nip -
                ;M

: button+h      ( -- n1 )
                bhoffset
                dup
                GetBwidth: hb + 2 + to bhoffset ;

:M On_Size:     ( -- )                  \ handle resize message
                hbb to hb                       \ init the chain
                2 to bhoffset
                begin   hb
                while   button+h 2
                        GetBwidth: hb GetBheight: hb Move: hb
                        GetPrev: hb to hb
                repeat
                ;M

;CLASS


:CLASS HButtonBar       <Super  Generic-ButtonBar       \ TOP HORIZONTAL


int bhoffset    \ horizontal offset

:M StartSize:   ( -- width height )     \ starting window size
                hbb to hb                       \ init the chain
                0
                begin   hb
                while   GetBwidth: hb 2 + +
                        GetPrev: hb to hb
                repeat  2 +                     \ total width of buttons
                hbb to hb                       \ init the chain
                0
                begin   hb
                while   GetBheight: hb max
                        GetPrev: hb to hb
                repeat  4 +                     \ highest button
                ;M

:M StartPos:    ( -- x y )              \ Starting Position
                0 0
                ;M

: button+h      ( -- n1 )
                bhoffset
                dup
                GetBwidth: hb + 2 + to bhoffset ;

:M On_Size:     ( -- )                  \ handle resize message
                hbb to hb                       \ init the chain
                2 to bhoffset
                begin   hb
                while   button+h 2
                        GetBwidth: hb GetBheight: hb Move: hb
                        GetPrev: hb to hb
                repeat
                ;M

;CLASS


\ HButtonBar Chro-buttons
\
\       50 SetButtonWidth: Chro-buttons
\
\       'X' +k_control AddKeyButton  EXIT "Analyze"
\       ' function AddFuncButton FUNC "myFunc"

\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\       Define a Lower Right Push Button Bar
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

:CLASS LRButtonBar      <Super  Generic-ButtonBar       \ LOWER RIGHT

:M ClassInit:   ( -- )
                ClassInit: super
                ;M

:M StartSize:   ( -- width height )     \ starting window size
                hbb to hb               \ init the chain
                0
                begin   hb
                while        GetOrigin: hb drop
                             GetBWidth: hb + max
                               GetPrev: hb to hb
                repeat  4 +             \ total height of buttons
                hbb to hb               \ init the chain
                0
                begin   hb
                while        GetOrigin: hb nip
                            GetBHeight: hb + max
                               GetPrev: hb to hb
                repeat  2 +             \ total height of buttons
                ;M

:M StartPos:    ( -- x y )              \ Starting Position
                StartSize: self         \ my size
                GetSize: parent         \ parents size
                rot - >r - r>           \ put me in lower right hand corner
                ;M

:M On_Size:     ( -- )                  \ handle resize message
                hbb to hb               \ init the chain
                begin   hb
                while        GetOrigin: hb
                             GetBWidth: hb
                            GetBHeight: hb
                                  Move: hb
                               GetPrev: hb to hb
                repeat
                ;M

;CLASS

INTERNAL        \ definitions accessible while defining a buttonbar

\ HButtonBar Chro-buttons
\
\       AddButton "myFunc"   ... forth code ... ;

|CLASS AddButton        <Super Button

in-system

warning off

: (ClassInit)   ( -- )
                [ warning on ]
                ClassInit: super
                GetBar: BuildBar to bprev       \ end of link is NULL
                bprev 0=                        \ if i'm the first one
                if      self PutBar: BuildBar   \ put me in the bar
                else    begin   bprev
                        while   bprev to id            \ save here temp
                                GetPrev: bprev to bprev
                        repeat  self SetPrev: id       \ temp use
                        0 SetPrev: self
                then
                NextBid: BuildBar to id
                here to title ,"text"
                GetBCnt: BuildBar 1+ PutBCnt: BuildBar      \ bump count
                :noname to bfunc
                !csp
                ;

in-application

:m ClassInit:   ( -- )
\in-system-ok   (ClassInit) ;m

;Class


\       LRButtonBar BARNAME
\       x y width height AddXYButton "myFunc"  ... forth code ... ;

-1 constant 1/1
-3 constant 1/4
-4 constant 2/4
-5 constant 3/4
-6 constant 4/4
-7 constant 1/2
-8 constant 2/2

|CLASS AddXYButton    <Super Button

int bx
int by

:M GetOrigin:   ( -- x y )
                bx by
                ;M

in-system

warning off

: (ClassInit)   ( x y width height -- )
                [ warning on ]
                ClassInit: super
                to bheight
                dup -1 = if drop defbwidth                      then
                dup -2 = if drop defbwidth 2/                   then
                dup -3 = if drop defbwidth 2/ 2/ 1-             then
                dup -4 = if drop defbwidth 2/                   then
                dup -5 = if drop defbwidth 2/ dup 2/ +          then
                dup -6 = if drop defbwidth                      then
                dup -7 = if drop defbwidth 2/                   then
                dup -8 = if drop defbwidth 2/                   then
                0max to bwidth
                to by
                dup -1 = if drop 2                              then
                dup -2 = if drop defbwidth 2/ 3 +               then
                dup -3 = if drop 2                              then
                dup -4 = if drop defbwidth 2/ 2/ 3 +            then
                dup -5 = if drop defbwidth 2/    3 +            then
                dup -6 = if drop defbwidth 2/ dup 2/ + 3 +      then
                dup -7 = if drop 2                              then
                dup -8 = if drop defbwidth 2/ 3 +               then
                0max to bx
                GetBar: BuildBar to bprev       \ end of link is NULL
                bprev 0=                        \ if i'm the first one
                if      self PutBar: BuildBar   \ put me in the bar
                else    begin   bprev
                        while   bprev to id            \ save here temp
                                GetPrev: bprev to bprev
                        repeat  self SetPrev: id       \ temp use
                        0 SetPrev: self
                then
                NextBid: BuildBar to id
                here to title ,"text"
                GetBCnt: BuildBar 1+ PutBCnt: BuildBar      \ bump count
                :noname to bfunc
                !csp
                ;

in-application

:M ClassInit:   ( x y width height -- )
\in-system-ok   (ClassInit) ;m

;Class

\ Usage:  <pixels> HSpace
\ Spaces over <pixels> on the toolbar.
\ using a value of -1 for <pixels> will split the
\ toolbar and start another line

|CLASS HSpace   <Super Button

:M ClassInit:   ( n1 -- )
                ClassInit: super
                to bwidth
                GetBar: BuildBar to bprev       \ end of link is NULL
                bprev 0=                        \ if i'm the first one
                if      self PutBar: BuildBar   \ put me in the bar
                else    begin   bprev
                        while   bprev to id            \ save here temp
                                GetPrev: bprev to bprev
                        repeat  self SetPrev: id       \ temp use
                        0 SetPrev: self
                then
                NextBid: BuildBar to id
                0 to title
                GetBCnt: BuildBar 1+ PutBCnt: BuildBar      \ bump count
                ['] noop to bfunc
                ;M


:M Start:       ( parent -- )
                to parent
                ;M

:M Move:        ( x y x y -- )
                4drop
                ;M

;Class

\ BitMap data structures for use with bit mapped tool bars

 create BMPheader
         here                            nostack1
         0 w,    \ bftype        +0
         0 ,     \ bfsize        +2
         0 w,    \ reserved      +6
         0 w,    \ reserved      +8
         0 ,     \ bfOffBits     +10
         here swap - constant sizeof(BMPheader)

 create BMPinfoheader
         here                            nostack1
         0 ,     \ biSize        +0
         0 ,     \ biWidth       +4
         0 ,     \ biHeight      +8
         0 w,    \ biPlanes      +12
         0 w,    \ biBitCount    +14
         0 ,     \ biCompression
         0 ,     \ biSizeImage
         0 ,     \ biXPelsPerMeter
         0 ,     \ biYPelsPerMeter
         0 ,     \ biClrUsed
         0 ,     \ biClrImportant
         here over - swap !

 BMPinfoheader @ constant sizeof(BMPinfoheader)

 create BMPrect
         0 ,     \ left
         0 ,     \ top
         0 ,     \ right
         0 ,     \ bottom

 4 constant sizeof(RGBQUAD)

 24 constant sizeof(BMPbitmap)
             create BMPbitmap sizeof(BMPbitmap) allot

EXTERNAL

23 value DefToolHeight
24 value DefToolWidth
-1 value DefToolSpacing         \ one pixel overlap between buttons

\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\       Define the Button Bar for Exec
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

:Class ToolBar  <Super  Generic-ButtonBar

int bhoffset                            \ horizontal offset
int bvoffset                            \ vertical   offset
int toolwidth
int toolheight
int tool-spacing                        \ space between buttons
int bar-name
int started?
int bmp-adr
int bmp-len
int bmp-off
int picture-bitmap
int prev-bitmap

Windc picture-dc

 3 constant border-width
 3 constant vertical-offset
 0 constant horizontal-offset

:M ClassInit:   ( -<toolbarname>- )     \ follow by .BMP toolbar filename
                ClassInit: super
                DefToolWidth   to toolwidth
                DefToolHeight  to toolheight
                DefToolSpacing to tool-spacing
                here to bar-name ,"text"
                FALSE to started?
                0 to picture-bitmap
                0 to prev-bitmap
                0 to bmp-adr
                0 to bmp-len
                0 to bmp-off
                bar-name c@
                if      bar-name count "OPEN abort" Couldn't open the ToolBar bitmaps"
                        >r
                        here               to bmp-adr           \ set the bmp address
                        r@ file-size 2drop to bmp-len           \ set the bmp length
                        bmp-len allot                           \ allocate the space
                        bmp-adr bmp-len r@ read-file 2drop      \ read the bmp file
                        r> close-file drop                      \ close file
                then
                ;M

: read-bmp      ( a1 n1 -- )
                >r
                bmp-adr bmp-len bmp-off /string >r swap
                r> r> min dup>r move
                r> +to bmp-off ;

:M GetWinDC:    ( -- dc )
                GetHandle: picture-dc
                ;M

:M StartSize:   { \ Brows -- width height }     \ starting window size
                started?
        if      1 to Brows
                hbb to hb                       \ init the chain
                0
                begin   hb
                while   GetBwidth: hb 0< 0=     \ skip any next row markers
                        if      GetBwidth: hb + tool-spacing +
                        else    1 +to Brows
                                horizontal-offset 4 + + >r 0
                                                \ save toolbar width, start next row
                        then
                        GetPrev: hb to hb
                repeat  horizontal-offset 4 + + \ last row width remains on stack
                Brows 1- 0max                   \ if multiple rows, recover each row
                begin   ?dup                    \ width, and find the longest one
                while   swap r> max swap
                        1-
                repeat                             \ total width of buttons
                toolheight vertical-offset + Brows *
                           vertical-offset +       \ total height
                border-width 2* border-width 2* D+ \ compensate for dialog border width
                floatBar
                IF      20 +
                THEN
        else    0 0
        then
                ;M

:M WindowStyle: ( -- style )            \ return the window style
                WindowStyle: Super
                floatBar 0=
                IF      WS_DLGFRAME or  \ give this child a dialog frame border
                THEN
                ;M

:M ExWindowStyle: ( -- extended_style )
                ExWindowStyle: Super
                WS_EX_TOOLWINDOW or
                ;M

: button+h      ( -- n1 )
                bhoffset
                dup
                GetBwidth: hb 0>
                IF      GetBwidth: hb + tool-spacing +
                THEN    to bhoffset ;

:M On_Size:     ( -- )                          \ handle resize message
                started?
        if      hbb to hb                       \ init the chain
                horizontal-offset 2 + to bhoffset
                0 to bvoffset
                begin   hb
                while   GetBwidth: hb 0<
                        if      horizontal-offset 2 + to bhoffset          \ to left end
                                toolheight  vertical-offset + +to bvoffset \ next row
                        else    button+h    vertical-offset bvoffset +
                                GetBwidth: hb GetBheight: hb Move: hb
                        then
                        GetPrev: hb to hb
                repeat
        then
                ;M

:M On_Paint:    ( -- )
                LTGRAY_BRUSH Call GetStockObject
                0 0
                StartSize: self 1+ SetRect: WinRect
                Addrof: WinRect GetHandle: dc call FillRect ?win-error
                EraseRect: WinRect
                StartPos: self  StartSize: self   Move: self
                ;M

:M On_Done:       ( -- )
                On_Done: super
                FALSE to started?
                ;M

:M Start:       { theParent \ hmem1 hmem2 lpbmi lpvBits hdcMem hbm -- }
                GetDC: self  PutHandle: dc
                0 call CreateCompatibleDC PutHandle: picture-dc
                640 32 CreateCompatibleBitmap: dc to picture-bitmap
                picture-bitmap  SelectObject: picture-dc to prev-bitmap
                GetHandle: dc  ReleaseDC: self
                theParent Start: super          \ first start the bar
                                                \ then load the bitmap
                bar-name c@
        if      0 to bmp-off                    \ reset to start of bmp file
                BMPheader                                        \ BMP header dest
                sizeof(BMPheader)                                \ size of BMP header
                read-bmp                                         \ read header

                BMPinfoheader                                    \ dest for header info
                sizeof(BMPinfoheader)                            \ size of info header
                read-bmp                                         \ read info

                1 BMPinfoheader 14 + w@ lshift sizeof(RGBQUAD) * \ size of image
                sizeof(BMPinfoheader) + GHND
                call GlobalAlloc to hmem1                        \ allocate it
                hmem1 call GlobalLock to lpbmi                   \ lock it
                BMPinfoheader  lpbmi sizeof(BMPinfoheader) move  \ copy info up
                lpbmi sizeof(BMPinfoheader) +                    \ color dest
                1 BMPinfoheader 14 + w@ lshift                   \ size of image
                sizeof(RGBQUAD) *                                \ times quads
                read-bmp                                         \ read colors

                BMPheader dup 2 + @ swap 10 + @ -                \ bit map size
                GHND call GlobalAlloc to hmem2                   \ alloc mem
                hmem2 call GlobalLock to lpvBits                 \ lock mem
                lpvBits                                          \ dest of bits
                BMPheader dup 2 + @ swap 10 + @ -                \ bit map size
                read-bmp

                DIB_RGB_COLORS
                lpbmi
                lpvBits
                CBM_INIT
                BMPinfoheader                                    \ info pointer
                GetHandle: picture-dc                            \ device context
                call CreateDIBitmap to hbm
                hmem1 call GlobalUnlock 0= ?win-error
                hmem2 call GlobalUnlock 0= ?win-error
                hmem1 call GlobalFree   0= ?win-error
                0 to hmem1
                hmem2 call GlobalFree   0= ?win-error
                0 to hmem2

                GetHandle: picture-dc call CreateCompatibleDC to hdcMem
                hbm hdcMem call SelectObject drop
                BMPbitmap sizeof(BMPbitmap) hbm call GetObject drop

                SRCCOPY 0 0
                hdcMem
                BMPbitmap 8 + @                             \ image height
                BMPbitmap 4 + @                             \ image width
                0 0
                GetHandle: picture-dc
                call BitBlt ?win-error
                hdcMem call DeleteDC ?win-error
                hbm call DeleteObject ?win-error
                TRUE to started?
                0 0 SetOrigin: self     \ toolbar at top left corner of window
        then    ;M

:M Close:       ( -- )
                GetHandle: picture-dc
                if                                      \ restore original bitmap
                        prev-bitmap SelectObject: picture-dc drop
                                                        \ release DC if allocated
                        GetHandle: picture-dc Call DeleteDC ?win-error
                        0 PutHandle: picture-dc         \ clear the WinDC variable
                then
                picture-bitmap
                if      picture-bitmap call DeleteObject drop
                        0 to picture-bitmap
                then
                Close: Super
                ;M

;Class


|Class PictureButton    <Super Button

int picture-number

in-system

warning off

: (ClassInit)   ( n1 -- )
                [ warning on ]
                to picture-number
                ClassInit: super
                DefToolWidth  to bwidth
                DefToolHeight to bheight
                GetBar: BuildBar to bprev               \ end of link is NULL
                bprev 0=                                \ if i'm the first one
                if      self PutBar: BuildBar           \ put me in the bar
                else    begin   bprev
                        while   bprev to id             \ save here temp
                                GetPrev: bprev to bprev
                        repeat  self SetPrev: id        \ temp use
                        0 SetPrev: self
                then
                NextBid: BuildBar to id
                here to title 0 ,
                GetBCnt: BuildBar 1+ PutBCnt: BuildBar  \ bump count
                :noname to bfunc
                !csp
                ;

in-application
:m ClassInit:   ( n1 -- )
\in-system-ok   (Classinit) ;m

WinDC dc        \ The window's device context

16 cells bytes &ps

:M WM_PAINT     ( hwnd msg wparam lparam -- res )
                picture-number 0 >=
                IF      &ps BeginPaint: self  PutHandle: dc
                        SRCCOPY                          \ copy mode
                        picture-number DefToolWidth 1- * \ offset to desired icon
                        0                                \ source y
                        GetWinDC: parent                 \ source handle
                        bwidth bheight                   \ width, height
                        0 0                              \ destination
                        BitBlt: dc
                        &ps EndPaint: self
                THEN
                0 ;M

:M WM_LBUTTONDOWN ( h m w l -- res )
                WM_LBUTTONDOWN WM: Super
                picture-number 0 >=
                IF      GetDC: self  PutHandle: dc
                        SRCCOPY                          \ copy mode
                        picture-number DefToolWidth 1- * \ offset to desired icon
                        0                                \ source y
                        GetWinDC: parent                 \ source handle
                        bwidth  3 - bheight 3 -          \ width, height
                        1 1                              \ destination
                        BitBlt: dc
                        GetHandle: dc ReleaseDC: self
                THEN
                 ;M

;Class

\ ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
\ EditField is used on a toolbar as shown here:
\ <fieldwidth> EditField <fieldname>
\
\ <fieldname> is used to set the edit fields text contents in the form:
\ s" new text"        SetText: <fieldname>
\ ' nyWmChar        SetWmChar: <fieldname>      \ set WM_CHAR filtering
\ ' nyWmKeyDown  SetWmKeyDown: <fieldname>      \ set WM_KEYDOWN filtering
\ ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

:Class EditField <Super EditControl

int bprev
int editwidth
int editheight

:M SetPrev:     ( bprev -- ) to bprev ;M
:M GetPrev:     ( -- bprev ) bprev ;M

:M GetBwidth:   ( -- edit_width )
                editwidth
                ;M

:M GetBheight:  ( -- edit_height )
                editheight
                ;M

:M StartSize:   ( width height )
                editwidth
                editheight
                ;M

:M ClassInit:   ( editWidth -- )
                ClassInit: super
                to editwidth
                DefToolHeight to editheight
                s" Edit" binfo place
                GetBar: BuildBar to bprev       \ end of link is NULL
                bprev 0=                        \ if i'm the first one
                if      self PutBar: BuildBar   \ put me in the bar
                else    begin   bprev
                        while   bprev to id            \ save here temp
                                GetPrev: bprev to bprev
                        repeat  self SetPrev: id       \ temp use
                        0 SetPrev: self
                then
                NextBid: BuildBar to id
                here to title 0 ,
                GetBCnt: BuildBar 1+ PutBCnt: BuildBar      \ bump count
                ;M

\ the toolbar must not remove the focus from the edit control
:M RemoveFocus: ( -- f1 )
                FALSE
                ;M

:M DoButton:    ( -- )          \ a NOOP needed by TOOLBAR
                ;M

;Class

\ ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
\ ComboField is used on a toolbar as shown here:
\ <fieldwidth> ComboField <fieldname>
\
\ <fieldname> is used to set the combo fields text contents in the form:
\ s" new item"   InsertString: <fieldname>      \ insert items into list
\ ' nyWmChar        SetWmChar: <fieldname>      \ set WM_CHAR filtering
\ ' nyWmKeyDown  SetWmKeyDown: <fieldname>      \ set WM_KEYDOWN filtering
\ ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

:Class ComboField <Super ComboControl

int bprev
int bheight
int combowidth
int comboheight

:M SetPrev:     ( bprev -- ) to bprev ;M
:M GetPrev:     ( -- bprev ) bprev ;M

:M GetBwidth:   ( -- edit_width )
                combowidth
                ;M

:M GetBheight:  ( -- edit_height )
                bheight
                ;M

:M StartSize:   ( width height )
                combowidth
                comboheight       \ height of edit control when open
                ;M

:M SetHeight:   ( height -- )
                to comboheight
                ;M

:M ClassInit:   ( editWidth -- )
                ClassInit: super
                to combowidth
                200 to comboheight
                DefToolHeight to bheight
                s" Edit" binfo place
                GetBar: BuildBar to bprev       \ end of link is NULL
                bprev 0=                        \ if i'm the first one
                if      self PutBar: BuildBar   \ put me in the bar
                else    begin   bprev
                        while   bprev to id            \ save here temp
                                GetPrev: bprev to bprev
                        repeat  self SetPrev: id       \ temp use
                        0 SetPrev: self
                then
                NextBid: BuildBar to id
                here to title 0 ,
                GetBCnt: BuildBar 1+ PutBCnt: BuildBar      \ bump count
                ;M

\ the toolbar must not remove the focus from the edit control
:M RemoveFocus: ( -- f1 )
                FALSE
                ;M

:M DoButton:    ( -- )                  \ a NOOP needed by TOOLBAR
                ;M

;Class



Index: CHILDWND.F
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/CHILDWND.F,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** CHILDWND.F	3 May 2007 09:10:48 -0000	1.1
--- CHILDWND.F	8 May 2007 08:34:39 -0000	1.2
***************
*** 33,37 ****
  :M SetParent:   ( parent -- )
  \ *G Set the object address of the parent window.
!                 Parent ;M
  
  :M GetParent:   ( -- parent )
--- 33,37 ----
  :M SetParent:   ( parent -- )
  \ *G Set the object address of the parent window.
!                 to Parent ;M
  
  :M GetParent:   ( -- parent )

Index: Menu.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/Menu.f,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** Menu.f	3 May 2007 09:00:02 -0000	1.2
--- Menu.f	8 May 2007 08:34:39 -0000	1.3
***************
*** 3,6 ****
--- 3,8 ----
  \ menu.f beta 2002/11/05 ron Added support for multiple instances capability
  
+ Require window.f
+ 
  cr .( Loading Window Menus...)
  
***************
*** 9,14 ****
  only forth also definitions
  
- needs GdiTools
- 
  INTERNAL        \ internal definitions start here
  
--- 11,14 ----
***************
*** 34,38 ****
  EXTERNAL
  
! 200 constant IdStart
  IdStart value IdCounter
  
--- 34,38 ----
  EXTERNAL
  
! 200  constant IdStart
  IdStart value IdCounter
  

Index: Class.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/Class.f,v
retrieving revision 1.5
retrieving revision 1.6
diff -C2 -d -r1.5 -r1.6
*** Class.f	1 May 2007 07:41:55 -0000	1.5
--- Class.f	8 May 2007 08:34:39 -0000	1.6
***************
*** 1295,1299 ****
  
  : (classto)     ( n -<value>- -- )
!                 >in @ ^class if bl word count ^class (search-self)
                  ?dup if  dup n>tfa c@
                  dup   tint = if drop name>xt nip nip
--- 1295,1301 ----
  
  : (classto)     ( n -<value>- -- )
!                 >in @  bl word count [ ' locals >body ] literal (search-self)
!                 0= localstk 0= or if dup >in !
!                 ^class if bl word count ^class (search-self)
                  ?dup if  dup n>tfa c@
                  dup   tint = if drop name>xt nip nip
***************
*** 1309,1313 ****
                  >body @ postpone ^base postpone literal postpone + postpone 2!
                  exit then
!                 2drop then then >in ! oldto ;
  
  ' (classto) compiles-for to
--- 1311,1315 ----
                  >body @ postpone ^base postpone literal postpone + postpone 2!
                  exit then
!                 2drop then then then >in ! oldto ;
  
  ' (classto) compiles-for to
***************
*** 1316,1323 ****
  
  : (class+to)     ( n -<value>- -- )
!                 >in @ ^class if bl word count ^class (search-self)
                  ?dup if  dup n>tfa c@ tint = if name>xt nip nip
                  >body @ postpone ^base postpone literal postpone + postpone +!
!                 exit then drop then then >in ! old+to ;
  
  ' (class+to) compiles-for +to
--- 1318,1327 ----
  
  : (class+to)     ( n -<value>- -- )
!                 >in @ bl word count [ ' locals >body ] literal (search-self)
!                 0= localstk 0= or if dup >in !
!                 ^class if bl word count ^class (search-self)
                  ?dup if  dup n>tfa c@ tint = if name>xt nip nip
                  >body @ postpone ^base postpone literal postpone + postpone +!
!                 exit then drop then then then >in ! old+to ;
  
  ' (class+to) compiles-for +to

[Win32forth-cvs] win32forth-stc/src/lib ButtonBar.f, NONE, 1.1 Buttons.f, NONE, 1.1 Calendar.f, NONE, 1.1 Label.f, NONE, 1.1 ListBox.f, NONE, 1.1 ProgressBar.f, NONE, 1.1 RebarControl.f, NONE, 1.1 ScintillaControl.f, NONE, 1.1 ScintillaEdit.f, NONE, 1.1 ScrollBar.f, NONE, 1.1 StatusBar.f, NONE, 1.1 TabControl.f, NONE, 1.1 TextBox.f, NONE, 1.1 TrackBar.f, NONE, 1.1 TrayWindow.f, NONE, 1.1 UpDownControl.f, NONE, 1.1 excontrols.f, NONE, 1.1 sendmessage.f, NONE, 1.1 toolbar.f, NONE, 1.1 treeview.f, 1.1, 1.2

[George H. <geo...@us...>]

Update of /cvsroot/win32forth/win32forth-stc/src/lib
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv22070/win32forth-stc/src/lib

Modified Files:
	treeview.f 
Added Files:
	ButtonBar.f Buttons.f Calendar.f Label.f ListBox.f 
	ProgressBar.f RebarControl.f ScintillaControl.f 
	ScintillaEdit.f ScrollBar.f StatusBar.f TabControl.f TextBox.f 
	TrackBar.f TrayWindow.f UpDownControl.f excontrols.f 
	sendmessage.f toolbar.f 
Log Message:
gah:Added the axtension classes plus scintilla toolbars rebars etc.

--- NEW FILE: toolbar.f ---
(This appears to be a binary file; contents omitted.)

--- NEW FILE: UpDownControl.f ---
\ $Id: UpDownControl.f,v 1.1 2007/05/08 08:31:46 georgeahubert Exp $

\ *D doc\classes\
\ *> Controls

anew -UpDownControl.f

WinLibrary COMCTL32.DLL

needs textbox.f

cr .( Loading UpDownControl Class...)

INTERNAL
EXTERNAL

\ ------------------------------------------------------------------------
\ *W <a name="UpDownControl"></a>
\ *S UpDownControl class
\ ------------------------------------------------------------------------
:Class UpDownControl	<Super Control
\ *G Up-Down control
\ *P An up-down control is a pair of arrow buttons that the user can click to
\ ** increment or decrement a value, such as a scroll position or a number displayed
\ ** in a companion control.
\ *P For 16 Bit values only.

int style

:M ClassInit:   ( -- )
\ *G Initialise the class.
                ClassInit: super
                0 to style ;M

:M WindowStyle: ( -- style )
\ *G Get the window style of the control. Default style is:
\ ** WS_BORDER, UDS_ARROWKEYS, UDS_SETBUDDYINT and UDS_ALIGNRIGHT.
		WindowStyle: super
		[ WS_BORDER UDS_ARROWKEYS OR UDS_SETBUDDYINT OR UDS_ALIGNRIGHT OR ] literal or
		style or ;M

:M AddStyle:    ( n -- )
\ *G Set any additional style of the control. Must be done before the control
\ ** is created.
                to style ;M

:M Start:       ( Parent -- )
\ *G Create the control.
		to parent Z" msctls_updown32" create-control ;M

:M StartSize:	( -- cx cy )
\ *G default window size
		40 20 ;M

:M StartPos: 	( -- x y )
\ *G default window position
		0 0 ;M

:M SetBuddy:	( hBuddy -- )
\ *G Sets the buddy window for the up-down control.
		0 SWAP UDM_SETBUDDY SendMessage:SelfDrop ;M

:M GetValue: 	( -- n )
\ *G Retrieves the current position of the up-down control.
\ ** Note: This method ABORT's on error.
		0 0 UDM_GETPOS SendMessage:Self
		word-split ABORT" Up/Down Control read error"
		;M

:M SetValue:	( n -- )
\ *G Set the current position for the up-down control.
		0 word-join 0 UDM_SETPOS SendMessage:SelfDrop ;M

:M SetDecimal: 	( -- )
\ *G Sets the radix base for the control to decimal.
\ ** Decimal numbers are signed.
		0 10 UDM_SETBASE SendMessage:SelfDrop ;M

:M SetHex: 	( -- )
\ *G Sets the radix base for the control to hexadecimal.
\ ** Hexadecimal numbers are always unsigned.
		0 16 UDM_SETBASE SendMessage:SelfDrop ;M

:M GetBase: 	( -- n )
\ *G Get the current radix base (that is, either base 10 or 16).
		0 0 UDM_GETBASE SendMessage:Self ;M

:M SetRange: 	( lower upper -- )
\ *G Sets the minimum and maximum positions (range) the control.
\ ** Neither position can be greater than the UD_MAXVAL value or less than
\ ** the UD_MINVAL value. In addition, the difference between the two positions
\ ** cannot exceed UD_MAXVAL.
		swap word-join 0 UDM_SETRANGE SendMessage:SelfDrop ;M

:M GetRange: 	( -- lower upper )
\ *G Retrieves the minimum and maximum positions (range) for the control.
		0 0 UDM_GETRANGE SendMessage:Self word-split SWAP ;M

:M Enable:      ( f -- )
\ *G Enable the control.
                ID EnableDlgItem: parent ;M

:M Disable:     ( -- )
\ *G Disable the control.
                false Enable: self ;M

;Class
\ *G End of UpDownControl control

:Class SpinnerControl           <Super UpDownControl
TextBox TheBox

:m start:     ( parent -- )     \ both must have same parent
              dup Start: TheBox
              Start: super
              ;m

:m TheBox:   ( -- spinbox ) \ in case we need it directly for some reason
              Addr: TheBox ;m

:m Move:      ( x y w h -- )
              Move: TheBox
              \ allow the updowncontrol to move with the editcontrol
              GetHandle: TheBox SetBuddy: self ;m

:m SetFont:   ( hndl -- )
              Setfont: TheBox ;m

:M Close:     ( -- )
              Close: TheBox
              Close: self ;M
;class

MODULE

\ *Z

--- NEW FILE: TrayWindow.f ---
\    File: TrayWindow.f
\
\  Author: Dirk Busch (dbu)
\   Email: dir...@wi...
\
\ Created: Sonntag, April 24 2005 - dbu
\ Updated: Sonntag, Januar 15 2006 - dbu
\
\ *D doc\classes\
\ *! TrayWindow
\ *T TrayWindow class
\ *P Windows that are created with this class will hide themself
\ ** in the windows traybar when they are minimized.

Require window.f
Require control.f

cr .( Loading TrayWindow class...)

anew -TrayWindow.f

internal

#define NIM_ADD     0x00000000
#define NIM_MODIFY  0x00000001
#define NIM_DELETE  0x00000002

#define NIF_MESSAGE 0x00000001
#define NIF_ICON    0x00000002
#define NIF_TIP     0x00000004

2 proc Shell_NotifyIconA as Shell_NotifyIcon

external

\ *W <a name="TrayWindow"></a>
\ *S Glossary
:class TrayWindow <super window
\ *G TrayWindow class

Record: &NOTIFYICONDATA
        int   nid_cbSize
        int   nid_hWnd
        int   nid_uID
        int   nid_uFlags
        int   nid_uCallbackMessage
        int   nid_hIcon
     64 bytes nid_szTip
;RecordSize: sizeof(NOTIFYICONDATA)

:M DefaultIcon: ( -- hIcon )
\ *G Get the handle of the icon whitch should be added to the traybar.
        DefaultIcon: super ;M

:M GetTooltip:  ( -- addr len )
\ *G Get the tooltip text for the traybar icon.
        s" Tooltip text" ;M

:M GetID:       ( -- uID )
        1 ;M

:M GetFlags:    ( -- uFlags )
        [ NIF_ICON NIF_MESSAGE NIF_TIP or or ] literal ;M

WM_APP 1+ constant WM_CALLBACK_MESSAGE

: ShellNotifyIcon      ( n -- )
        &NOTIFYICONDATA swap call Shell_NotifyIcon drop ;

:M AddIcon:     ( -- )
\ *G Add our icon to the traybar
        NIM_ADD ShellNotifyIcon ;M

:M DeleteIcon:  ( -- )
\ *G Remove our icon from the traybar
        NIM_DELETE ShellNotifyIcon ;M

:M On_Init:     ( -- )
        On_Init: super

        sizeof(NOTIFYICONDATA) to nid_cbSize
        GetHandle: self        to nid_hWnd
        GetID: [ self ]        to nid_uID
        GetFlags: [ self ]     to nid_uFlags
        WM_CALLBACK_MESSAGE    to nid_uCallbackMessage
        DefaultIcon: [ self ]  to nid_hIcon
        GetTooltip: [ self ]   nid_szTip swap 64 min cmove
        ;M

:M On_Done:     ( -- )
        DeleteIcon: self
        On_Done: super ;M

:M IsVisible?:  ( -- f )
\ *G Check if the window is visible or not.
        GetHandle: self call IsWindowVisible ;M

:M ShowWindow:  ( -- )
\ *G Show the window and remove the icon from the traybar.
        IsVisible?: self 0=
        if   DeleteIcon: self
             SW_RESTORE Show: self Update: self
        then ;M

:M HideWindow:  ( -- )
\ *G Hide the window and add the icon to the traybar.
        IsVisible?: self
        if   SW_HIDE Show: self Update: self
             AddIcon: self
        then ;M

:M WM_SIZE      ( hWnd uMsg wParam lParam -- res )
\ *G Handle the WM_SIZE message. If the window is minimized
\ ** it will be hidden and the icon will be added to the traybar.
        over SIZE_MINIMIZED =
        if   HideWindow: [ self ]
        then WM_SIZE WM: super
        ;M

:M WM_SYSCOMMAND ( hWnd uMsg wParam lParam -- res )
\ *G Handle the WM_SYSCOMMAND message. If the window is minimized
\ ** it will be hidden and the icon will be added to the traybar.
        over SC_MINIMIZE =
        if   HideWindow: [ self ] 0
        else hWnd WM_SYSCOMMAND 2swap DefWindowProc: self
        then ;M

: TrackPopup    ( -- )
\ Open the popup menu of the window.
        CurrentPopup
        if   get-mouse-xy
             GetHandle: self Track: CurrentPopup
        then ;

:M On_IconNotify:       ( hWnd uMsg wParam lParam -- res )
\ *G Handle the messages from the traybar icon.
\ *P The default handler removes the icon for the traybar and shows the window,
\ ** when the user click's with the left mouse button on the tray icon.
\ *P If the right mouse button is used the popup menu of the window is shown.
\ ** Use the \b SetPopupBar: \d method to assign a popup menu to the window.
        case    WM_LBUTTONUP of ShowWindow: [ self ] endof
                WM_RBUTTONUP of TrackPopup           endof
        endcase 0 ;M

:M WM_CALLBACK_MESSAGE  ( hWnd uMsg wParam lParam -- res )
        On_IconNotify: [ self ] ;M

;class
\ *G End of TrayWindow class

module

\s

\ ----------------------------------------------------------------------------
\ *S Example
\ -----------------------------------------------------------------------------

\ *+

\ Create a tray window
:object TestWindow <super TrayWindow

:M GetTooltip:  ( -- addr len )
        s" TrayWindow Test" ;M

;object

           Start: TestWindow \ open the window
SW_MINIMIZE Show: TestWindow \ minimize it to hide it in the TrayBar
\ *-
\ *Z

--- NEW FILE: ScintillaEdit.f ---
\    File: ScintillaEdit.f
\
\  Author: Dirk Busch (dbu)
\   Email: dir...@wi...
\
\ Created: Mittwoch, Juni 09 2004 - dbu
\ Updated: Samstag, Juli 03 2004 - 10:52 - dbu
\
\ A wrapper class around the ScintillaControl class.
\ This Class can be used to build a real Editor around the control.

cr .( Loading Scintilla Window...)

ANEW -ScintillaEdit.f

needs ScintillaControl.f
needs file.f
\ needs RegistryWindowPos.f

\ ------------------------------------------------------------------------------
\ ------------------------------------------------------------------------------

INTERNAL

FileOpenDialog OpenFileDialog "Open Source File" "Forth Files (*.f,*.fs,*.4th,*.fth,*.seq)|*.f;*.fs;*.4th;*.fth;*.seq|All Files (*.*)|*.*"
FileSaveDialog SaveFileDialog "Save Source File" "Forth Files (*.f)|*.f|All Files (*.*)|*.*|"

NewEditDialog  FindTextDlg "Find Text" "Search for:" "Find" "" "Case Sensitive Search"


EXTERNAL

\ ------------------------------------------------------------------------------
\ ------------------------------------------------------------------------------

:Class ScintillaEdit <super ScintillaControl

ReadFile EditFile
create FindText$ MAXSTRING char+ allot
int FindMode
int CreateBackup?

fload ScintillaLexer.f

:M SetCaretBackColor:	( color -- )	\ value of zero turns it off effect
		dup 0=
		if	false SCI_SETCARETLINEVISIBLE hwnd send-window
		else	0 swap SCI_SETCARETLINEBACK hwnd send-window
			0 true SCI_SETCARETLINEVISIBLE hwnd send-window
		then	;M

:M SetColors:	( fore back -- )
		style_default rot stylesetfore: self
		style_default swap stylesetback: self
		0 0 SCI_STYLECLEARALL hwnd send-window
		InitLexer: [ self ]
		;M

:M InitLexer:   ( -- )
                SCLEX_FORTH SetLexer: self

                0 ANSKeywords  SetKeyWords: self
                1 commentStart SetKeyWords: self
                2 commentEnd   SetKeyWords: self
                3 UserWords1   SetKeyWords: self
                4 UserWords2   SetKeyWords: self
                5 UserWords3   SetKeyWords: self
                6 UserWords4   SetKeyWords: self
                7 UserWords5   SetKeyWords: self
                8 UserWords6   SetKeyWords: self

                SCE_FORTH_DEFAULT COL_FORTH_DEFAULT StyleSetFore: self
                SCE_FORTH_COMMENT COL_FORTH_COMMENT StyleSetFore: self
                SCE_FORTH_STRING  COL_FORTH_STRING  StyleSetFore: self
                SCE_FORTH_NUMBER  COL_FORTH_NUMBER  StyleSetFore: self
                SCE_FORTH_LOCALS  COL_FORTH_LOCALS  StyleSetFore: self
                SCE_FORTH_ANS     COL_FORTH_ANS     StyleSetFore: self
                SCE_FORTH_USER1   COL_FORTH_USER1   StyleSetFore: self
                SCE_FORTH_USER2   COL_FORTH_USER2   StyleSetFore: self
                SCE_FORTH_USER3   COL_FORTH_USER3   StyleSetFore: self
                SCE_FORTH_USER4   COL_FORTH_USER4   StyleSetFore: self
                SCE_FORTH_USER5   COL_FORTH_USER5   StyleSetFore: self
                SCE_FORTH_USER6   COL_FORTH_USER6   StyleSetFore: self
                ;M
create WordChars MAXSTRING allot 0 WordChars !
s" abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" WordChars place
s" 0123456789°!§$%&/()=?`´^{[]}\+*~#,.-;:_@<>|" WordChars +place
WordChars count + dup 34 swap c! ( " ) char+ dup 39 swap c! ( ' ) char+ 0 swap c!

:M Start:       ( Parent -- )
                Start: super
                0 to FindMode
                true to CreateBackup?
                FindText$ off
                InitLexer: self
                STYLE_DEFAULT z" Fixedsys" StyleSetFont: self
                WordChars 1+ SetWordChars: self ;M

:M GetFileName: ( -- addr )
                GetName: EditFile ;M

:M SetWindowTitle: { \ Text$ -- }
                1024 LocalAlloc: Text$
                WindowTitle: parent zcount Text$ place
                s"  - " Text$ +place
                GetFileName: self count dup 0=
                if 2drop s" [NEW FILE]" then Text$ +place
                Text$ count SetText: parent ;M

:M SetFileName: ( addr len -- )
                SetName: EditFile
                SetWindowTitle: self ;M

: MessageBox    ( n a1 n1 -- n2 )
                pad place pad +NULL
                z" ScintillaEdit"
                pad count drop
                Gethandle: self Call MessageBox ;

: GetOpenFilename ( -- addr len )
                Gethandle: self Start: OpenfileDialog count ;

: GetSaveFilename ( -- addr len )
                Gethandle: self Start: SaveFileDialog count ;

: SaveText      ( -- )          \ save the Text in the control to the file
                \ get the complete text from the control
                ReleaseBuffer: EditFile
                GetTextLength: self 1+ AllocBuffer: EditFile
                GetBuffer: EditFile GetText: self

                \ adjust the Text length in the EditFile because
                \ the Scintilla-Control returns on null byte at the
                \ end of the Text. Thank's Ezra for telling me about this
                \ bug (Freitag, August 19 2005 - dbu)
                GetLength: EditFile 1- SetLength: EditFile

                \ save the text to the file
                SaveFile: EditFile
                ReleaseBuffer: EditFile

                \ and mark the text in the control as unchanged
                SetSavepoint: self ;

:M SaveFileAs:  ( -- )          \ save the file under a new name
                GetSaveFilename ?dup
                if   SetFileName: self
                     SaveText
                else drop
                then ;M

: CreateBackup  { \ from$ to$ -- } \ create a Backup of the active file (*.BAK)
                CreateBackup?
                if   max-path localAlloc: from$
                     max-path localAlloc: to$

                     GetFileName: self count from$ place from$ +null

                     GetFileName: self count to$ place
                     to$ count "minus-ext" to$ place s" .bak" to$ +place to$ +null

                     false to$ count drop from$ count drop
                     Call CopyFile ?win-error
                then ;

:M SaveFile:    ( -- )          \ save the file under it's current name
                GetFileName: self c@ 0=
                if   SaveFileAs: self
                else CreateBackup SaveText
                then ;M

:M SaveBeforeCloseing: ( -- )
                GetModify: self 0<>
                if   [ MB_YESNO MB_ICONQUESTION or ] literal
                     s" The current File has changed. Would you like to save your changes?" MessageBox
                     IDYES = if SaveFile: self then
                then ;M

:M NewFile:     ( -- )          \ open a new empty file
                SaveBeforeCloseing: self
                ClearAll: self
                EmptyUndoBuffer: self
                SetSavepoint: self
                ClearName: EditFile ;M

: SetFile       ( f -- )
                GetBuffer: EditFile ?dup
                if   over + 0 swap c! \ add 0-terminator
                     SetText: self
                then
                EmptyUndoBuffer: self
                SetSavepoint: self
                0 -1 Colourise: self ;

:M OpenNamedFile: ( addr len -- f )          \ open a file
                SaveBeforeCloseing: self
                ClearAll: self
                LoadFile: EditFile
                dup if SetFile then
                SetWindowTitle: self ;M

:M OpenFile:    ( -- )          \ open a file
                GetOpenFilename ?dup
                if   OpenNamedFile: self
                else drop
                then ;M

:M ReloadFile:  ( -- )          \ reload the current file
                GetFileName: self c@ 0<>
                if   GetModify: self 0<>
                     if   [ MB_YESNO MB_ICONQUESTION or ] literal
                          s" The current File has changed. All changes will be lost. Would you like to continue?" MessageBox
                          IDYES =
                          if   GetFileName: self count pad place
                               SetSavepoint: self NewFile: self
                               pad count LoadFile SetFile
                          then
                     then
                then ;M

:M Delete:      ( -- )          \ delete the selected text
                0 PAD ! PAD ReplaceSel: self ;M

:M RemoveSel:   ( -- )          \ remove the current selection
                -1 GetCurrentPos: self SetSel: self ;M

:M ?Selection:  ( -- f )
                GetSelectionStart: self GetSelectionEnd: self - ;M

:M ViewEOL:     ( -- )
                GetViewEOL: self not SetViewEOL: self ;M

:M SetEOL:      ( eolMode -- )
                dup ConvertEOL: self SetEOL: super ;M

:M SetOverType: ( -- )
                GetOverType: self not SetOverType: super ;M

:M ViewWhiteSpace: ( -- )
                GetWhiteSpace: self
                SCWS_INVISIBLE = if SCWS_VISIBLEALWAYS else SCWS_INVISIBLE then
                SetWhiteSpace: self ;M

:M ?Find:       ( -- f )
                FindText$ c@ 0<> ;M

:M FindText:    ( -- )
                FindText$ self Start: FindTextDlg
                case    0 of exitm            endof
                        1 of 0                endof \ ignore case
                        2 of SCFIND_MATCHCASE endof
                endcase dup to FindMode

                ?Find: self
                if   FindText$ +null
                     0 GetTextLength: self
                     FindText$ 1+ FindText: super ( nStart nEnd flag )
                     if   SetSel: self
                     then
                else drop
                then ;M

:M SearchNext:  ( -- )
                ?Find: self
                if
                     GetSelectionEnd: self SetSelectionStart: self
                     SearchAnchor: self
                     FindMode FindText$ 1+ SearchNext: super INVALID_POSITION <>
                     if ScrollCaret: super then
                then ;M

:M SearchPrev:  ( -- ) \ this doesn't work... why?
                ?Find: self
                if
                     GetSelectionEnd: self SetSelectionStart: self
                     SearchAnchor: self
                     FindMode FindText$ 1+ SearchPrev: super INVALID_POSITION <>
                     if ScrollCaret: super then
                then ;M

:M GetCurrentLine: ( -- #line )
                GetCurrentPos: self
                LineFromPosition: self ;M

:M IsBackupEnabled: ( -- f )
                CreateBackup? ;M

:M EnableBackup: ( f -- )
                to CreateBackup? ;M

:M InsertDate:  { \ $buf -- } \ replace selection with current date
                MAXSTRING LocalAlloc: $buf
                get-local-time time-buf
                >month,day,year" $buf place

\                time&date 2drop drop
\                s"  - " $buf +place
\                (.)   $buf +place s" :" $buf +place
\                2 .#" $buf +place drop
                $buf +null $buf 1+ ReplaceSel: self ;M

:M InsertDate&Time: { \ $buf -- } \ replace selection with current date and time
                MAXSTRING LocalAlloc: $buf
                get-local-time time-buf
                >month,day,year" $buf place

                time&date 3drop
                s"  - " $buf +place
                (.)   $buf +place s" :" $buf +place
                2 .#" $buf +place drop
                $buf +null $buf 1+ ReplaceSel: self ;M

: SelBounds     ( -- n1 n2 )
                GetSelectionEnd: self LineFromPosition: self
                GetSelectionStart: self LineFromPosition: self ;

: Comment?      ( #line -- ) \ check if line starts with a comment
                PositionFromLine: self
                dup GetCharAt: self [char] \ = swap
                1+ GetCharAt: self bl = and ;

:M CommentBlock: ( -- ) \ comment a block of lines
                ?Selection: self
                if   BeginUndoAction: self
                     SelBounds
                     ?do  i Comment? not
                          if   i PositionFromLine: self
                               z" \ " InsertText: self
                          then
                     loop EndUndoAction: self
                then ;M

:M UnCommentBlock: ( -- ) \ uncomment a block of lines
                ?Selection: self
                if   BeginUndoAction: self
                     SelBounds
                     ?do  i Comment?
                          if   i PositionFromLine: self
                               dup 2 + SetSel: self Delete: self
                          then
                     loop EndUndoAction: self
                then ;M

:M GotoColumn:  ( n -- )
\                GetCurrentLine: self PositionFromLine: self
                GetCurrentPos: self
                + ( 1- ) dup SetCurrentPos: self SetAnchor: self ;M

:M GetCurrentLineLength: ( -- n )
                GetCurrentLine: self
                LineLength: self ;M

:M HighlightLine: ( Anchor Pos -- )
                GetCurrentLine: self PositionFromLine: self dup>r
                   + SetCurrentPos: self
                r> + SetAnchor: self ;M

:M HighlightWord: { \ buf$ Pos Anchor -- } \ highlight the current word under cursor

                GetCurrentLineLength: self 1+ dup LocalAlloc: buf$
                buf$ GetCurLine: self
                GetCurrentLineLength: self min ( curpos )

                buf$ swap 2dup
                BEGIN   2dup bl scan dup
                WHILE   2nip
                        bl skip
                REPEAT  3drop 2 pick - dup dup>r
                /string 2dup bl scan nip - r@ + nip

                r> swap HighlightLine: self ;M

:m ~:           ( -- )
                ReleaseBuffer: EditFile ;m

Record: scn \ struct SCNotification
        int scn_hWndFrom
        int scn_idFrom
        int scn_code
        int scn_position;
        \ SCN_STYLENEEDED, SCN_MODIFIED, SCN_DWELLSTART,
        \ SCN_DWELLEND, SCN_CALLTIPCLICK,
        \ SCN_HOTSPOTCLICK, SCN_HOTSPOTDOUBLECLICK
        int scn_ch               \ SCN_CHARADDED, SCN_KEY
        int scn_modifiers        \ SCN_KEY, SCN_HOTSPOTCLICK, SCN_HOTSPOTDOUBLECLICK
        int scn_modificationType \ SCN_MODIFIED
        int scn_text             \ SCN_MODIFIED
        int scn_length           \ SCN_MODIFIED
        int scn_linesAdded       \ SCN_MODIFIED
        int scn_message          \ SCN_MACRORECORD
        int scn_wParam           \ SCN_MACRORECORD
        int scn_lParam           \ SCN_MACRORECORD
        int scn_line             \ SCN_MODIFIED
        int scn_foldLevelNow     \ SCN_MODIFIED
        int scn_foldLevelPrev    \ SCN_MODIFIED
        int scn_margin           \ SCN_MARGINCLICK
        int scn_listType         \ SCN_USERLISTSELECTION
        int scn_x                \ SCN_DWELLSTART, SCN_DWELLEND
        int scn_y                \ SCN_DWELLSTART, SCN_DWELLEND
;RecordSize: /scn

: fill-scn      ( l -- )
                scn /scn move ;

:M OnNotify:    ( h m w l -- res ) \ handle the Notifications
\ comment:
\                cr ." OnNotify: "
                fill-scn scn_code
                case \   SCN_STYLENEEDED        of ." SCN_STYLENEEDED" endof
                     \   SCN_STYLENEEDED        of ." SCN_STYLENEEDED" endof
                     \   SCN_CHARADDED          of ." SCN_CHARADDED" endof
                     \   SCN_SAVEPOINTREACHED   of ." SCN_SAVEPOINTREACHED" endof
                     \   SCN_SAVEPOINTLEFT      of ." SCN_SAVEPOINTLEFT" endof
                     \    SCN_KEY                of On_ScnKey: self endof
                     \   SCN_DOUBLECLICK        of ." SCN_DOUBLECLICK" endof
                     \   SCN_UPDATEUI           of ." SCN_UPDATEU" endof
                     \   SCN_MODIFIED           of ." SCN_MODIFIED" endof
                     \   SCN_MACRORECORD        of ." SCN_MACRORECORD" endof
                     \   SCN_MARGINCLICK        of ." SCN_MARGINCLICK" endof
                     \   SCN_NEEDSHOWN          of ." SCN_NEEDSHOWN" endof
                     \   SCN_PAINTED            of ." SCN_PAINTED" endof
                     \   SCN_USERLISTSELECTION  of ." SCN_USERLISTSELECTION" endof
                     \   SCN_URIDROPPED         of ." SCN_URIDROPPED" endof
                     \   SCN_DWELLSTART         of ." SCN_DWELLSTART" endof
                     \   SCN_DWELLEND           of ." SCN_DWELLEND" endof
                     \   SCN_ZOOM               of ." SCN_ZOOM" endof
                     \   SCN_HOTSPOTCLICK       of ." SCN_HOTSPOTCLICK" endof
                     \   SCN_HOTSPOTDOUBLECLICK of ." SCN_HOTSPOTDOUBLECLICK" endof
                     \   SCN_CALLTIPCLICK       of ." SCN_CALLTIPCLICK" endof
                endcase
\ comment;
                true ;M

:M OnCommand:   ( h m w l -- res )
comment:
                cr ." OnCommand: "
                over HIWORD
                case    SCEN_CHANGE    of ." SCEN_CHANGE" endof
                        SCEN_SETFOCUS  of ." SCEN_SETFOCUS" endof
                        SCEN_KILLFOCUS of ." SCEN_KILLFOCUS" endof
                endcase
comment;
                true ;M

;Class

MODULE


--- NEW FILE: Label.f ---
\ $Id: Label.f,v 1.1 2007/05/08 08:31:46 georgeahubert Exp $

\ *D doc\classes\
\ *> Controls

anew -Label.f

WinLibrary COMCTL32.DLL

Require controls.f

cr .( Loading Label Classes...)

INTERNAL
EXTERNAL

\ ------------------------------------------------------------------------
\ *W <a name="Label"></a>
\ *S Label class
\ ------------------------------------------------------------------------
:Class Label		<super StaticControl
\ *G Class for static controls

int style

:M ClassInit:   ( -- )
\ *G Initialise the class.
                ClassInit: super
                0 to style ;M

:M WindowStyle: ( -- style )
\ *G Get the window style of the control.
                WindowStyle: super
                style or ;M

:M AddStyle:    ( n -- )
\ *G Set any additional style of the control. Must be done before the control
\ ** is created.
                to style ;M

:M Setfont:     ( handle -- )
\ *G Set the font in the control.
                1 swap WM_SETFONT SendMessage:SelfDrop ;M

:M Enable:      ( f -- )
\ *G Enable the control.
                ID EnableDlgItem: parent ;M

:M Disable:     ( -- )
\ *G Disable the control.
                false Enable: self ;M

;Class
\ *G End of Label class

\ ------------------------------------------------------------------------
\ *W <a name="StaticImage"></a>
\ *S StaticImage class
\ ------------------------------------------------------------------------
|Class StaticImage	<Super Label
\ *G Base class for static control showing an image.
\ ** This is an internal class; don't use it directly.

:M ImageType:	( -- ImageType )
\ *G Get the image type of the control. \i ImageType \d is IMAGE_BITMAP.
		IMAGE_BITMAP ;M

:M GetImage:	( -- hImage )
\ *G Retrieve a handle to the image associated with the control.
		0 ImageType: [ self ] STM_GETIMAGE SendMessage:Self ;M

:M SetImage:	( hImage -- )
\ *G Associate a new image (icon or bitmap) with the control.
		GetImage: self over <>
		if   ImageType: [ self ] STM_SETIMAGE SendMessage:SelfDrop
		else drop
		then ;M

:M SetFont:     ( fhndl -- )
\ *G Set the font in the control.
                drop ;M

;Class
\ *G End of StaticImage class

\ ------------------------------------------------------------------------
\ *W <a name="StaticBitmap"></a>
\ *S StaticBitmap class
\ ------------------------------------------------------------------------
:Class StaticBitmap	<Super StaticImage
\ *G Static control showing a bitmap.

:M WindowStyle: ( -- style )
\ *G Get the window style of the control. Default style is: SS_BITMAP.
		WindowStyle: super SS_BITMAP OR ;M

;Class
\ *G End of StaticImage class

\ ------------------------------------------------------------------------
\ *W <a name="StaticIcon"></a>
\ *S StaticIcon class
\ ------------------------------------------------------------------------
:Class StaticIcon	<Super StaticImage
\ *G Static control showing an icon.

:M WindowStyle: ( -- style )
\ *G Get the window style of the control. Default style is: SS_ICON.
		WindowStyle: super SS_ICON OR ;M

:M ImageType: 	( -- ImageType )
\ *G Get the image type of the control. \i ImageType \d is IMAGE_ICON.
		IMAGE_ICON ;M

;Class
\ *G End of StaticIcon class

\ ------------------------------------------------------------------------
\ *W <a name="StaticMetafile"></a>
\ *S StaticMetafile class
\ ------------------------------------------------------------------------
:Class StaticMetafile	<Super StaticImage
\ *G Static control showing an enhanced metafile.

:M WindowStyle: ( -- style )
\ *G Get the window style of the control. Default style is: SS_ENHMETAFILE.
		WindowStyle: super SS_ENHMETAFILE OR ;M

:M ImageType: 	( -- ImageType )
\ *G Get the image type of the control. \i ImageType \d is IMAGE_ENHMETAFILE.
		IMAGE_ENHMETAFILE ;M

;Class
\ *G End of StaticMetafile class

\ ------------------------------------------------------------------------
\ *W <a name="StaticFrame"></a>
\ *S StaticFrame class
\ ------------------------------------------------------------------------
:Class StaticFrame	<Super Label
\ *G Static control showing a frame.

:M BlackRect:	( -- )
\ *G Rectangle in the window frame color (default is black).
		WindowStyle: super  SS_BLACKRECT OR  SetStyle: self ;M

:M GrayRect:	( -- )
\ *G Rectangle in the screen background color (default is gray).
		WindowStyle: super  SS_GRAYRECT OR  SetStyle: self ;M

:M WhiteRect:	( -- )
\ *G Rectangle in the window background color (default is white).
		WindowStyle: super  SS_WHITERECT OR  SetStyle: self ;M

:M BlackFrame:	( -- )
\ *G Frame in the window frame color (default is black).
		WindowStyle: super  SS_BLACKFRAME OR  SetStyle: self ;M

:M GrayFrame:	( -- )
\ *G Frame in the screen background color (default is gray).
		WindowStyle: super  SS_GRAYFRAME OR  SetStyle: self ;M

:M WhiteFrame:	( -- )
\ *G Frame in the window background color (default is white).
		WindowStyle: super  SS_WHITEFRAME OR  SetStyle: self ;M

:M EtchedFrame:	( -- )
\ *G draws an etched frame (frame appears lower than background)
		WindowStyle: super  SS_ETCHEDFRAME OR  SetStyle: self ;M

:M SunkenFrame:	( -- )
\ *G Draws frame with half-sunken border.
		WindowStyle: super  SS_SUNKEN OR  SetStyle: self ;M

;Class
\ *G End of StaticFrame class

MODULE

\ *Z

--- NEW FILE: ListBox.f ---
\ $Id: ListBox.f,v 1.1 2007/05/08 08:31:46 georgeahubert Exp $

\ *D doc\classes\
\ *> Controls

anew -ListBox.f

WinLibrary COMCTL32.DLL

Require controls.f

cr .( Loading ListBox Classes...)

INTERNAL
EXTERNAL

\ ------------------------------------------------------------------------
\ *W <a name="ComboBox"></a>
\ *S ComboBox class
\ ------------------------------------------------------------------------
:Class ComboBox		<super ComboControl
\ *G ComboBox control
\ ** (enhanced Version of the ComboControl class)

int style

:M ClassInit:   ( -- )
\ *G Initialise the class.
                ClassInit: super
                0 to style ;M

:M WindowStyle: ( -- style )
\ *G Get the window style of the control.
                WindowStyle: super
                style or ;M

:M AddStyle:    ( n -- )
\ *G Set any additional style of the control. Must be done before the control
\ ** is created.
                to style ;M

:M SetDir:      ( dirz$ attrib -- )
\ *G Add the names of directories and files that match a specified string and
\ ** set of file attributes. SetDir: can also add mapped drive letters to the list.
\ *P \i attrib \d Specifies the attributes of the files or directories to be added to
\ ** the combo box. This parameter can be one or more of the following values:
\ *L
\ *| DDL_ARCHIVE    | Includes archived files. |
\ *| DDL_DIRECTORY  | Includes subdirectories, which are enclosed in square brackets ([ ]). |
\ *| DDL_DRIVES All | mapped drives are added to the list. Drives are listed in the form [-x-], where x is the drive letter. |
\ *| DDL_EXCLUSIVE  | Includes only files with the specified attributes. By default, read-write files are listed even if DDL_READWRITE is not specified. |
\ *| DDL_HIDDEN     | Includes hidden files. |
\ *| DDL_READONLY   | Includes read-only files. |
\ *| DDL_READWRITE  | Includes read-write files with no additional attributes. This is the default. |
\ *| DDL_SYSTEM     | Includes system files. |
\ *P \i dirz$ \d specifies an absolute path, relative path, or file name. An absolute path
\ ** can begin with a drive letter (for example, d:\) or a UNC name (for example, \\machinename\sharename).
\ ** If the string specifies a file name or directory that has the attributes specified by
\ ** the wParam parameter, the file name or directory is added to the list. If the file name
\ ** or directory name contains wildcard characters (? or *), all files or directories that
\ ** match the wildcard expression and have the attributes specified by the wParam parameter
\ ** are added to the list displayed in the combo box.
                CB_DIR SendMessage:SelfDrop ;M

:M AddStringTo: ( z"string" -- )
\ *G Add a string to the list box of a combo box. If the combo box does not have the
\ ** CBS_SORT style, the string is added to the end of the list. Otherwise, the string
\ ** is inserted into the list, and the list is sorted.
                0 CB_ADDSTRING SendMessage:SelfDrop ;M

:M SetSelection: ( n -- )
\ *G Select a string in the list of a combo box.
                0 swap CB_SETCURSEL SendMessage:SelfDrop ;M

:M GetSelectedString: ( -- addr cnt )
\ *G Get the selected from the combo box.
\ ** Note: The string is returned in the global \i NEW$ \d.
                0 0 CB_GETCURSEL SendMessage:Self
                new$ dup rot CB_GETLBTEXT SendMessage:Self
                ;M

:M Setfont:     ( handle -- )
\ *G Set the font in the control.
                1 swap WM_SETFONT SendMessage:SelfDrop ;M

:M InsertStringAt: ( lpszString posn -- )
\ *G Insert string at the specified position.
\ *P \i posn \d specifies the zero-based index of the position at which to insert
\ ** the string. If this parameter is -1, the string is added to the end of the list.
\ *P \i lpszString \d is a null-terminated string to be inserted.
                CB_INSERTSTRING SendMessage:Self
		CB_ERR OVER = SWAP CB_ERRSPACE = OR
		ABORT" Error adding string to combo box" ;M

:M DeleteString: ( index -- )
\ *G Delete a string.
\ *P \i index \d specifies the zero-based index of the string to delete.
		0 SWAP CB_DELETESTRING SendMessage:SelfDrop ;M

:M Clear: 	( -- )
\ *G Remove all strings from the combo box
		0 0 CB_RESETCONTENT SendMessage:SelfDrop ;M

:M Find: 	( lpszString -- index )
\ *G Search the list for an item beginning with the string (case-insensitive)
		-1 CB_FINDSTRING SendMessage:Self ;M

:M FindExact: 	( lpszString -- index )
\ *G Find the first item that matches the string exactly (case-insensitive)
		-1 CB_FINDSTRINGEXACT SendMessage:Self ;M

:M GetCount: 	( -- n )
\ *G Return count of items in list
		0 0 CB_GETCOUNT SendMessage:Self ;M

:M SelectString: ( lpszString -- index )
\ *G Select item beginning with string
		-1 CB_SELECTSTRING SendMessage:Self ;M

:M GetStringAt:	( index -- a n )
\ *G Return string of specified item.

\ TODO: Don't use HERE here !!!
		HERE SWAP CB_GETLBTEXT SendMessage:Self  HERE SWAP ;M

:M GetCurrent: 	( -- index )
\ *G return current selection item
		0 0 CB_GETCURSEL SendMessage:Self ;M

:M Enable:      ( f -- )
\ *G Enable the control.
                ID EnableDlgItem: parent ;M

:M Disable:     ( -- )
\ *G Disable the control.
                false Enable: self ;M

;Class
\ *G End of ComboBox class

\ ------------------------------------------------------------------------
\ *W <a name="ComboListBox"></a>
\ *S ComboListBox class
\ ------------------------------------------------------------------------
:Class ComboListBox	<super ComboBox
\ *G ComboBox list control

:M WindowStyle: ( -- style )
\ *G Get the window style of the control. The default style is: CBS_DROPDOWNLIST
                WindowStyle: SUPER CBS_DROPDOWNLIST OR ;M

:M Start:       ( Parent -- )
\ *G Create the control.
\ We don't want the editcontrol in this control to be subclassed as with
\ super class. It shows the ibeam cursor so we override the start method.
                TO Parent
                z" COMBOBOX" Create-Control ;M

;Class
\ *G End of ComboListBox class

\ ------------------------------------------------------------------------
\ *W <a name="ListBox"></a>
\ *S ListBox class
\ ------------------------------------------------------------------------
:Class ListBox		<super ListControl
\ *G ListBox control (single selection)
\ ** (enhanced Version of the ListControl class)

int style

:M ClassInit:   ( -- )
\ *G Initialise the class.
                ClassInit: super
                0 to style ;M

:M WindowStyle: ( -- style )
\ *G Get the window style of the control.
                WindowStyle: super
                style or ;M

:M AddStyle:    ( n -- )
\ *G Set any additional style of the control. Must be done before the control
\ ** is created.
                to style ;M

:M SetDir:      ( dirz$ attrib -- )
\ *G Add the names of directories and files that match a specified string and
\ ** set of file attributes. SetDir: can also add mapped drive letters to the list.
\ *P \i attrib \d Specifies the attributes of the files or directories to be added to
\ ** the combo box. This parameter can be one or more of the following values:
\ *L
\ *| DDL_ARCHIVE    | Includes archived files. |
\ *| DDL_DIRECTORY  | Includes subdirectories, which are enclosed in square brackets ([ ]). |
\ *| DDL_DRIVES All | mapped drives are added to the list. Drives are listed in the form [-x-], where x is the drive letter. |
\ *| DDL_EXCLUSIVE  | Includes only files with the specified attributes. By default, read-write files are listed even if DDL_READWRITE is not specified. |
\ *| DDL_HIDDEN     | Includes hidden files. |
\ *| DDL_READONLY   | Includes read-only files. |
\ *| DDL_READWRITE  | Includes read-write files with no additional attributes. This is the default. |
\ *| DDL_SYSTEM     | Includes system files. |
\ *P \i dirz$ \d specifies an absolute path, relative path, or file name. An absolute path
\ ** can begin with a drive letter (for example, d:\) or a UNC name (for example, \\machinename\sharename).
\ ** If the string specifies a file name or directory that has the attributes specified by
\ ** the wParam parameter, the file name or directory is added to the list. If the file name
\ ** or directory name contains wildcard characters (? or *), all files or directories that
\ ** match the wildcard expression and have the attributes specified by the wParam parameter
\ ** are added to the list displayed in the combo box.
                LB_DIR SendMessage:SelfDrop ;M

:M Clear:       ( -- )
\ *G Remove all items from the list box.
                0 0 LB_RESETCONTENT SendMessage:SelfDrop ;M

:M AddStringTo: ( z"string" -- )
\ *G Add a string to a list box. If the list box does not have the LBS_SORT style,
\ ** the string is added to the end of the list. Otherwise, the string is inserted
\ ** into the list and the list is sorted.
                0 LB_ADDSTRING SendMessage:SelfDrop ;M

:M SetSelection: ( n -- )
\ *G Select a string and scroll it into view, if necessary. When the new string is
\ ** selected, the list box removes the highlight from the previously selected string.
\ *P \i n \d specifies the zero-based index of the string that is selected. If this parameter
\ ** is -1, the list box is set to have no selection.
\ *P Windows 95/98: The \i n \d parameter is limited to 16-bit values. This means list boxes
\ ** cannot contain more than 32,767 items. Although the number of items is restricted, the
\ ** total size in bytes of the items in a list box is limited only by available memory.
                0 swap LB_SETCURSEL SendMessage:SelfDrop ;M

:M GetSelection: ( -- n )
\ *G Retrieve the index of the currently selected item, if any.
\ *P The return value is the zero-based index of the currently selected item. If there is no
\ ** selection, the return value is LB_ERR.
                0 0 LB_GETCURSEL SendMessage:Self ;M

:M GetString:    ( index -- addr n )
\ *G Retrieve a string from the list box.
\ *P The return value is the length of the string, in chars, excluding the terminating null character.
\ ** If \i n \d does not specify a valid index, the return value is LB_ERR.
                new$ dup rot LB_GETTEXT SendMessage:Self  ;M

:M GetSelectedString: ( -- addr cnt )
\ *G Retrieve the currently selected string from the list box.
\ ** Note: The string is returned in the global \i NEW$ \d.
                GetSelection: self GetString: self ;M

:M GetCount:    ( -- n )
\ *G Retrieve the number of items in the list box.
                0 0 LB_GETCOUNT SendMessage:Self ;M

:M Setfont:     ( handle -- )
\ *G Set the font in the control.
                1 swap WM_SETFONT SendMessage:SelfDrop ;M

:M AddString: 	( lpszString -- )
\ *G Add a string to a list box. If the list box does not have the LBS_SORT style,
\ ** the string is added to the end of the list. Otherwise, the string is inserted
\ ** into the list and the list is sorted.
\ ** Note: This method ABORT's on error.
                0 LB_ADDSTRING SendMessage:Self
                LB_ERR OVER = SWAP LB_ERRSPACE = OR
                ABORT" Error adding string to list box"
                ;M

:M InsertString: ( lpszString index -- )
\ *G Insert a string into the list box. Unlike the AddString: method, the InsertString: method
\ ** does not cause a list with the LBS_SORT style to be sorted.
\ ** Note: This method ABORT's on error.
\ *P \i index \d specifies the zero-based index of the position at which to insert
\ ** the string. If this parameter is -1, the string is added to the end of the list.
\ *P Windows 95/98: The \i index \d parameter is limited to 16-bit values. This means list
\ ** boxes cannot contain more than 32,767 items. Although the number of items is restricted,
\ ** the total size in bytes of the items in a list box is limited only by available memory.
		LB_INSERTSTRING SendMessage:Self
		LB_ERR OVER = SWAP LB_ERRSPACE = OR
		ABORT" Error inserting string in list box"
		;M

:M DeleteString: ( index -- )
\ *G Delete a string from the list box.
\ *P \i index \d specifies the zero-based index of the string to be deleted.
\ *P Windows 95/98: The \i index \d parameter is limited to 16-bit values. This means list boxes
\ ** cannot contain more than 32,767 items. Although the number of items is restricted, the total
\ ** size in bytes of the items in a list box is limited only by available memory.
		0 SWAP LB_DELETESTRING SendMessage:SelfDrop ;M

:M Find: 	( lpszString -- index )
\ *G Find the first string in the list box that begins with the specified string.
\ ** The entire list box is searched from the beginning.
\ ** The search is case independent, so the string (\i lpszString \d) can contain any combination of
\ ** uppercase and lowercase letters.
\ *P The return value is the zero-based index of the matching item, or LB_ERR if the search was unsuccessful.
		-1 LB_FINDSTRING SendMessage:Self ;M

:M FindExact: 	( lpszString -- index )
\ *G Find the first list box string that exactly matches the specified string, except that the search
\ ** is not case sensitive.
\ ** The entire list box is searched from the beginning.
\ *P The return value is the zero-based index of the matching item, or LB_ERR if the search was unsuccessful.
	-1 LB_FINDSTRINGEXACT SendMessage:Self ;M

:M GetCurrent: 	( -- index )
\ *G Retrieve the index of the currently selected item, if any.
\ *P The return value is the zero-based index of the currently selected item. If there is no
\ ** selection, the return value is LB_ERR.
                GetSelection: self ;M

:M SelectString: ( lpszString -- index )
\ *G Search the list box for an item that begins with the characters in a specified string.
\ ** If a matching item is found, the item is selected.
\ ** The entire list box is searched from the beginning.
\ *P If the search is successful, the return value is the index of the selected item. If the
\ ** search is unsuccessful, the return value is LB_ERR and the current selection is not changed.
		-1 LB_SELECTSTRING SendMessage:Self ;M

:M GetState:	( index -- f )
\ *G Retrieve the selection state of an item.
\ ** If an item is selected, the return value is true; otherwise, it is false.
\ ** Note: This method ABORT's on error.
		0 SWAP LB_GETSEL SendMessage:Self
		LB_ERR OVER = ABORT" GetState: error occurred."
		0>
		;M

:M Enable:      ( f -- )
\ *G Enable the control.
                ID EnableDlgItem: parent ;M

:M Disable:     ( -- )
\ *G Disable the control.
                false Enable: self ;M

:M SetTabStops: ( addr cnt -- )
\ *G Set the tab-stop positions in the list box.
\ *P \i cnt \d Specifies the number of tab stops in the list box.
\ *P \i addr \d is a pointer to the first member of an array of integers containing the tab
\ ** stops. The integers represent the number of quarters of the average character width for
\ ** the font that is selected into the list box. For example, a tab stop of 4 is placed at
\ ** 1.0 character units, and a tab stop of 6 is placed at 1.5 average character units. However,
\ ** if the list box is part of a dialog box, the integers are in dialog template units. The tab
\ ** stops must be sorted in ascending order; backward tabs are not allowed.
\ *P The list box must have been created with the LBS_USETABSTOPS style.
                LB_SETTABSTOPS SendMessage:SelfDrop ;M

;Class
\ *G End of ListBox class

\ ------------------------------------------------------------------------
\ *W <a name="MultiListbox"></a>
\ *S MultiListbox class
\ ------------------------------------------------------------------------
:Class MultiListbox  	<Super Listbox
\ *G ListBox control
\ ** MultiListbox allows multiple selections to be made.
\ ** Click once on an item to select it.  Click again to deselect.

:M WindowStyle: ( -- style )
\ *G Get the window style of the control. The default style is: LBS_MULTIPLESEL
		WindowStyle: super
		LBS_MULTIPLESEL OR
		;M

:M Select:	( index -- )
\ *G Select a string in the list box.
\ *P \i index \d specifies the zero-based index of the string to set. If this parameter
\ ** is -1, the selection is added to all strings.
\ ** Note: This method ABORT's on error.
		TRUE LB_SETSEL SendMessage:Self
		LB_ERR = ABORT" Select: error occurred."
		;M

:M Unselect: 	( index -- )
\ *G Deselect a string in the list box.
\ *P \i index \d specifies the zero-based index of the string to set. If this parameter
\ ** is -1, the selection is removed from all strings.
\ ** Note: This method ABORT's on error.
		FALSE LB_SETSEL SendMessage:Self
		LB_ERR = ABORT" Unselect: error occurred."
		;M

:M GetSelCount:	( -- n )
\ *G Retrieve the total number of selected items in the list box.
		0 0 LB_GETSELCOUNT SendMessage:Self ;M

:M GetSelectedItems: ( array cnt -- count )
\ *G Fill a buffer with an array of integers that specify the item numbers of selected
\ ** items in the list box.
\ *P \i array \d is a pointer to a buffer large enough for the number of integers specified
\ ** by the \i cnt \d parameter.
\ *P \i cnt \d specifies the maximum number of selected items whose item numbers are to be placed
\ ** in the buffer. Windows 95/98: The \i cnt \d parameter is limited to 16-bit values. This means
\ ** list boxes cannot contain more than 32,767 items. Although the number of items is restricted,
\ ** the total size in bytes of the items in a list box is limited only by available memory.
		LB_GETSELITEMS SendMessage:Self ;M
;Class
\ *G End of MultiListbox class

\ *W <a name="MultiExListbox"></a>
\ *S MultiExListbox class
:Class MultiExListbox	<Super MultiListbox
\ *G ListBox control
\ ** Also allows multiple selections to be made.
\ ** The difference is that Ctrl-Click selects and unselects
\ ** individual items and Shift-Click will select a range (as will
\ ** Shift-Drag.

:M WindowStyle: ( -- style )
\ *G Get the window style of the control. The default style is: LBS_EXTENDEDSEL
      WindowStyle: super LBS_EXTENDEDSEL OR ;M

;Class
\ *G End of MultiExListbox class

\ ------------------------------------------------------------------------
\ *W <a name="DragListbox"></a>
\ *S DragListbox class
\ ------------------------------------------------------------------------
:Class DragListbox	<Super Listbox
\ *G ListBox control
\ ** Allows dragging of items in list box to re-order them
\ ** requires processing of drag list notification messages by the
\ ** application to actually do the dragging.

:M WindowStyle: ( -- style )
\ *G Get the window style of the control. The default style is: LBS_EXTENDEDSEL
		WindowStyle: super
		LBS_EXTENDEDSEL OR
		;M

:M Start:       ( Parent -- )
\ *G Create the control.
		Start: super \ create a single-selection list box
		hWnd Call MakeDragList ?Win-Error \ convert it to a Drag-type
		;M

;Class
\ *G End of DragListbox class

MODULE

\ *Z

Index: treeview.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/lib/treeview.f,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** treeview.f	6 May 2007 14:09:32 -0000	1.1
--- treeview.f	8 May 2007 08:31:46 -0000	1.2
***************
*** 5,9 ****
  \               On creation needs a sensible StartSize: ( default set to size of parent )
  \               Class control does not have the definition "null-check" which is in
! \               class Window and hence Child-Window. 
  
  (( TreeView.F   A rudimentary TreeView class              by Michael Hillerström
--- 5,9 ----
  \               On creation needs a sensible StartSize: ( default set to size of parent )
  \               Class control does not have the definition "null-check" which is in
! \               class Window and hence Child-Window.
  
  (( TreeView.F   A rudimentary TreeView class              by Michael Hillerström
***************
*** 42,45 ****
--- 42,47 ----
  ))
  
+ Require control.f
+ 
  cr .( Loading TreeView Class...)
  
***************
*** 86,91 ****
  comment;
  
! Needs Window.f
! Needs Control.f
  
  \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
--- 88,92 ----
  comment;
  
! 
  
  \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

--- NEW FILE: StatusBar.f ---
\ $Id: StatusBar.f,v 1.1 2007/05/08 08:31:46 georgeahubert Exp $

\ StatusBar.f
\ Statusbar control separated from ExControls

\ *D doc\classes\
\ *> Controls
\ *T ExControls -- More (enhanced) classes for standard windows controls.

Require control.f

cr .( Loading StatusBar Class...)

anew -StatusBar.f

WinLibrary COMCTL32.DLL

INTERNAL
EXTERNAL

\ ------------------------------------------------------------------------
\ *W <a name="Statusbar"></a>
\ *S Statusbar class
\ ------------------------------------------------------------------------
:Class Statusbar	<Super Control
\ *G Status bar control
\ *P A status bar is a horizontal window at the bottom of a parent window in
\ ** which an application can display various kinds of status information.
\ *P This status bar control has only one part to display information.

INT BorderStyle \ style of border to use
int style

:M AddStyle:    ( n -- )
\ *G Set any additional style of the control. Must be done before the control
\ ** is created.
                to style ;M

:M Start:       ( Parent -- )
\ *G Create the control.
                to parent Z" msctls_statusbar32" create-control
                0 TRUE SB_SIMPLE SendMessage:SelfDrop
                ;M

:M WindowStyle: ( -- style )
\ *G Get the window style of the control. Default style is: WS_CHILD WS_VISIBLE or.
		WindowStyle: super style or ;M

:M RaisedBorder: ( -- )
\ *G The text is drawn with a border to appear lower than the plane of the
\ ** window (default).
		0 TO BorderStyle ;M

:M NoBorder: 	( -- )
\ *G The text is drawn without borders.
		SBT_NOBORDERS TO BorderStyle ;M

:M SunkenBorder: ( -- )
\ *G The text is drawn with a border to appear higher than the plane of the window.
		SBT_POPOUT TO BorderStyle ;M

:M ClassInit:   ( -- )
\ *G Initialise the class.
		ClassInit: super
		RaisedBorder: self
    0 to style ;M

:M MinHeight: 	( #pixels -- )
\ *G Sets the minimum height of the status window's drawing area.
\ *P The minimum height is the sum of #pixels and twice the width, in pixels,
\ ** of the vertical border of the status window.
\ *P An application must use the Redraw: method to redraw the window.
		0 SWAP SB_SETMINHEIGHT SendMessage:SelfDrop ;M

:M GetBorders: 	( -- hWidth vWidth divWidth )
\ *G Retrieves the current widths of the horizontal and vertical borders of
\ ** the status window.
\ *P \i hWidth \d is the width of the horizontal border.
\ *P \i vWidth \d is the width of the vertical border.
\ *P \i divWidth \d is the width of the border between rectangles.

\ TODO: Don't use HERE here !!!
		HERE 0 SB_GETBORDERS SendMessage:Self ?Win-Error
		HERE DUP @  SWAP CELL+ DUP @  SWAP CELL+ @
		;M

:M Redraw: 	( -- )
\ *G Redraw the statusbar after changes (e.g. size).
		0 0 WM_SIZE SendMessage:SelfDrop ;M

:M SetText: 	( szText -- )
\ *G Sets the text in the status window.
\ *P Use \i RaisedBorder: \d, \i NoBorder: \d or \i SunkenBorder: \d to set
\ ** the the style how the text is drawn.
		255 BorderStyle OR SB_SETTEXTA SendMessage:Self ?Win-error ;M

:M Clear: 	( -- )
\ *G clears text in the status window.
		Z" " SetText: self ;M

:M Setfont:     ( handle -- )
\ *G Set the font in the control.
                1 swap WM_SETFONT SendMessage:SelfDrop ;M

:M Height:      ( -- height )
\ Get the height of the status window.
                GetWindowRect: self
                nip swap - nip ;M
;Class
\ *G End of Statusbar class

\ ------------------------------------------------------------------------
\ *W <a name="MultiStatusbar"></a>
\ *S MultiStatusbar class
\ ------------------------------------------------------------------------
:Class MultiStatusbar	<Super Statusbar
\ *G Status bar control
\ *P A status bar is a horizontal window at the bottom of a parent window in
\ ** which an application can display various kinds of status information.
\ *P This status bar control can have multiple parts to display information.

INT nParts    \ number of parts in statusbar
INT aWidths   \ address of widths table

:M Start:       ( Parent -- )
\ *G Create the control.
                Start: super
                0 FALSE SB_SIMPLE SendMessage:SelfDrop
                ;M

:M SetParts: 	( aWidths nParts -- )
\ *G Sets the number of parts in the status window and the coordinate of the right
\ ** edge of each part.
\ *P \i nParts \d Number of parts to set (cannot be greater than 256).
\ *P \i aWidths \d is a pointer to an integer array. The number of elements is
\ ** specified in nParts. Each element specifies the position, in client coordinates,
\ ** of the right edge of the corresponding part. If an element is -1, the right edge
\ ** of the corresponding part extends to the border of the window.
\ *P Note: \i aWidths \d must be valid until SetParts: is used again!
                TO nParts
		TO aWidths
		aWidths nParts SB_SETPARTS SendMessage:Self ?Win-error
		;M

:M GetParts: 	( -- aWidths nParts )
\ *G Gets the number of parts in the status window and the coordinate of the right
\ ** edge of each part.
		aWidths nParts ;M

:M SetSimple: 	( -- )
\ *G Reset the status bar to show only one part.
		0 TRUE SB_SIMPLE SendMessage:SelfDrop ;M

:M SetMulti:	( -- )
\ *G Set the status bar to show all parts set with \i SetParts: \d before.
		0 FALSE SB_SIMPLE SendMessage:SelfDrop ;M

:M SetText: 	( szText n -- )
\ *G Sets the text in the \i n'th \d part of status window.
\ *P Use \i RaisedBorder: \d, \i NoBorder: \d or \i SunkenBorder: \d to set
\ ** the the style how the text is drawn.
		BorderStyle OR SB_SETTEXTA SendMessage:Self ?Win-Error ;M

;Class
\ *G End of MultiStatusbar class

MODULE

\ *Z


--- NEW FILE: ScrollBar.f ---
\ $Id: ScrollBar.f,v 1.1 2007/05/08 08:31:46 georgeahubert Exp $

\ *D doc\classes\
\ *> Controls

anew -ScrollBar.f

WinLibrary COMCTL32.DLL

Require control.f

cr .( Loading ScrollBar Class...)

INTERNAL
EXTERNAL

\ ------------------------------------------------------------------------
\ *W <a name="ScrollBar"></a>
\ *S ScrollBar class
\ ------------------------------------------------------------------------
|Class ScrollBar	<Super Control
\ *G Scrollbar control
\ ** Note: this is an internal class. Don't use it directly.

int style
Record: ScrollInfo
    INT cbSize
    INT fMask
    int  nMin
    int  nMax
    INT nPage
    int  nPos
    int  nTrackPos
;RecordSize: sizeof(ScrollInfo)

:M ClassInit:   ( -- )
\ *G Initialise the class.
                ClassInit: super
                0 to style
                sizeof(ScrollInfo) to cbSize
                0 to nMin
                100 to nMax
                25 to nPage
                0 to npos
                ;M

:M WindowStyle: ( -- style )
\ *G Get the window style of the control.
                WindowStyle: super
                style or ;M

:M AddStyle:    ( n -- )
\ *G Set any additional style of the control. Must be done before the control
\ ** is created.
                to style ;M

: SetScrollInfo ( -- n )
                1 ScrollInfo SB_CTL hwnd Call SetScrollInfo ;

: GetScrollInfo ( -- n )
                ScrollInfo SB_CTL hwnd Call GetScrollInfo ;

:M SetRange:    ( min max -- )
                to nMax to nMin SIF_RANGE to fMask
                SetScrollInfo to npos ;M

:M GetRange:    ( -- min val )
                SIF_RANGE to fmask
                GetScrollInfo drop
                nmin nmax ;M

:M SetPosition: ( n -- prev )
                to npos SIF_POS to fmask
                SetScrollInfo to npos ;M

:M GetPosition: ( -- n )
                SIF_POS to fmask
                GetScrollInfo drop npos ;M

:M SetPage:     ( page -- )
                to npage SIF_PAGE to fmask
                SetScrollInfo drop ;M

:M GetPage:     ( -- page )
                SIF_PAGE to fmask
                GetScrollInfo drop npage ;M

:M Start:       ( Parent -- )
\ *G Create the control.
                to parent z" SCROLLBAR" create-control ;M

:M SetFont:     ( hndl -- )
\ *G Set the font in the control.
\ ** Note that this is a dummy method in this class.
                drop ;M

:M Enable:      ( f -- )
\ *G Enable the control.
                ID EnableDlgItem: parent ;M

:M Disable:     ( -- )
\ *G Disable the control.
                false Enable: self ;M

;Class

\ ------------------------------------------------------------------------
\ *W <a name="HorizScroll"></a>
\ *S HorizScroll class
\ ------------------------------------------------------------------------
:Class HorizScroll      <Super ScrollBar
\ *G Scrollbar control (vorizontal).

:M WindowStyle: ( -- style )
\ *G Get the window style of the control. Default style is: SBS_HORZ.
                WindowStyle: super SBS_HORZ or ;M

;Class
\ *G End of HorizScroll class

\ ------------------------------------------------------------------------
\ *W <a name="VertScroll"></a>
\ *S VertScroll class
\ ------------------------------------------------------------------------
:Class VertScroll	<Super ScrollBar
\ *G Scrollbar control (vertical).

:M WindowStyle: ( -- style )
\ *G Get the window style of the control. Default style is: SBS_VERT.
                WindowStyle: super SBS_VERT or ;M

;Class
\ *G End ...
 
[truncated message content]

[Win32forth-cvs] win32forth-stc/src/console BasicWin.f, NONE, 1.1 ConsoleStatbar.f, NONE, 1.1 Statbar.f, NONE, 1.1 WinBase.f, NONE, 1.1

[George H. <geo...@us...>]

Update of /cvsroot/win32forth/win32forth-stc/src/console
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv12988/win32forth-stc/src/console

Added Files:
	BasicWin.f ConsoleStatbar.f Statbar.f WinBase.f 
Log Message:
gah:Added files for console status bar: NOTE needs the kernel to be meta compiled. Also when the status bar is loaded the info doesn't show until after the first use of interpret; just hit enter.

--- NEW FILE: WinBase.f ---
\ $Id: WinBase.f,v 1.1 2007/05/08 08:08:44 georgeahubert Exp $

\    File: WinBase.f
\  Author: Jeff Kelm
\ Created: 27-Aug-1998
\ Updated: August 17th, 2003 dbu
\ Extensions and defines for Win32For

Comment:  Revision History (most recent first)

September 17th, 2003 dbu
 - removed old Win32s support
August 17th, 2003 dbu
 - Changed to use in WinEd 2.21.05 and later
19990601
 - Uncommented the constants which don't show up on my NT machine (running older
   version of Win32forth).
19990520
 - Removed the class name string definitions since these are now
   handled in the ChildWindow DefClassName: method.
 - Commented out most of the constant declarations since they
   now appear to work (at least on Win98, Win32Forth v4.2).
19990519
 - Added stack frame code.
19990422
 - Eliminated the 990413 changes.  Didn't work.
19990413
 - Eliminated "WinLibrary COMCTL32.DLL" initialization.  Moved to
   BasicWin.f in Create: for ChildWindow.  This will hopefully clear up
   issues with turnkeying if that DLL isn't already loaded.
19990315
 - Changed DefinedAbort, to correct a problem in ?WinError
   ?WinError didn't compile the right stuff if the source was from the
   keyboard (or pasted from the clipboard) but inside a definition.
   The definition:
      : DrawAxes ...  hdc GetHandle: wnd1 Call ReleaseDC  ?WinError ;
   generated this when typed in by hand (or pasted):
      : DrawAxes ... HDC lit O:WND1 M0:GETHANDLE: Call ReleaseDC
         DUP (?WINERROR) 0= ;   \ leaves a flag on the stack!
   and generated this when read in from file:
      : DrawAxes ... HDC lit O:WND1 M0:GETHANDLE: Call ReleaseDC
         DUP (?WINERROR) 0= ABORT" Defined in file: popup.f -- Line: 80" ;
   corrected version generates:
      : DrawAxes ... HDC lit O:WND1 M0:GETHANDLE: Call ReleaseDC
         DUP (?WINERROR) 0= DROP ;
 - eliminated redundant IF...ELSE...THEN clause in DefinedAbort, since
   the only way DefinedAbort, is executed is when STATE is true.
19981120
 - added UPDOWN_CLASS definition
19981118
 - added TTM_UPDATETIPTEXT, TTM_ENUMTOOLS & TTM_GETTEXT
19981117
 - separated window classes into their own file (BasicWin.f)
 - Simplified definitions for zCount and MAKELONG
 - Factored ?WinError, but it still looks too complicated
Comment;

Require menu.f

CR  .( Loading Extensions...)



\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ \\\ Extensions to Win32For
\

in-system

: DEFAULTOF   \ defines a default condition for CASE structure (must be last!)
   POSTPONE DUP POSTPONE OF ; IMMEDIATE

in-application

\ MAKELONG macro creates an unsigned 32-bit by concatenating two 16-bit values
: MAKELONG ( hi lo -- n)   SWAP word-join ;



\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ \\\ Redefined ?WinError to give more debugging information
\
: (GetLastError) ( -- n)   GetLastWinErr ;

: (FormatSystemMessage) ( error -- a n)
   GetLastWinErrMsg count ;

: (?WinError) ( f)   \ show an error dialog box if f=FALSE/0
   0= IF  (GetLastError) (FormatSystemMessage)
          2DUP  2 - ( to drop CRLF pair)  CR TYPE CR  ( echo to console)
          DROP >R
          MB_OK MB_ICONWARNING OR  Z" Error"
             R> NULL  Call MessageBox drop
    THEN ;


false [IF]   \ add more debugging information to ?WinError

   : DefinedAbort,   \ compiles an ABORT" with the file name and line where defined
        LOADING?
        IF  S" Defined in file: "    TEMP$ PLACE
              LOADFILE COUNT         TEMP$ +PLACE
              S"  -- Line: "         TEMP$ +PLACE
              LOADLINE @ (.)         TEMP$ +PLACE
              POSTPONE (ABORT")
              TEMP$ COUNT ", 0 c, align
        ELSE  POSTPONE DROP
        THEN
        ;

   : ?WinError ( f)
      STATE @ IF  POSTPONE DUP  POSTPONE (?WinError)  POSTPONE 0= DefinedAbort,
            ELSE  (?WinError)
            THEN ; IMMEDIATE

[ELSE]   \ just give messagebox as an alert, don't abort

   : ?WinError ( f)   (?WinError) ;

[THEN]

: CreateNewID ( -- id)   \ create a new id number (hopefully unique, but not guaranteed)
	NextId ;



WinLibrary COMCTL32.DLL   \ Add the advanced control library.
                          \ Needed for CreateToolbar, CreateStatusWindow, etc.


\ defines not in Win32for WINCON.DLL
\ TTN_GETDISPINFOA   CONSTANT TTN_NEEDTEXT       \ ANSI version
\ TBN_GETBUTTONINFOA CONSTANT TBN_GETBUTTONINFO  \ ANSI version
\ TTM_ADDTOOLA       CONSTANT TTM_ADDTOOL        \ ANSI version
\ SB_SETTEXTA        CONSTANT SB_SETTEXT         \ ANSI version
\ SB_GETTEXTA        CONSTANT SB_GETTEXT         \ ANSI version
\ TTM_UPDATETIPTEXTA CONSTANT TTM_UPDATETIPTEXT  \ ANSI version
\ TTM_GETTEXTA       CONSTANT TTM_GETTEXT        \ ANSI version
\ TTM_ENUMTOOLSA     CONSTANT TTM_ENUMTOOLS      \ ANSI version

   \ Strings not defined in Win32for
\   : STATUSCLASSNAME   Z" msctls_statusbar32" ;
\   : TOOLBARCLASSNAME  Z" ToolbarWindow32"    ;
\   : WC_TREEVIEW       Z" SysTreeView32"      ;
\   : TOOLTIPS_CLASS    Z" tooltips_class32"   ;
\   : PROGRESS_CLASS    Z" msctls_progress32"  ;
\   : TRACKBAR_CLASS    Z" msctls_trackbar32"  ;
\   : UPDOWN_CLASS      Z" msctls_updown32"    ;


\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ \\\ Load Resources
\
\ LR_LOADFROMFILE is not claimed to work on NT, but the documentation
\ appears to be out of date since it works on my NT machine.
\    For icons, the alternative would be:
\       0 Z" Toolbar.ico"  appInst
\       Call ExtractIcon  DUP VALUE hIcon  ?WinError
\    Couldn't find a simple alternative for bitmaps and didn't look
\    for one for cursors.

\ a is a relative address of a zString for file name,
\ f is resource type (IMAGE_ICON, IMAGE_BITMAP, or IMAGE_CURSOR)
\ returns handle to resource
: GetResource ( a f -- handle)
   2>R  LR_LOADFROMFILE 0 0 R> R>
   NULL  Call LoadImage  DUP ?WinError ;

\ create an icon resource from file
: GetIconResource ( a -- handle)
   IMAGE_ICON  GetResource ;

\ create a bitmap resource from file
: GetBmpResource ( a -- handle)
   IMAGE_BITMAP  GetResource ;

\ create a cursor resource from file
: GetCurResource ( a -- handle)
   IMAGE_CURSOR  GetResource ;



Comment:  ------------------------------------------------------
                Stack Frame Code

To address concerns raised by Tom Zimmer regarding storage and
reentrancy in my routines I have adopted an approach similar
to the way MASM handles it.  In MASM the directive LOCAL
generates a stack frame with enough room for the structure
being declared.

My initial attempts at this are admittedly crude, but will give
me something to play with for a now.  After experimenting a
while, I may come up with a more elegant approach.
------------------------------------------------------  Comment;

\ create a stack frame on the parameter stack for u cells, addr
\ is to top-of-stack item, x1.  Since stack grows down in
\ Win32Forth, this is the address to the start of the structure.
: sFrame ( u -- xn .. x2 x1 addr)   \ u<=100
   100 MIN 0 MAX  0 ?DO  0  LOOP  sp@ ;



\ for creating an initialized stack frame

0 VALUE OldStackPtr

: StartFrame ( -- )   \ start creating an initialized stack frame
   OldStackPtr ABORT" Can't nest initialized stack frames"
   sp@ TO OldStackPtr ;

: EndFrame ( -- addr)   \ end an initialized stack frame,
                        \ returning address of start of structure
   OldStackPtr 0= ABORT" No initialized stack frame started"
   sp@ ;

: ReclaimFrame ( xn ... x2 x1 -- )   \ return stack to state
                                     \ prior to stack frame
   OldStackPtr sp!  0 TO OldStackPtr ;


Comment:  ------------------------------------------------------

Usage
   StartFrame  ICC_DATE_CLASSES 8  EndFrame
      Call InitCommonControlsEx  ?WinError  ReclaimFrame

Could also try something like putting the stack frame on the return stack

Before              After    return address of a routine that cleans up the
xt2                 xt3  <== return stack before dropping through to xt2
xt1                 u    <== number of items to remove from the return stack
                    x1
                    x2
                    ...
                    xn
                    xt2
                    xt1

This would allow several frames to be created and kept around and they
would automagically delete themselves when the word that created them
return to the word that called it.
------------------------------------------------------  Comment;

--- NEW FILE: Statbar.f ---
\    File: Statbar.f
\  Author: Jeff Kelm
\ Created: 24-Sep-1998
\ Updated: August 17th, 2003 dbu
\ Classes to handle Statusbars (simple and multipart)

Comment:  Revision History (most recent first)
August 17th, 2003 dbu
 - Changed to use in WinEd 2.21.05 and later
19981231
 - Incorporated the new ChildWindow class.
19981216
 - Removed Redraw: SetStyle: GetStyle: methods, now handled in BasicWin.f
 - Changed SetSimple: to eliminate flag and created SetMulti: to make up for it
19981117
 - General cosmetic updates
 - redefined to use BaseWindow superclass and call BasicWin.f
 - eliminated SetParent: from Create: set by CreateStatusWindow now
Comment;


NEEDS BasicWin.f
CR  .( Loading Statusbar class for the Console window...)



\ Notes:
\ 1) SBARS_SIZEGRIP don't appear to work.  Always shows up with the size grip
\    box.



\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ \\\ Simple Statusbar Class
\
:Class Console_Statusbar  <Super Console_ChildWindow

      INT BorderStyle \ style of border to use

   :M DefStyle: ( -- style)   \ default control style
      [ WS_VISIBLE WS_CHILD OR ] literal
      ;M

   :M DefClassName: ( -- ClassName)   \ default class name
      Z" msctls_statusbar32"
      ;M

   :M Create: ( hParent)   \ creates an empty statusbar in parent window
      Create: super
      0 TRUE SB_SIMPLE SendMessage: self DROP
      ;M

comment:
:Class Statusbar  <Super BaseWindow

      INT BorderStyle \ style of border to use

   :M DefStyle: ( -- style)   \ override if another style is needed
      WS_BORDER WS_VISIBLE OR   \ WS_CHILD is forced
      ;M
comment;

   :M RaisedBorder: ( -- )   \ text drawn below border (default)
      0 TO BorderStyle
      ;M

   :M NoBorder: ( -- )   \ text drawn at border level (no border)
      SBT_NOBORDERS TO BorderStyle
      ;M

   :M SunkenBorder: ( -- )   \ text drawn above border
      SBT_POPOUT TO BorderStyle
      ;M

   :M ClassInit: ( -- )   \ initialize class
      ClassInit: super
      RaisedBorder: self           \ default, text lower than border
      ;M

comment:
   :M Create: ( hParent)   \ creates an empty statusbar in parent window
      CreateNewID                  \ Statusbar ID
      SWAP
      NULL                         \ initial string to display
      DefStyle: self  WS_CHILD OR  \ style
      Call CreateStatusWindow  DUP PutHandle: self  ?WinError
      0 TRUE SB_SIMPLE SendMessage: self DROP
      ;M
comment;

   \ NULL MinHeight: self  appears to reset to the default height statusbar
   :M MinHeight: ( #pixels)   \ set minimum height of text region (not including borders)
      0 SWAP SB_SETMINHEIGHT SendMessage: self DROP
      ;M

   :M GetBorders: ( -- hWidth vWidth divWidth)   \ returns the border widths in pixels
      HERE 0 SB_GETBORDERS SendMessage: self ?WinError
      HERE DUP @  SWAP CELL+ DUP @  SWAP CELL+ @
      ;M

   :M Redraw: ( -- )   \ redraw the statusbar after changes (e.g., size)
      0 0 WM_SIZE SendMessage: self DROP
      ;M

\   :M SetStyle: ( style)   \ set style of statusbar "on the fly"
\      GWL_STYLE GetHandle: self Call SetWindowLong DROP
\      Redraw: self
\      ;M

\   :M GetStyle: ( -- style)   \ get current style of statusbar
\      GWL_STYLE GetHandle: self Call GetWindowLong
\      ;M

   :M SetText: ( szText)   \ sets simple status bar text
      255 BorderStyle OR SB_SETTEXT SendMessage: self ?WinError
      ;M

   :M Clear: ( -- )   \ clears text from status window
      Z" " SetText: self
      ;M

;Class



\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ \\\ Multipart Statusbar Class
\
:Class Console_MultiStatusbar <Super Console_Statusbar

      INT nParts    \ number of parts in statusbar
      INT aWidths   \ address of widths table

   :M Create: ( hParent)
      Create: super
      0 FALSE SB_SIMPLE SendMessage: self DROP
      ;M

   :M SetParts: ( aWidths nParts)   \ width table address and count
      TO nParts
      TO aWidths
      aWidths nParts SB_SETPARTS SendMessage: self ?WinError
      ;M

   :M GetParts: ( -- aWidths nParts)   \ retrieve data structure info
      aWidths  nParts
      ;M

   :M SetSimple: ( flag)   \ sets status bar to show single-part
      0 TRUE SB_SIMPLE SendMessage: self DROP
      ;M

   :M SetMulti: ( flag)   \ sets status bar to show multiparts
      0 FALSE SB_SIMPLE SendMessage: self DROP
      ;M

   :M SetText: ( szText n)   \ set text in n'th part
      BorderStyle OR
\ was      SB_SETTEXT SendMessage: self DROP
( is)      SB_SETTEXT SendMessage: self ?WinError
      ;M

;Class


--- NEW FILE: ConsoleStatbar.f ---
\ $Id: ConsoleStatbar.f,v 1.1 2007/05/08 08:08:44 georgeahubert Exp $

\    File: ConsoleStatbar.f
\  Author: Dirk Busch
\ Created: September 26th, 2003 - 10:30 dbu
\ Updated: January 22nd, 2004 - 10:43 dbu
\ Statusbar for the Win32Forth console window

needs Statbar.f \ Status bar Class by Jeff Kelm

\ anew -ConsoleStatbar.f

INTERNAL

\ *****************************************************************************
\  window class for the status bar
\ *****************************************************************************

:Object ConsoleStatusbar  <Super Console_MultiStatusbar

create MultiWidth 80 , -1 , \ width of statusbar parts

0 value forth-sp
0 value forth-depth
0 value forth-base

8 value display-depth       \ # of stack entries that are displayed

:M Create:      ( hParent -- )
                Create: super
                GetHandle: self
                if   MultiWidth 2 SetParts: self
                     Show: self
                then ;M

:M SetSP:       ( n -- )
                to forth-sp ;M

:M SetDepth:    ( n -- )
                to forth-depth ;M

:M SetBase:     ( n -- )
                to forth-base ;M

:M SetDisplayDepth:     ( n -- )
                to display-depth ;M

:M SetText:     ( a n -- ) \ set text a for part n
                swap dup +null 1+ swap SetText: super ;M

:M Update:      { \ buf$ buf1$ pad$ -- }
                MAXSTRING LocalAlloc: buf$  \ temp string buffer
                MAXSTRING LocalAlloc: buf1$ \ temp string buffer
                MAXSTRING LocalAlloc: pad$  \ a place to save PAD
                pad pad$ MAXSTRING move \ save PAD, (.) not reentrant
                hld @ >r                \ save HLD, (.) not reentrant

                \ print base
                s"  Base: " buf$ place
                forth-base
                case        2 of s" binary"  buf$ +place endof
                            8 of s" octal"   buf$ +place endof
                           10 of s" decimal" buf$ +place endof
                           16 of s" hex"     buf$ +place endof
                       defaultof decimal forth-base (.) buf$ +place forth-base base ! endof
                endcase
                buf$ 0 SetText: self

                \ print stack from left to right (right is TOS)
                s"  Stack: " buf$ place
                forth-depth 0=
                if   s"  empty " buf$ +place
                else \ display stack depth
                     BASE @ >R DECIMAL
                     s" {" buf$ +place forth-depth (.) buf$ +place s" } " buf$ +place
                     R> BASE !

                     \ display stack entries
                     0  forth-depth 1- display-depth 1- min
                     do  i cells forth-sp + @ (.) buf$ +place
                         s"  " buf$ +place
                     -1 +loop
                then

                \ print Floating point stack from left to right (right is TOS)
                s" | Floating point stack: " buf$ +place
                fdepth 0=
                if   s"  empty" buf$ +place
                else \ display Stack depth
                     BASE @ >R DECIMAL
                     s" {" buf$ +place fdepth (.) buf$ +place s" } " buf$ +place
                     R> BASE !

                     \ display stack entries
                     display-depth fdepth umin dup 1- swap 0
                     DO   dup i - fpick buf1$ (g.) buf1$ count buf$ +place
                          s"  " buf$ +place  \ JvdV, July 26th, 2004 added a seperator
                     LOOP drop
                then
                buf$ 1 SetText: self    \ update status bar

                r> hld !                \ restore HLD
                pad$ pad MAXSTRING move \ restore PAD
                ;M

;Object

\ *****************************************************************************
\  hook's for the interpreter
\ *****************************************************************************

: Update-Console-Statusbar ( -- ) \ update the status bar
                GetHandle: ConsoleStatusbar
                if   depth SetDepth: ConsoleStatusbar
                     sp@      SetSP: ConsoleStatusbar
                     base @ SetBase: ConsoleStatusbar
                     source-id 0=
                     if Update: ConsoleStatusbar then
                then ;

: Console-Statusbar-interpret ( -- ) \ hook for INTERPRET
                _interpret
                Update-Console-Statusbar ;

EXTERNAL

\ changed to use the reset-stack-chain
\ January 22nd, 2004 - 13:53 dbu
: Console-Statusbar-reset-stacks ( ?? -- ) \ hook for RESET-STACKS
                TURNKEYED? NOT
\in-system-ok   if Update-Console-Statusbar then ;

reset-stack-chain chain-add CONSOLE-STATUSBAR-RESET-STACKS

INTERNAL

\ *****************************************************************************
\  hook for the console window proc
\ *****************************************************************************

0 value &Console-Window-Proc \ addr of the org console window proc

4 Callback: Console-Statusbar-WindowProc ( hwnd msg wparam lparam -- res )

                \ redraw our status bar if needed
                2 PICK WM_WINDOWPOSCHANGED = if Redraw: ConsoleStatusbar then

                \ and call the org console window proc
                4reverse &Console-Window-Proc Call CallWindowProc ;

\ *****************************************************************************
\ set number of stack entries that are displayed in the status bar
\ *****************************************************************************

: Console-SetDisplayDepth ( n -- )
                SetDisplayDepth: ConsoleStatusbar ;

\ *****************************************************************************
\  INIT-CONSOLE
\ *****************************************************************************

: M_INIT_CONS   ( -- )
                _conHndl Create: ConsoleStatusbar
                GetHandle: ConsoleStatusbar
                if   \ hook into the interpreter
                     ['] Console-Statusbar-interpret is interpret

                     \ sublassing of the console window
                     ['] Console-Statusbar-WindowProc GWL_WNDPROC _conHndl
                     Call SetWindowLong to &Console-Window-Proc

                     \ and update the status bar
                     Update-Console-Statusbar
                then ;

m_init_cons

: M_INIT-CONSOLE ( -- f )
                \ create console window
                X_INIT-CONSOLE dup 0<>
                if   M_INIT_CONS \ create the status bar
                then ;

' M_INIT-CONSOLE is INIT-CONSOLE

MODULE


--- NEW FILE: BasicWin.f ---
\    File: BasicWin.f
\  Author: Jeff Kelm
\ Created: 17-Nov-1998
\ Updated: August 17th, 2003 dbu
\ Defines some basic window classes

Comment:  Revision History (most recent first)
August 17th, 2003 dbu
 - Changed to use in WinEd 2.21.05 and later
19990519
 - Modify to use 'stack frames' instead of HERE for temp
   storage.  Items marked ( fix) have not yet been properly
   handled.
19990422
 - Removed the changes on 990412, didn't work.  Added more to
   text in PutHandle: for debugging
19990412
 - Add equivalent to InitCommonControls to ChildWindow, Create:
   to try to correct a problem with turnkeying under Win95
   reported by Mar...@t-... (Martin Bitter).
19990315
 - Changed GetClientSize: to give ( x y) stack arguments
   (had incorrectly given (y x) stack).
19990218
 - GetStyleEx: changed to GetExStyle: in +/-ExStyle:
19990128
 - Rename StyleEx to ExStyle in several places.
 - Change logic of -Style/StyleEx: so that it doesn't set a flag
   if it wasn't already set (was XOR, now INVERT AND).
 - Extended styles can be NULL which gives errors in
   Get/SetStyleEx: and +/-StyleEx: from Get/SetWindowLong: which
   test returned results with ?WinError.
19981231
 - Incorporated the new ChildWindow class.
19981216
 - Change stack ordering to ( x y) for Get/SetPosition:
   and Get/SetSize:
 - replaced  GetHandle: self  with  hWnd
19981208
 - Added Get/SetText: methods
19981207
 - Added SetFocus: method
19981204
 - Added -Style: and -StyleEx: methods
19981202
 - Added +Style: and +StyleEx: methods
 - Rename GetWindowSize: to GetSize: for consistency
19981120
 - Changed ?WinError to DROP in Enable: & Disable: methods
19981117
 - separated these from WinBase.f where they had been defined.
 - General cosmetic updates
 - Added some validity checking to PutHandle: and Destroy:
 - Added methods to BaseWindow (SetID: GetStyle: SetStyle:
   GetStyleEx: GetWindowProc: SetWindowProc: Enable: Disable:
   IsVisible:)
 - Removed BaseChildWindow and incorporate functionality into
   BaseWindow.
 - Renamed BaseChildWindow to ChildWindow
           MoveTo: to SetPosition:
           Resize: to SetSize:
           GetWindowPos: to GetPosition:
 - Remove GetClientRect: (GetClientSize: provides same
   functionality)
Comment;



NEEDS WinBase.f
CR  .( Loading Base Window classes...)



\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ \\\ A basic window class with some primative methods
\
:Class Console_BaseWindow  <Super Object

   INT hWnd   \ the window handle

   :M GetHandle: ( -- hWnd)   \ return the window handle
      hWnd
      ;M

   :M PutHandle: ( hWnd)   \ set the window handle
      DUP  Call IsWindow  0= ABORT" Nonexistent window handle"
      TO hWnd
      ;M

   :M SendMessage: ( lparam wparam msg -- result)
      hWnd  Call SendMessage
      ;M

   :M Show: ( -- )   \ show the window
      SW_SHOW  hWnd  Call ShowWindow DROP
      ;M

   :M Hide: ( -- )   \ hide the window
      SW_HIDE  hWnd  Call ShowWindow DROP
      ;M

   :M GetWindowLong: ( offset -- n)   \ get window memory
                                      \ contents at offset
      hWnd  Call GetWindowLong
      ( GetWindowLong could return NULL, so don't ?WinError)
      ;M

   :M SetWindowLong: ( n offset)   \ set window memory contents
                                   \ at offset
      hWnd  Call SetWindowLong  DROP
      ( SetWindowLong could return NULL, so don't ?WinError)
      ;M

   :M GetWindowRect: ( -- b r t l)   \ get window bounding rect
\ was      HERE hWnd  Call GetWindowRect  ?WinError
\ was      HERE 3 CELLS + @  HERE 2 CELLS + @  HERE CELL+ @  HERE @
      4 sFrame  \ save space on stack for RECT
      hWnd Call GetWindowRect ?WinError  ( b r t l)
      ;M

   :M GetClientSize: ( -- cx cy)   \ returns size of client area
\ was      HERE hWnd  Call GetClientRect ?WinError
\ was      HERE 2 CELLS + @  HERE @ -
\ was      HERE 3 CELLS + @  HERE CELL+ @ -
      4 sFrame   \ save space on stack for RECT
      hWnd Call GetClientRect ?WinError  ( b r t l)
      SWAP >R  -  SWAP R> -
      ;M

   :M GetSize: ( -- cx cy)   \ returns size of window rectangle
\ was      HERE hWnd  Call GetWindowRect ?WinError
\ was      HERE 2 CELLS + @  HERE @ -
\ was      HERE 3 CELLS + @  HERE CELL+ @ -
      GetWindowRect: self  ( b r t l)
      SWAP >R  -  SWAP R> -
      ;M

   :M SetSize: ( cx cy)   \ set size of window rectangle
\ was      SWAP 2>R  SWP_NOOWNERZORDER SWP_NOMOVE OR
( is)      SWAP 2>R  [ SWP_NOZORDER SWP_NOMOVE OR ] literal
      2R> 0 0 NULL  hWnd Call SetWindowPos ?WinError
      ;M

   :M GetPosition: ( -- x y)   \ return upper-left corner
\ was      HERE hWnd  Call GetWindowRect ?WinError
\ was      HERE 2@ SWAP
      GetWindowRect: self  2NIP  SWAP
      ;M

   :M SetPosition: ( x y)  \ set position of upper-left corner
\ was      SWAP 2>R  SWP_NOOWNERZORDER SWP_NOSIZE OR
( is)      SWAP 2>R  [ SWP_NOZORDER SWP_NOSIZE OR ] literal
      0 0 2R> NULL  hWnd Call SetWindowPos ?WinError
      ;M

   :M Destroy: ( -- )   \ destroy the window
      hWnd Call DestroyWindow  DUP
      IF  0 TO hWnd  THEN  ?WinError
      ;M

   :M GetID: ( -- id)   \ retrieve window identifier
      GWL_ID GetWindowLong: self
      ;M

   :M SetID: ( id)   \ set the window identifier
      GWL_ID SetWindowLong: self
      ;M

   :M GetStyle: ( -- style)   \ retrieve basic window style
      GWL_STYLE GetWindowLong: self
      ;M

   :M SetStyle: ( style)   \ set the basic window style
      GWL_STYLE SetWindowLong: self
      ;M

   :M +Style: ( style)   \ add to the basic window style
      GetStyle: self OR  SetStyle: self
      ;M

   :M -Style: ( style)   \ remove from the basic window style
      INVERT  GetStyle: self AND  SetStyle: self
      ;M

   :M GetExStyle: ( -- exStyle)   \ retrieve extended styles
      GWL_EXSTYLE GetWindowLong: self
      ;M

   :M SetExStyle: ( exStyle)   \ set the extended window style
      GWL_EXSTYLE SetWindowLong: self
      ;M

   :M +ExStyle: ( exStyle)   \ add to the extended window style
      GetExStyle: self OR  SetExStyle: self
      ;M

   :M -ExStyle: ( exStyle)   \ add to the extended window style
      INVERT  GetExStyle: self AND  SetExStyle: self
      ;M

   :M GetParent: ( -- hParent)   \ handle of parent window
      hWnd Call GetParent
      ;M

   :M SetParent: ( hWnd)   \ change the parent window
      hWnd Call SetParent  ?WinError
      ;M

   :M Enable: ( -- )   \ enables mouse and keyboard input to
                       \ the window or control
      TRUE hWnd Call EnableWindow  DROP
      ;M

   :M Disable: ( -- )   \ disables mouse and keyboard input to
                        \ the window or control
      FALSE hWnd Call EnableWindow  DROP
      ;M

   :M SetFocus: ( -- )   \ set keyboard focus to this window
      hWnd Call SetFocus  DROP
      ;M

   :M IsVisible: ( -- f)   \ ff=window not visible
      hWnd Call IsWindowVisible
      ;M

   :M SetText: ( szText)   \ send text to window/control
      hWnd Call SetWindowText  ?WinError
      ;M

   :M GetText: ( -- a n)   \ get window/control text
( fix)      MAXSTRING HERE hWnd Call GetWindowText  DUP ?WinError
      HERE SWAP
      ;M

;Class



:Class Console_ChildWindow  <Super Console_BaseWindow

   :M DefStyle: ( -- style)   \ default control style
      [ WS_VISIBLE WS_CHILD OR ] literal
      ;M

   :M DefExStyle: ( -- exStyle)   \ default extended style
      NULL
      ;M

   :M DefClassName: ( -- ClassName)   \ default class name
      Z" STATIC"
      ;M

   :M DefSize: ( -- cx cy)   \ default window size
      CW_USEDEFAULT CW_USEDEFAULT
      ;M

   :M DefPosition: ( -- x y)   \ default window position
      CW_USEDEFAULT CW_USEDEFAULT
      ;M

   :M Create: ( hParent -- )   \ create a child of parent window
      >R
      NULL                              \ creation parameters
      AppInst                           \ instance handle
      CreateNewID                       \ menu handle/control ID
      R>                                \ parent window
      DefSize: [ self ]  SWAP           \ window size ( h w)
      DefPosition: [ self ]  SWAP       \ window pos ( y x )
      DefStyle: [ self ]                \ window style
      NULL                              \ window title
      DefClassName: [ self ]            \ class name
      DefExStyle: [ self ]              \ extended window style
      Call CreateWindowEx  DUP TO hWnd  ?WinError
      ;M

;Class

[Win32forth-cvs] win32forth-stc/src/kernel gkernel.f,1.36,1.37

[George H. <geo...@us...>]

Update of /cvsroot/win32forth/win32forth-stc/src/kernel
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv10697/win32forth-stc/src/kernel

Modified Files:
	gkernel.f 
Log Message:
gah:Made INTERPRET a deferred word for the console status bar

Index: gkernel.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/kernel/gkernel.f,v
retrieving revision 1.36
retrieving revision 1.37
diff -C2 -d -r1.36 -r1.37
*** gkernel.f	24 Apr 2007 08:55:47 -0000	1.36
--- gkernel.f	8 May 2007 08:02:27 -0000	1.37
***************
*** 4601,4609 ****
                  ['] (interpret-i) is (interpret) ; immediate \ turn off compiling
  
! : interpret     ( -- )
                  begin bl word dup c@ while
                    (interpret)
                  repeat drop ;
  
  \ -------------------- Colon Compiler ---------------------------------------
  
--- 4601,4611 ----
                  ['] (interpret-i) is (interpret) ; immediate \ turn off compiling
  
! : _interpret     ( -- )
                  begin bl word dup c@ while
                    (interpret)
                  repeat drop ;
  
+ defer interpret ' _interpret is interpret
+ 
  \ -------------------- Colon Compiler ---------------------------------------
  
***************
*** 5420,5435 ****
              _localn (copy-code) code-here 1- code-c! ;
  
! : local0    -4  localn ; immediate
! : local1    -8  localn ; immediate
! : local2    -12 localn ; immediate
! : local3    -16 localn ; immediate
! : local4    -20 localn ; immediate
! : local5    -24 localn ; immediate
! : local6    -28 localn ; immediate
! : local7    -32 localn ; immediate
! : local8    -36 localn ; immediate
! : local9    -40 localn ; immediate
! : local10   -44 localn ; immediate
! : local11   -48 localn ; immediate
  
  create local-ptrs ' local0 , ' local1 , ' local2 ,
--- 5422,5437 ----
              _localn (copy-code) code-here 1- code-c! ;
  
! : local0    -4  localn ; immediate tloc tfa!
! : local1    -8  localn ; immediate tloc tfa!
! : local2    -12 localn ; immediate tloc tfa!
! : local3    -16 localn ; immediate tloc tfa!
! : local4    -20 localn ; immediate tloc tfa!
! : local5    -24 localn ; immediate tloc tfa!
! : local6    -28 localn ; immediate tloc tfa!
! : local7    -32 localn ; immediate tloc tfa!
! : local8    -36 localn ; immediate tloc tfa!
! : local9    -40 localn ; immediate tloc tfa!
! : local10   -44 localn ; immediate tloc tfa!
! : local11   -48 localn ; immediate tloc tfa!
  
  create local-ptrs ' local0 , ' local1 , ' local2 ,

[Win32forth-cvs] win32forth-stc w32fScintilla.dll,NONE,1.1

[George H. <geo...@us...>]

Update of /cvsroot/win32forth/win32forth-stc
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv9105/win32forth-stc

Added Files:
	w32fScintilla.dll 
Log Message:
gah:Added scintilla dll

--- NEW FILE: w32fScintilla.dll ---
(This appears to be a binary file; contents omitted.)

[Win32forth-cvs] win32forth-stc/demos TreeViewDemo.f, NONE, 1.1 toolbardemo.f, NONE, 1.1 ControlDemo.f, 1.1, 1.2

[George H. <geo...@us...>]

Update of /cvsroot/win32forth/win32forth-stc/demos
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv7174/win32forth-stc/demos

Modified Files:
	ControlDemo.f 
Added Files:
	TreeViewDemo.f toolbardemo.f 
Log Message:
gah:Added more demos and made ControlDemo start on loading

--- NEW FILE: toolbardemo.f ---
\ $Id: toolbardemo.f,v 1.1 2007/05/08 07:53:50 georgeahubert Exp $

\ Demo from toolbar moved to it's own file

\ Define tool strings (short texts that are placed under button bitmap as a part
\                      of the button)

Require toolbar.f
Require menu.f

:ToolStrings TestButtonStrings
                ts," Cut"         ts," Copy"        ts," Paste"
                ts," Properties"  ts," Print"       ts," New"
                ts," Open"        ts," Save"        ts," Undo"
                ts," Redo"        ts," Delete"      ts," Print preview"
                ts," Find"        ts," Replace"     ts," Help"
;ToolStrings


\ Define tool tips (texts that gives a short description of the buttons function)

:ToolStrings TestToolTips
                ts," Cut Text"    ts," Copy Text"   ts," Paste Text"
                ts," Properties"  ts," Print File"  ts," New File"
                ts," Open File"   ts," Save File"   ts," Undo"
                ts," Redo"        ts," Delete"      ts," Print preview"
                ts," Find"        ts," Replace"     ts," Help"
;ToolStrings


\ Define all toolbar buttons in this application.  Some will show up by default...

:ToolBarTable TestButtonTable
\  Bitmap index    id    Initial state    Initial style       tool string index
   STD_CUT         1001  TBSTATE_ENABLED  TBSTYLE_CHECKGROUP  0 ToolBarButton,
   STD_COPY        1002  TBSTATE_CHECKED  TBSTATE_ENABLED or
                                          TBSTYLE_CHECKGROUP  1 ToolBarButton,
                                                                SeparatorButton,
   STD_PASTE       1003  TBSTATE_ENABLED  TBSTYLE_BUTTON      2 ToolBarButton,
                                                                SeparatorButton,
   STD_PROPERTIES  1004  TBSTATE_ENABLED  TBSTYLE_BUTTON      3 ToolBarButton,
   STD_PRINT       1005  TBSTATE_ENABLED  TBSTYLE_BUTTON      4 ToolBarButton,


   ToolBarTableExtraButtons:

\  The following buttons will initialy not be in the tool-bar, but you can
\  put them there by customizing it (double click on gray part of the toolbar).

   STD_FILENEW     1006  TBSTATE_ENABLED  TBSTYLE_BUTTON      5 ToolBarButton,
   STD_FILEOPEN    1007  TBSTATE_ENABLED  TBSTYLE_BUTTON      6 ToolBarButton,
   STD_FILESAVE    1008  TBSTATE_ENABLED  TBSTYLE_BUTTON      7 ToolBarButton,
   STD_UNDO        1009  TBSTATE_ENABLED  TBSTYLE_BUTTON      8 ToolBarButton,
   STD_REDOW       1010  TBSTATE_ENABLED  TBSTYLE_BUTTON      9 ToolBarButton,
   STD_DELETE      1011  TBSTATE_ENABLED  TBSTYLE_BUTTON     10 ToolBarButton,
   STD_PRINTPRE    1012  TBSTATE_ENABLED  TBSTYLE_BUTTON     11 ToolBarButton,
   STD_FIND        1013  TBSTATE_ENABLED  TBSTYLE_BUTTON     12 ToolBarButton,
   STD_REPLACE     1014  TBSTATE_ENABLED  TBSTYLE_BUTTON     13 ToolBarButton,
   STD_HELP        1015  TBSTATE_ENABLED  TBSTYLE_BUTTON     14 ToolBarButton,
;ToolBarTable



\ Define toolbar for our test application...

:Object TestToolBar      <super Win32ToolBar

:M Start:       ( parent -- )
                \ Set-up registry key for customization data...
                z" Software\Win32Forth\Test"            \ Registry sub-key
                z" TestToolBarLayout"                   \ value key name
                SetRegistryKey: self

\                TestButtonStrings IsButtonStrings: self
                TestButtonTable   IsButtonTable: self
                TestToolTips      IsToolTips: self

                Start: super

                HINST_COMMCTRL  IDB_STD_SMALL_COLOR  15 AddBitmaps: self drop
\               HINST_COMMCTRL  IDB_STD_LARGE_COLOR  15 AddBitmaps: self drop

                ;M

:M WindowStyle: ( -- style )
                WindowStyle: super
                CCS_ADJUSTABLE or
                TBSTYLE_TOOLTIPS or
\               TBSTYLE_WRAPABLE or
                ;M

:M On_QueryDelete: ( buttonindex -- f )
                3 <>                            \ You may not delete Paste-button
                ;M

:M On_QueryInsert: ( buttonindex -- f )
                5 <>                            \ No insert to the immediate left
                ;M                              \ of the Properties-button


:M On_CustHelp: ( -- f )                        \ Request for customization help
    z" CustHelp"  z" On_Command:" MB_OK MessageBox: self drop
                true
                ;M

;Object


\ Define our main window

:Object MainWindow  <super Window

                int ToolBar


:M ClassInit:   ( -- )
                ClassInit: super

                NULL to ToolBar
                ;M

:M On_Init:     ( -- )
                On_Init: super

                TestToolBar  to ToolBar

                \ Create ToolBar
                999 SetId: ToolBar
                self Start: ToolBar
                ;M

:M WindowTitle: ( -- z" )
                z" ToolBar test"
                ;M

:M WindowHasMenu: ( -- f )
                true
                ;M

:M WM_NOTIFY    ( h m w l -- f )
                Handle_Notify: Toolbar
                ;M

:M On_Command:  ( hCtrl code id -- f )
                GetText: ToolBar  z" On_Command:" MB_OK MessageBox: self drop
                true
                ;M

:M WM_COMMAND   ( hwnd msg wparam lparam -- res )
                ?dup 0=
                if      LOWORD
                        CurrentMenu
                        if      dup DoMenu: CurrentMenu
                        then
                        CurrentPopup
                        if      dup DoMenu: CurrentPopup
                        then    drop
                else    over HIWORD ( notification code ) rot LOWORD ( ID )
                        On_Command: [ self ]
                then
                0 ;M

:M WM_SIZE      ( -- )
                WM_SIZE WM: super
                AutoSize: ToolBar
                ;M

;Object

: Demo ( -- ) start: MainWindow ;



Index: ControlDemo.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/demos/ControlDemo.f,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** ControlDemo.f	3 May 2007 08:49:21 -0000	1.1
--- ControlDemo.f	8 May 2007 07:53:50 -0000	1.2
***************
*** 105,106 ****
--- 105,108 ----
                  Start: EditSample ;
  
+ demo
+ 

--- NEW FILE: TreeViewDemo.f ---
\ $Id: TreeViewDemo.f,v 1.1 2007/05/08 07:53:50 georgeahubert Exp $

Require TreeView.f

:Class NewTVC <super TreeViewControl

        Font WinFont


:M WindowStyle: ( -- style )
                WindowStyle: super
                TVS_HASLINES        or
                TVS_HASBUTTONS      or
                TVS_DISABLEDRAGDROP or
                TVS_SHOWSELALWAYS   or
                TVS_LINESATROOT     or
                ;M

int hRoot
int hSon
int hPrev

: AddItem       ( sztext hAfter hParent nChildren -- )
                tvins  /tvins  erase
                tvitem /tvitem erase
                ( nChildren)      to cChildren
                ( hParent)        to hParent
                ( hAfter)         to hInsertAfter
                                  to pszText
                TVIF_TEXT TVIF_CHILDREN or
                to mask
                tvitem->tvins
                tvins 0 TVM_INSERTITEMA hWnd Call SendMessage
                to hPrev
                ;


: FillTreeView  ( -- )
                z" Root Item"        TVI_LAST  TVI_ROOT  1  AddItem
                hPrev to hRoot
                z" First son"        hPrev     hRoot     1  AddItem
                hPrev to hSon
                z" First Grandson"   hPrev     hSon      0  AddItem
                z" Second Grandson"  hPrev     hSon      0  AddItem
                z" Second son"       hPrev     hRoot     0  AddItem
                z" Third son"        hPrev     hRoot     1  AddItem
                hPrev to hSon
                z" Third Grandson"   hPrev     hSon      0  AddItem
                ;

:M Start:       ( Parent -- )
                Start: super

                8 Width: WinFont
                16 Height: WinFont
                s" Courier New" SetFaceName: WinFont
                Create: WinFont
                true Handle: WinFont WM_SETFONT hWnd CALL SendMessage drop \ activate a new font

                \ Insert items...
                FillTreeView
                ;M


:M On_SelChanged: { \ text$ -- f }      \ Show text of selected item in message box
                maxstring LocalAlloc: text$

                TVIF_TEXT        to mask
                hItemNew         to hItem
                text$            to pszText
                maxstring        to cchTextMax
                tvitem 0 TVM_GETITEMA  hWnd Call SendMessage drop

                text$ z" TreeView selection"
                MB_OK MessageBox: Parent drop

                false
                ;M

;Class


:Object MainWindow  <super Window

        int TreeView

:M On_Init:     ( -- )
                On_Init: super

                New> NewTVC to TreeView
                1001 SetId: TreeView
                self Start: TreeView
                ;M

:M WindowTitle: ( -- sztitle )
                z" TreeView Test"
                ;M

:M StartSize:   ( -- w h )
                100 100
                ;M

:M On_Size:     ( -- )
                AutoSize: TreeView
                ;M

:M WM_NOTIFY    ( h m w l -- f )
                dup @  GetHandle: TreeView  =
                if      Handle_Notify: TreeView
                else    false
                then
                ;M

;Object

Start: MainWindow

[Win32forth-cvs] win32forth-stc/Templates SplitterWindow2.f, NONE, 1.1

[Jos v.d.V. <jo...@us...>]

Update of /cvsroot/win32forth/win32forth-stc/Templates
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv3847

Added Files:
	SplitterWindow2.f 
Log Message:
Jos: Added the splitterwindow.

--- NEW FILE: SplitterWindow2.f ---
anew -SplitterWindow2.f

\ Needs NoConsole.f
Needs Resources.f
Needs Window.f
Needs Childwnd.f
Needs Control.f
Needs Menu.f

false value turnkey?

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

\ ------------------------------------------------------------------------
\ Define the left part of the splitter window.
\ ------------------------------------------------------------------------
\ Note: 2 panes do not always do the same thing.

:Object LeftPane        <Super Child-Window

:M On_Init:       ( -- )        On_Init: super  ;M
:M WndClassStyle: ( -- style )  CS_DBLCLKS      ;M
:M Start:         ( Parent -- ) start: super    ;M
:M ExWindowStyle: ( -- style )  ExWindowStyle: Super WS_EX_CLIENTEDGE or ;M
:M On_Paint:      ( -- )        0 0 Width Height WHITE FillArea: dc      ;M

;Object


\ ------------------------------------------------------------------------
\ Define the right part of the splitter window.
\ ------------------------------------------------------------------------

:Object RightPane       <Super Child-Window

:M On_Init:       ( -- )        On_Init: super  ;M
:M WndClassStyle: ( -- style )  CS_DBLCLKS      ;M
:M Start:         ( Parent -- ) start: super    ;M
:M ExWindowStyle: ( -- style )  ExWindowStyle: Super WS_EX_CLIENTEDGE or ;M
:M On_Paint:      ( -- )        0 0 Width Height WHITE FillArea: dc      ;M

;Object


\ ------------------------------------------------------------------------
\ Define the line between the 2 panes.
\ ------------------------------------------------------------------------

:Object Splitter        <Super child-window

:M WindowStyle: ( -- style )
        WindowStyle: super
        [ WS_DISABLED WS_CLIPSIBLINGS or ] literal or
        ;M

:M WndClassStyle: ( -- style )  CS_DBLCLKS                              ;M
:M On_Paint:      ( -- )        0 0 Width Height LTGRAY FillArea: dc    ;M

;Object

variable LeftWidth  200 LeftWidth !
2 value thickness


\ ------------------------------------------------------------------------
\ Define the window that contains the 2 panes.
\ ------------------------------------------------------------------------

:Object SplitterWindow        <Super Window

0 value ToolBarHeight    \ set to height of toolbar if any
0 value StatusBarHeight  \ set to height of status bar if any

int dragging?
int mousedown?

: LeftHeight    ( -- n )        Height StatusBarHeight - ToolBarHeight - ;
: RightHeight   ( -- n )        Height StatusBarHeight - ToolBarHeight - ;

: position-windows ( -- )
        0  ToolBarHeight  LeftWidth @  LeftHeight  Move: LeftPane
        LeftWidth @ thickness +  ToolBarHeight  Width LeftWidth @ thickness + -  RightHeight  Move: RightPane
        LeftWidth @  ToolBarHeight  thickness  LeftHeight  Move: Splitter
        self OnPosition ;

: InSplitter?   ( -- f1 )   \ is cursor on splitter window
        hWnd get-mouse-xy
        0 height within
        swap  LeftWidth @ dup thickness + within  and ;

\ mouse click routines for Main Window to track the Splitter movement

: DoSizing      ( -- )
        mousedown? dragging? or 0= ?EXIT
        mousex ( 1+ ) width min  thickness 2/ -
        [ thickness 2* ] literal max width  [ thickness 2* ] literal - min
        LeftWidth !
        position-windows
        WINPAUSE ;

: On_clicked    ( -- )
        mousedown? 0= IF  hWnd Call SetCapture drop  THEN
        true to mousedown?
        InSplitter? to dragging?
        DoSizing ;

: On_unclicked ( -- )
        mousedown? IF  Call ReleaseCapture drop  THEN
        false to mousedown?
        false to dragging? ;

: On_DblClick ( -- )
        false to mousedown?
        InSplitter? 0= ?EXIT
        LeftWidth @ 8 >
        IF      0 thickness 2/ -  LeftWidth !
        ELSE    132 Width 2/ min  LeftWidth !
        THEN
        position-windows
        ;

:M WM_SETCURSOR ( h m w l -- )
        hWnd get-mouse-xy
        ToolBarHeight dup LeftHeight + within
        swap  0 width within and
        IF  InSplitter?
                IF  SIZEWE-CURSOR
                ELSE  arrow-cursor
                THEN  1
        ELSE  DefWindowProc: self
        THEN
        ;M

:M On_Init:     ( -- )
        self Start: LeftPane
        self Start: RightPane
        self Start: Splitter
        self OnInit    \ perform user function
        ;M

:M Classinit:   ( -- )
        ClassInit: super   \ init super class
        ['] On_clicked     SetClickFunc: self
        ['] On_unclicked   SetUnClickFunc: self
        ['] DoSizing       SetTrackFunc: self
        ['] On_DblClick    SetDblClickFunc: self
        ;M

:M WindowStyle:   ( -- style )  WindowStyle: Super   WS_CLIPCHILDREN or ;M
:M WindowHasMenu: ( -- f )      true                                    ;M
:M WndClassStyle: ( -- style )  CS_DBLCLKS                              ;M
:M StartSize:     ( -- w h )    screen-size >r 2/ r> 2/                 ;M
:M StartPos:      ( -- x y )    CenterWindow: Self                      ;M
:M On_Size:       ( -- )        position-windows                        ;M
:M ParentWindow:  ( -- hwndParent | 0=NoParent )   parent               ;M
:M SetParent:     ( hwndparent -- )             to parent               ;M

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

;Object

MENUBAR ApplicationBar
    POPUP "File"
        MENUITEM        "Exit"          Close: SplitterWindow    ;
ENDBAR

: main  ( -- )
        Start: SplitterWindow
        ApplicationBar SetMenuBar: SplitterWindow
        \ turnkey? if MessageLoop bye then
        ;
main
\s

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

[Win32forth-cvs] win32forth-stc/Templates TreeViewInSplitWindow.f, NONE, 1.1

[Jos v.d.V. <jo...@us...>]

Update of /cvsroot/win32forth/win32forth-stc/Templates
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv3356

Added Files:
	TreeViewInSplitWindow.f 
Log Message:
Jos: The window and treeview are OK. The used popupwindow (click-right on and item) is not yet right. When compiled with the ITC-version it is OK.

--- NEW FILE: TreeViewInSplitWindow.f ---
anew -TreeViewInSplitWindow.f

\ Needs NoConsole.f
Needs Resources.f
Needs Window.f
Needs Childwnd.f
Needs Control.f
Needs Menu.f
Needs PopupWindow.f
Needs Treeview.f

false value turnkey?

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


:Class NewTVC <super TreeViewControl

        Font WinFont

:M WindowStyle: ( -- style )
                WindowStyle: super
                TVS_HASLINES        or
                TVS_HASBUTTONS      or
                TVS_DISABLEDRAGDROP or
                TVS_SHOWSELALWAYS   or
                TVS_LINESATROOT     or
                ;M

int hRoot
int hSon
int hPrev

: AddItem       ( sztext hAfter hParent nChildren -- )
                tvins  /tvins  erase
                tvitem /tvitem erase
                ( nChildren)      to cChildren
                ( hParent)        to hParent
                ( hAfter)         to hInsertAfter
                                  to pszText
                TVIF_TEXT TVIF_CHILDREN or
                to mask
                tvitem->tvins
                tvins 0 TVM_INSERTITEMA hWnd Call SendMessage
                to hPrev
                ;


: FillTreeView  ( -- )  \ Application depended
                z" Root Item"        TVI_LAST  TVI_ROOT  1  AddItem
                hPrev to hRoot
                z" First son"        hPrev     hRoot     1  AddItem
                hPrev to hSon
                z" First Grandson"   hPrev     hSon      0  AddItem
                z" Second Grandson"  hPrev     hSon      0  AddItem
                z" Second son"       hPrev     hRoot     0  AddItem
                z" Third son"        hPrev     hRoot     1  AddItem
                hPrev to hSon
                z" Third Grandson"   hPrev     hSon      0  AddItem
                ;

:M Start:       ( Parent -- )
                dup to parent
                Start: super

                8 Width: WinFont
                16 Height: WinFont
                s" Courier New" SetFaceName: WinFont
                Create: WinFont
                true Handle: WinFont WM_SETFONT hWnd CALL SendMessage drop \ activate a new font

                \ Insert items...
                FillTreeView
                ;M

: StartPopupWindow ( -- )
           hWnd get-mouse-xy
           GetWindowRect: Self 2drop
           rot + >r + r>  Hwnd Start: PopupWindow
          ;

:M On_SelChanged: { \ text$ -- f }      \ Show text of selected item in message box
                maxstring LocalAlloc: text$

                TVIF_TEXT        to mask
                hItemNew         to hItem
                text$            to pszText
                maxstring        to cchTextMax
                tvitem 0 TVM_GETITEMA  hWnd Call SendMessage drop

                \ text$ z" TreeView selection" MB_OK MessageBox: Parent drop
               StartPopupWindow
                false
                ;M

:M On_RightClick: ( -- )
                 On_SelChanged: Self
                ;M

;Class

\ ------------------------------------------------------------------------
\ Define the left part of the splitter window.
\ ------------------------------------------------------------------------

:Object LeftPane        <Super Child-Window

        int TreeView
        int EnableNotify?

:M On_Init:     ( -- )
        On_Init: super
        New> NewTVC to TreeView
        1001 SetId: TreeView
        self Start: TreeView
        true to EnableNotify?
        true to EnableNotify?

                ;M

:M WndClassStyle: ( -- style )  CS_DBLCLKS      ;M
:M Start:         ( Parent -- ) start: super    ;M
:M ExWindowStyle: ( -- style )  ExWindowStyle: Super WS_EX_CLIENTEDGE or ;M
:M On_Paint:      ( -- )        0 0 Width Height WHITE FillArea: dc      ;M

:M On_Size:       ( -- )        AutoSize: TreeView                       ;M

:M RefreshTreeview:  ( -- )
        wait-cursor
        EnableNotify? false to EnableNotify?
        SW_HIDE Show: TreeView    \ hide,
        FillTreeView: TreeView    \ fill,
        SW_RESTORE Show: TreeView \ and show it.
        to EnableNotify?
        arrow-cursor
        ;M

:M WM_NOTIFY    ( h m w l -- f )
        dup @  GetHandle: TreeView  =
                if      Handle_Notify: TreeView
                else    false
                then
                ;M

;Object


\ ------------------------------------------------------------------------
\ Define the right part of the splitter window.
\ ------------------------------------------------------------------------

:Object RightPane       <Super Child-Window

:M On_Init:       ( -- )        On_Init: super  ;M
:M WndClassStyle: ( -- style )  CS_DBLCLKS      ;M
:M Start:         ( Parent -- ) start: super    ;M
:M ExWindowStyle: ( -- style )  ExWindowStyle: Super WS_EX_CLIENTEDGE or ;M
:M On_Paint:      ( -- )        0 0 Width Height WHITE FillArea: dc      ;M

;Object


\ ------------------------------------------------------------------------
\ Define the line between the 2 panes.
\ ------------------------------------------------------------------------

:Object Splitter        <Super child-window


:M WindowStyle: ( -- style )
        WindowStyle: super
        [ WS_DISABLED WS_CLIPSIBLINGS or ] literal or
        ;M

:M WndClassStyle: ( -- style )  CS_DBLCLKS                              ;M
:M On_Paint:      ( -- )        0 0 Width Height LTGRAY FillArea: dc    ;M

;Object

variable LeftWidth  200 LeftWidth !
2 value thickness


\ ------------------------------------------------------------------------
\ Define the window that contains the 2 panes.
\ ------------------------------------------------------------------------

:Object SplitterWindow        <Super Window

0 value ToolBarHeight    \ set to height of toolbar if any
0 value StatusBarHeight  \ set to height of status bar if any

int dragging?
int mousedown?

: LeftHeight    ( -- n )        Height StatusBarHeight - ToolBarHeight - ;
: RightHeight   ( -- n )        Height StatusBarHeight - ToolBarHeight - ;

: position-windows ( -- )
        0  ToolBarHeight  LeftWidth @  LeftHeight  Move: LeftPane
        LeftWidth @ thickness +  ToolBarHeight  Width LeftWidth @ thickness + -  RightHeight  Move: RightPane
        LeftWidth @  ToolBarHeight  thickness  LeftHeight  Move: Splitter
        self OnPosition ;

: InSplitter?   ( -- f1 )   \ is cursor on splitter window
        hWnd get-mouse-xy
        0 height within
        swap  LeftWidth @ dup thickness + within  and ;

\ mouse click routines for Main Window to track the Splitter movement

: DoSizing      ( -- )
        mousedown? dragging? or 0= ?EXIT
        mousex ( 1+ ) width min  thickness 2/ -
        [ thickness 2* ] literal max width  [ thickness 2* ] literal - min
        LeftWidth !
        position-windows
        WINPAUSE ;

: On_clicked    ( -- )
        mousedown? 0= IF  hWnd Call SetCapture drop  THEN
        true to mousedown?
        InSplitter? to dragging?
        DoSizing ;

: On_unclicked ( -- )
        mousedown? IF  Call ReleaseCapture drop  THEN
        false to mousedown?
        false to dragging? ;

: On_DblClick ( -- )
        false to mousedown?
        InSplitter? 0= ?EXIT
        LeftWidth @ 8 >
        IF      0 thickness 2/ -  LeftWidth !
        ELSE    132 Width 2/ min  LeftWidth !
        THEN
        position-windows
        ;

:M WM_SETCURSOR ( h m w l -- )
        hWnd get-mouse-xy
        ToolBarHeight dup LeftHeight + within
        swap  0 width within and
        IF  InSplitter?
                IF  SIZEWE-CURSOR
                ELSE  arrow-cursor
                THEN  1
        ELSE  DefWindowProc: self
        THEN
        ;M

:M On_Init:     ( -- )
        self Start: LeftPane
        self Start: RightPane
        self Start: Splitter
        self OnInit    \ perform user function
        ;M

:M Classinit:   ( -- )
        ClassInit: super   \ init super class
        ['] On_clicked     SetClickFunc: self
        ['] On_unclicked   SetUnClickFunc: self
        ['] DoSizing       SetTrackFunc: self
        ['] On_DblClick    SetDblClickFunc: self
        ;M

:M WindowStyle:   ( -- style )  WindowStyle: Super   WS_CLIPCHILDREN or ;M
:M WindowHasMenu: ( -- f )      true                                    ;M
:M WindowTitle:   ( -- ztitle ) z" Treeview template"                   ;M
:M WndClassStyle: ( -- style )  CS_DBLCLKS                              ;M
:M StartSize:     ( -- w h )    screen-size >r 2/ r> 2/                 ;M
:M StartPos:      ( -- x y )    CenterWindow: Self                      ;M
:M On_Size:       ( -- )        position-windows                        ;M
:M ParentWindow:  ( -- hwndParent | 0=NoParent )   parent               ;M
:M SetParent:     ( hwndparent -- )             to parent               ;M

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

;Object

MENUBAR ApplicationBar
    POPUP "File"
        MENUITEM        "Exit"          Close: SplitterWindow    ;
ENDBAR

: main  ( -- )
        Start: SplitterWindow
        ApplicationBar SetMenuBar: SplitterWindow
        \ turnkey? if MessageLoop bye then
        ;
main
\s

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

[Win32forth-cvs] win32forth-stc/src/lib treeview.f,NONE,1.1

[Jos v.d.V. <jo...@us...>]

Update of /cvsroot/win32forth/win32forth-stc/src/lib
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv1060

Added Files:
	treeview.f 
Log Message:
Jos: The demo part was also tested en looks OK.

--- NEW FILE: treeview.f ---
\ $Id: treeview.f,v 1.1 2007/05/06 14:09:32 jos_ven Exp $

\ TreeView.f    Thursday, June 15 2006  Rod
\               Changed to use Control rather than Child-Window
\               On creation needs a sensible StartSize: ( default set to size of parent )
\               Class control does not have the definition "null-check" which is in
\               class Window and hence Child-Window. 

(( TreeView.F   A rudimentary TreeView class              by Michael Hillerström
                                                     mic...@us...


                This TreeView class hooks into Windows own library class.
                But be warned; this is a very 'stripped to the bone implementation'
                i.e. it has just what I need for DiaEdit...  Some day (soon) I
                will try to correct this.

                Please note that this code needs a new version of WINCON.DLL
                (dated September 15, 1997 or later).

                An example is included last in this file...


                Any comments/suggestions to:    mic...@us...



        Change log:
                November 23rd, 1997 - 21:59 MIH
                Added the line:   WinLibrary COMCTL32.DLL   to this source.

                September 16th, 1997 - 21:42 MIH
                Removed reference to COMMCTRL.F as Tom Zimmer has released an
                extended WINCON.DLL.  Thanks, Tom!

                August 31st, 1997 - 23:15 MIH
                First attempt...(which is VERY bare bones...)
                Need to convince Tom Zimmer to include #define's from COMMCTRL.H
                in WINCON.DLL.  For the time beeing, we'll have to cope with my
                FORTH constants in COMMCTRL.F.

))

cr .( Loading TreeView Class...)


\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\       Prerequisites...
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

WinLibrary COMCTL32.DLL         \ Make sure that ComCtl32.dll is loaded...


\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\       TreeView Constants and their significance...
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

comment:

A treeview can have a combination of the following styles:


TVS_DISABLEDRAGDROP  disables drag n' drop of tree-view items.

TVS_LINESATROOT      draws lines linking child items to the root of the hierarchy.

TVS_HASLINES         enhances the graphic representation of a tree-view by
                     drawing lines that link child items to their parent item.
                     To link items at the root of the hierarchy, you need to
                     combine this and the TVS_LINESATROOT style.

TVS_HASBUTTONS       adds a button to the left side of each parent item. The
                     user can click the button to expand or collapse the child
                     items as an alternative to double-clicking the parent
                     item. To add buttons to items at the root of the
                     hierarchy, this style must be combined with TVS_HASLINES,
                     and TVS_LINESATROOT.

TVS_EDITLABELS       makes it possible for the user to edit the labels of
                     tree-view items.

TVS_SHOWSELALWAYS    causes a selected item to remain selected when the
                     tree-view control loses focus.


comment;

Needs Window.f
Needs Control.f

\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\       TreeView Class...
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

:Class TreeViewControl <super control

     Record:    nmhdr
        int     hWndFrom
        int     idFrom
        int     code
    ;RecordSize: /nmhdr

     Record:    tvitem
        int     mask
        int     hItem
        int     state
        int     stateMask
        int     pszText
        int     cchTextMax
        int     iImage
        int     iSelectedImage
        int     cChildren
        int     lParam
    ;RecordSize: /tvitem

     Record:    tvins
        int     hParent
        int     hInsertAfter
\   TV_ITEM     item
/tvitem bytes   item
    ;RecordSize: /tvins

\    Record:    tvdi
\     NMHDR     hdr
\   TV_ITEM     item
\   ;Record


     Record:    tvkd
\     NMHDR     hdr
        int     wVKey
        int     flags
    ;RecordSize: /tvkd


     Record:    nmtv
\     NMHDR     hdr
        int     action
\   TV_ITEM     itemOld
        int     maskOld
        int     hItemOld
        int     stateOld
        int     stateMaskOld
        int     pszTextOld
        int     cchTextMaxOld
        int     iImageOld
        int     iSelectedImageOld
        int     cChildrenOld
        int     lParamOld
\   TV_ITEM     itemNew
        int     maskNew
        int     hItemNew
        int     stateNew
        int     stateMaskNew
        int     pszTextNew
        int     cchTextMaxNew
        int     iImageNew
        int     iSelectedImageNew
        int     cChildrenNew
        int     lParamNew
\     POINT     ptDrag
        int     x
        int     y
    ;RecordSize: /nmtv

Rectangle ItemRect

: fill-nmhdr    ( l -- )
                nmhdr   /nmhdr   2dup erase move ;

: fill-tvkd     ( l -- )
                3 cells+
                tvkd    /tvkd    2dup erase move ;

: fill-tvitem   ( l -- )
                3 cells+
                tvitem  /tvitem  2dup erase move ;

: fill-nmtv     ( addr -- )
                3 cells+
                nmtv    /nmtv    2dup erase move ;

: tvitem->tvins ( -- )
                tvitem item /tvitem move ;


\ -------------------- Create Tree-View Control --------------------

:M WindowStyle: ( -- style )
                [ WS_CHILD WS_VISIBLE or ] literal
                ;M

:M StartSize: ( -- w h )   width: parent  height: parent ;M

:M Start:       ( Parent -- )
                hWnd
                if   drop
                     SW_SHOWNOACTIVATE Show: self
                else to Parent
\                     Call InitCommonControls drop
                     z" SysTreeView32" Create-Control
                then ;M

:M Handle_Notify: ( h m w l -- f )
                dup fill-nmhdr
                code
                case
                   TVN_BEGINDRAGA      of  fill-nmtv   On_BeginDrag:      [ self ] endof
                   TVN_BEGINRDRAGA     of  fill-nmtv   On_BeginRDrag:     [ self ] endof
                   TVN_BEGINLABELEDITA of  fill-tvitem On_BeginLabelEdit: [ self ] endof
                   TVN_DELETEITEMA     of  fill-nmtv   On_DeleteItem:     [ self ] endof
                   TVN_ENDLABELEDITA   of  fill-tvitem On_EndLabelEdit:   [ self ] endof
                   TVN_GETDISPINFOA    of  fill-tvitem On_GetDispInfo:    [ self ] endof
                   TVN_ITEMEXPANDEDA   of  fill-nmtv   On_ItemExpanded:   [ self ] endof
                   TVN_ITEMEXPANDINGA  of  fill-nmtv   On_ItemExpanding:  [ self ] endof
                   TVN_KEYDOWN         of  fill-tvkd   On_KeyDown:        [ self ] endof
                   TVN_SELCHANGEDA     of  fill-nmtv   On_SelChanged:     [ self ] endof
                   TVN_SELCHANGINGA    of  fill-nmtv   On_SelChanging:    [ self ] endof
                   TVN_SETDISPINFOA    of  fill-tvitem On_SetDispInfo:    [ self ] endof
                   NM_RCLICK           of              On_RightClick:     [ self ] endof
                          false swap ( default)
                endcase
                ;M

:M ToggleExpandItem:  ( hItem -- )
                TVE_TOGGLE TVM_EXPAND SendMessage:SelfDrop ;M

:M ExpandItem:  ( hItem -- )
                TVE_EXPAND TVM_EXPAND SendMessage:SelfDrop ;M

:M CollapseItem:  ( hItem -- )
                TVE_COLLAPSE TVM_EXPAND SendMessage:SelfDrop ;M

:M SortChildren:      ( hItem -- )
                false TVM_SORTCHILDREN SendMessage:SelfDrop ;M

:M DeleteItem:  ( hItem -- f )
\ *G Removes an item and all its children from the tree view control.
\ ** hItem is the handle of the item to delete. If hItem is set to TVI_ROOT,
\ ** all items are deleted.
                0 TVM_DELETEITEM SendMessage:Self ;M

:M InsertItem:   ( -- hItem )   tvins 0 TVM_INSERTITEM SendMessage:Self ;M
:M SetImageList: ( himl iImage -- )   TVM_SETIMAGELIST SendMessage:SelfDrop ;M
\ :M DeleteItem:   ( hItem -- f )       0 TVM_DELETEITEM SendMessage:Self ;M
:M SetItem:      ( -- )           tvitem 0 TVM_SETITEM SendMessage:SelfDrop ;M
:M Expand:       ( hItem f -- )             TVM_EXPAND SendMessage:SelfDrop ;M
\ :M ToggleExpandItem: ( hItem -- )   TVE_TOGGLE Expand: self ;M
:M CollapseReset: ( hItem -- )  TVE_COLLAPSERESET TVE_COLLAPSE or Expand: self ;M
:M Collapse:     ( hItem -- )        TVE_COLLAPSE TVE_COLLAPSE or Expand: self ;M
:M GetItemRect: ( hItem -- f )  ItemRect ! ItemRect true TVM_GETITEMRECT SendMessage:Self ;M
:M SelectItem:  ( hItem flag -- )      TVM_SELECTITEM  SendMessage:SelfDrop ;M
:M GetNextItem: ( hItem flag -- h )   TVM_GETNEXTITEM SendMessage:Self   ;M
:M GetRoot:     ( -- hItem )               0 TVGN_ROOT GetNextItem: self ;M
:M GetChild:    ( hItem -- hItem )          TVGN_CHILD GetNextItem: self ;M
:M GetParentItem: ( hItem -- hItem )       TVGN_PARENT GetNextItem: self ;M
:M GetNext:     ( hItem -- hItem )           TVGN_NEXT GetNextItem: self ;M
:M GetPrevious: ( hItem -- hItem )       TVGN_PREVIOUS GetNextItem: self ;M

int maxwidth
: ItemWidthMax ( hItem -- hItem )
        dup GetItemRect: self IF  right: ItemRect  maxwidth max to maxwidth  THEN ;

:M GetMaxWidth: ( -- n )
        0 to MaxWidth
        GetRoot: self
        ItemWidthMax
        GetChild: self
        Begin  dup dup
        While
            ItemWidthMax
            GetChild: self
            Begin  dup
            While
               ItemWidthMax
               GetNext: self
            Repeat  drop
            GetNext: self
        Repeat  drop drop
        MaxWidth
        ;M

\ --------------------- Overridable methods ----------------------

:M On_BeginDrag: ( -- f )
                false
                ;M
:M On_BeginRDrag: ( -- f )
                false
                ;M
:M On_BeginLabelEdit: ( -- f )  \ f=true, cancel edit,  f=false, ok edit
                false
                ;M
:M On_DeleteItem: ( -- f )
                false
                ;M
:M On_EndLabelEdit: ( -- f )
                false
                ;M
:M On_GetDispInfo: ( -- f )
                false
                ;M
:M On_ItemExpanded: ( -- f )
                false
                ;M
:M On_ItemExpanding: ( -- f )   \ f=true, don't expand/collapse, f=false, ok go ahead
                false
                ;M
:M On_KeyDown: ( -- f )
                false
                ;M
:M On_SelChanged: ( -- f )
                false
                ;M
:M On_SelChanging: ( -- f )     \ f=true, don't change, f=false, ok change
                false
                ;M
:M On_SetDispInfo: ( -- f )
                false
                ;M
:M On_RightClick: ( -- f )
                false
                ;M
;Class


\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\       End  of Class definition(s)
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\


\   ***************************************************
\S  ******** Below please find a small example ********
\   ***************************************************


:Class NewTVC <super TreeViewControl

        Font WinFont


:M WindowStyle: ( -- style )
                WindowStyle: super
                TVS_HASLINES        or
                TVS_HASBUTTONS      or
                TVS_DISABLEDRAGDROP or
                TVS_SHOWSELALWAYS   or
                TVS_LINESATROOT     or
                ;M

int hRoot
int hSon
int hPrev

: AddItem       ( sztext hAfter hParent nChildren -- )
                tvins  /tvins  erase
                tvitem /tvitem erase
                ( nChildren)      to cChildren
                ( hParent)        to hParent
                ( hAfter)         to hInsertAfter
                                  to pszText
                TVIF_TEXT TVIF_CHILDREN or
                to mask
                tvitem->tvins
                tvins 0 TVM_INSERTITEMA hWnd Call SendMessage
                to hPrev
                ;


: FillTreeView  ( -- )
                z" Root Item"        TVI_LAST  TVI_ROOT  1  AddItem
                hPrev to hRoot
                z" First son"        hPrev     hRoot     1  AddItem
                hPrev to hSon
                z" First Grandson"   hPrev     hSon      0  AddItem
                z" Second Grandson"  hPrev     hSon      0  AddItem
                z" Second son"       hPrev     hRoot     0  AddItem
                z" Third son"        hPrev     hRoot     1  AddItem
                hPrev to hSon
                z" Third Grandson"   hPrev     hSon      0  AddItem
                ;

:M Start:       ( Parent -- )
                Start: super

                8 Width: WinFont
                16 Height: WinFont
                s" Courier New" SetFaceName: WinFont
                Create: WinFont
                true Handle: WinFont WM_SETFONT hWnd CALL SendMessage drop \ activate a new font

                \ Insert items...
                FillTreeView
                ;M


:M On_SelChanged: { \ text$ -- f }      \ Show text of selected item in message box
                maxstring LocalAlloc: text$

                TVIF_TEXT        to mask
                hItemNew         to hItem
                text$            to pszText
                maxstring        to cchTextMax
                tvitem 0 TVM_GETITEMA  hWnd Call SendMessage drop

                text$ z" TreeView selection"
                MB_OK MessageBox: Parent drop

                false
                ;M

;Class


:Object MainWindow  <super Window

        int TreeView

:M On_Init:     ( -- )
                On_Init: super

                New> NewTVC to TreeView
                1001 SetId: TreeView
                self Start: TreeView
                ;M

:M WindowTitle: ( -- sztitle )
                z" TreeView Test"
                ;M

:M StartSize:   ( -- w h )
                100 100
                ;M

:M On_Size:     ( -- )
                AutoSize: TreeView
                ;M

:M WM_NOTIFY    ( h m w l -- f )
                dup @  GetHandle: TreeView  =
                if      Handle_Notify: TreeView
                else    false
                then
                ;M

;Object

Start: MainWindow


\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\       End of File
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

[Win32forth-cvs] win32forth-stc/demos/GdiDemo BitBlt.f, NONE, 1.1 Figfonts.f, NONE, 1.1 Figraph.f, NONE, 1.1 Metafile.f, NONE, 1.1 SixEasyFonts.f, NONE, 1.1 TextList.f, NONE, 1.1 TxtAlign.f, NONE, 1.1

[Dirk B. <db...@us...>]

Update of /cvsroot/win32forth/win32forth-stc/demos/GdiDemo
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv18947/demos/GdiDemo

Added Files:
	BitBlt.f Figfonts.f Figraph.f Metafile.f SixEasyFonts.f 
	TextList.f TxtAlign.f 
Log Message:
GDI Class Library - Demo's added

--- NEW FILE: SixEasyFonts.f ---
\ SixEasyFonts.F
\ Written by David R. Pochin
\ Changed to use the GDI class library by Dirk Busch

\ Using Windows Stock Fonts

ANEW -SixEasyFonts.F

needs controls.f
needs gdi/gdi.f

\ Define an Object that is a child object of the Class "Window".
:OBJECT Fontdemo <SUPER WINDOW

gdiWindowDC tDC

:M WindowTitle: ( -- title )         \ Title for the window.
                z" Six Easy Fonts      One example only"
                ;M

:M StartSize:   ( -- width height )  \ Set width and height of window
                500 200
                ;M

:M StartPos:    ( -- x y )           \ Set the screen origin.
                100 100
                ;M

:M Close:       ( -- )               \ Do anything the class needs.
                Destroy: tDC
                Close: SUPER
                ;M

:M On_Paint:  ( -- )                 \ screen redraw procedure

        GetHandle: self GetDC: tDC
        if
             DEVICE_DEFAULT_FONT SelectStockObject: tDC
             20 30 s" DEVICE_DEFAULT_FONT AaBbCc¹º1/41/23/4¿HhIiJjKkLl" TextOut: tDC

             SYSTEM_FONT SelectStockObject: tDC drop
             20 50 s" SYSTEM_FONT AaBbCc¹º1/41/23/4¿HhIiJjKkLl" TextOut: tDC

             SYSTEM_FIXED_FONT SelectStockObject: tDC drop
             20 70 s" SYSTEM_FIXED_FONT AaBbCc¹º1/41/23/4¿HhIiJjKkLl" TextOut: tDC

             OEM_FIXED_FONT SelectStockObject: tDC drop
             20 90 s" OEM_FIXED_FONT AaBbCc¹º1/41/23/4¿HhIiJjKkLl" TextOut: tDC

             ANSI_FIXED_FONT SelectStockObject: tDC drop
             20 110 s" ANSI_FIXED_FONT AaBbCc¹º1/41/23/4¿HhIiJjKkLl" TextOut: tDC

             ANSI_VAR_FONT SelectStockObject: tDC drop
             20 130 s" ANSI_VAR_FONT AaBbCc¹º1/41/23/4¿HhIiJjKkLl" TextOut: tDC

             SelectObject: tDC drop \ clean up
             Release: tDC
        then ;M

;OBJECT \ Complete the definition of the new object.

: FONTS ( -- )
        Start: Fontdemo ;

FONTS

\ END OF LISTING.



--- NEW FILE: Figraph.f ---
\ FIGRAPH.F    Example of Object Oriented Graphics
\ Written by David R. Pochin
\ Changed to use the GDI class library by Dirk Busch

\ Examples of pens, brushes, lines, shapes and fills.

anew -FigGraph.f

needs controls.f
needs gdi/gdi.f

\ Define an Object that is a child of the Class Window
:OBJECT Grafdemo <SUPER WINDOW

ButtonControl Button_1   \ a button

gdiWindowDC tDC

\ Set Up handles for Pens and Brushes.
gdiPen hPen1
gdiPen hPen2
gdiPen hPen3
gdiPen hPen4
gdiHatchBrush hBrush1

\ Set up Array of Data Points for use with Polyline.
Create POLYDATA
        ( x1 , y1 , x2 , y2 , etc )
        140 , 70 , 180 , 100 , 200 , 50 , 230 , 90 , 250 , 80 ,

\ Things to do at the start of window creation
:M ClassInit:   ( -- )
        ClassInit: super \ Do anything the super class needs.
        ;M

:M WindowTitle: ( -- title )
        z" Drawing Figures with Win32Forth " ;M

:M StartSize:   ( -- width height )
        550 230 ;M

:M StartPos:    ( -- x y )
        100 100 ;M

\ Create five drawing methods.
\ Follow these patterns for other Windows figures such as Arc.
:M DrawRect:    ( bottom right top left -- )
        4reverse Rectangle: tDC ;M

:M DrawEllipse: ( bottom right top left -- )
        4reverse Ellipse: tDC ;M

:M DrawPie: ( Drawn counter clockwise from xstart, ystart )
        ( yfinish xfinish ystart xstart bottom right top left  -- )
        8reverse Pie: tDC ;M

:M DrawRoundRect: ( ycnr xcnr bottom right top left -- )
        6reverse RoundRect: tDC ;M

:M DrawPolyLine:  ( n addr -- )
        swap Polyline: tDC ;M

\ Remember to delete any objects you have made before closing.
:M Close:       ( -- )
        Destroy: hPen1
        Destroy: hPen2
        Destroy: hPen3
        Destroy: hPen4
        Destroy: hBrush1
        Destroy: tDC
        Close: super
        ;M

:M On_Init:     ( -- )

        \ Set up a Button
        IDOK               SetID: Button_1
        self               Start: Button_1
        160 180 70 25       Move: Button_1
        s" CLOSE"        SetText: Button_1
                        GetStyle: Button_1 BS_DEFPUSHBUTTON OR
                        SetStyle: Button_1

        \ Create all non Stock Object Pens and Brushes required.
        \ ONLY PenWidth 1 allowed with PenStyles other than PS_SOLID
        128 128 128 SetRGB: hPen1 12 SetWidth: hPen1 PS_SOLID SetStyle: hPen1 Create: hPen1
          0   0 255 SetRGB: hPen2  1 SetWidth: hPen1 PS_DOT   SetStyle: hPen2 Create: hPen2
        255   0   0 SetRGB: hPen3  4 SetWidth: hPen1 PS_SOLID SetStyle: hPen3 Create: hPen3
          0  255  0 SetRGB: hPen4  1 SetWidth: hPen1 PS_NULL  SetStyle: hPen4 Create: hPen4

          0 128 128 SetRGB: hBrush1 HS_DIAGCROSS SetStyle: hBrush1 Create: hBrush1

        ;M

:M On_Paint:  ( -- )          \ screen redraw procedure
        GetHandle: self GetDC: tDC
        if
                \ Select pen hPen1
                hPen1 SelectObject: tDC

                \ Set Brush to LTGREEN
                Brush: LTGREEN SelectObject: tDC

                \ draw a rectangle with solid fill
                hPen1 SelectObject: tDC
                100 80 20 20 DrawRect: self

                \ change pen to hPen2 and
                \ draw a dotted line
                hPen2 SelectObject: tDC drop
                100 20 MoveTo: tDC
                230 20 LineTo: tDC

                \ Select pen hPen3 and draw an ellipse
                Brush: LTYELLOW SelectObject: tDC drop
                hPen3 SelectObject: tDC drop
                100 485 40 340 DrawEllipse: self

                \ Select pen hPen3 and draw a pie
                Brush: LTCYAN SelectObject: tDC drop
                hPen4 SelectObject: tDC drop
                190 60 120 140 200 240 120 70 DrawPie: self

                \ Select pen hPen2, change background color,
                \ brush and draw a rounded rectangle
                Color: LTRED SetBackgroundColor: tDC
                hBrush1 SelectObject: tDC drop
                hPen2 SelectObject: tDC drop
                20 80 200 515 120 290 DrawRoundRect: self

                \ Change the pen colour and brush, draw an ellipse
                Color: WHITE SetBackgroundColor: tDC
                Pen: LTGREEN SelectObject: tDC drop
                NULL_BRUSH SelectStockObject: tDC drop \ this doesn't work... why?
                150 520 20 280 DrawEllipse: self

                \ Change the pen colour and draw a polyline
                Pen: MAGENTA SelectObject: tDC drop
                5 POLYDATA DrawPolyLine: self

                \ cleanup
                SelectObject: tDC drop \ bursh
                SelectObject: tDC drop \ pen
                Release: tDC
        then ;M

 :M WM_COMMAND   ( hwnd msg wparam lparam -- res )
        OVER LOWORD ( Id )
        CASE    IDOK OF Close: self ENDOF
        ENDCASE 0 ;M

 ;OBJECT

: DEMO  ( -- )
        Start: Grafdemo ;
DEMO

\ END OF LISTING


--- NEW FILE: Metafile.f ---
\ File:         Metafile.f
\ Purpose:      Demo application for the GDI class library
\ Written:      Sonntag, Oktober 30 2005 by Dirk Busch
\ Licence:      Public Domain

cr .( Loading GDI class library demo - Main...)

anew -gdidemo.f

needs window.f
needs gdi/gdi.f \ the GDI class library

0 value create-tunkey?

\ ----------------------------------------------------------------------
\ the Main window
\ ----------------------------------------------------------------------
:object GdiDemoWindow <super WINDOW

gdiPen          tPen
gdiSolidBrush   tSolidBrush
gdiHatchBrush   tHatchBrush
gdiFont         tFont
gdiWindowDC     tDC
gdiMetafileDC   tMetaDC

\ Create a metafile and store it on disk.
\ This metafile will be displayed during repaint
create FileName ," Metafile.emf"
create Text1    ," This is a Text"
create Text2    ,"TEXT" "This is a Text with a\TTAB"
int Created?

winver 1 > [if] \ sorry only Win98 and better
:M SetArcDirection: ( Direction -- OldDirection )
        SetArcDirection: tMetaDC ;M
[else]
:M SetArcDirection: ( Direction -- OldDirection )
        ;M
[then]

: CreateIt      ( -- )
        hWnd GetDC: tDC
        if
                \ Start recording a metafile for this window
                0 0 Width Height tDC CalcMetaRect: tMetaDC
                tDC StartRecording: tMetaDC
                if
                        \ setup the MetafileDC
                        MM_TEXT SetMapMode: tMetaDC
                        0 0 SetWindowOrg: tMetaDC

                        \ draw something into the metafile
                        tPen SelectObject: tMetaDC
                        tHatchBrush SelectObject: tMetaDC

                         50  50 100 125 Rectangle: tMetaDC
                        125 125 150 175 Ellipse: tMetaDC

                        AD_COUNTERCLOCKWISE SetArcDirection: tMetaDC
                        190 60 120 140 200 240 120 70 Pie: tMetaDC
                        290 160 120 140 200 240 120 70 Chord: tMetaDC
                        SetArcDirection: tMetaDC drop

                        SelectObject: tMetaDC drop \ tHatchBrush

                        tSolidBrush SelectObject: tMetaDC

                        AD_CLOCKWISE SetArcDirection: tMetaDC
                        190 60 120 140 200 240 120 70 Pie: tMetaDC
                        290 160 120 140 200 240 120 70 Chord: tMetaDC
                        SetArcDirection: tMetaDC drop

                        SelectObject: tMetaDC drop \ tSolidBrush
                        SelectObject: tDC drop \ tPen

                         20 300 120 350 tHatchBrush FillRect: tMetaDC
                        120 300 220 350 tHatchBrush FrameRect: tMetaDC

                        tFont SelectObject: tMetaDC
                        20 350 Text1 count TextOut: tMetaDC

                        20 SetTabSize: tMetaDC
                        20 400 Text2 count TabbedTextOut: tMetaDC 2drop
                        SetTabSize: tMetaDC drop \ TabSize

                        SelectObject: tMetaDC drop \ tFont

                        \ cleanup the MetafileDC
                        SetMapMode: tMetaDC drop
                        SetWindowOrg: tMetaDC 2drop

                        \ stop recording
                        StopRecording: tMetaDC
                        if   \ save it
                             FileName count Save: tMetaDC drop
                             true to Created?
                        then
                        Destroy: tMetaDC
                then
                Release: tDC
        then ;

\ Load the Metafile and draw it
: LoadAndDrawIt ( -- )
        FileName count Load: tMetaDC \ load the metafile from disk
        if   0 0 Width Height tDC Draw: tMetaDC \ and draw it in our window
             Destroy: tMetaDC \ clean up
        then ;

:M On_Paint:    ( -- )
        Created?
        if   hWnd GetDC: tDC
             if   LoadAndDrawIt
                  Release: tDC
             then
        then ;M

:M Start:       ( -- )

        FALSE to Created? \ we don't have a Metafile to display yet

        \ create a Pen
        hWnd ChooseColor: tPen 0=
        if 255 SetRValue: tPen then
        PS_DASHDOTDOT SetStyle: tPen
        Create: tPen drop

        \ create a solid brush
        hWnd ChooseColor: tSolidBrush 0=
        if 255 SetGValue: tSolidBrush then
        Create: tSolidBrush drop

        \ create a hatch brush
        hWnd ChooseColor: tHatchBrush 0=
        if 255 SetBValue: tHatchBrush then
        HS_DIAGCROSS SetStyle: tHatchBrush
        Create: tHatchBrush drop

        \ let the user choose a font
        hWnd Choose: tFont 0=
        if      \ create a font
                s" Times New Roman" SetFaceName: tFont
                true SetUnderline: tFont
                true SetItalic: tFont
                20 SetHeight: tFont
                Create: tFont drop
        then


        Start: super    \ display our window
        CreateIt        \ create our metafile
        Paint: super    \ and force a repaint
        ;M

:M On_Done:     ( -- )
        On_Done: super
        turnkeyed? if bye then
        ;M

;object

\ ----------------------------------------------------------------------
\ Start the demo or create a turnkey application
\ ----------------------------------------------------------------------

: GdiDemo ( -- )
        Start: GdiDemoWindow ;

create-tunkey? [if]
        ' GdiDemo turnkey Metafile.exe
[else]
        GdiDemo
[then]

--- NEW FILE: Figfonts.f ---
\ FigFonts.F   Listing for 'Win32Forth Fonts'.
\ Written by David R. Pochin
\ Changed to use the GDI class library by Dirk Busch

\ Examples of Fonts

anew -FigFonts.f

needs CONTROLS.F
needs gdi/gdi.f

\ Define an Object that is a child object of the Class "Window".
:OBJECT Fontdemo <SUPER WINDOW

ButtonControl Button_1   \ Declare a button

gdiWindowDC tDC
gdiFont     aFont    \ Create a object of the class font
gdiFont     bFont    \ and another

:M ClassInit:   ( -- )          \ Things to do at the start of window creation.
        ClassInit: SUPER    \ Do anything the class needs.

                                 \ set the default font type for printing
        s" Impact"      SetFaceName: aFont
        24              SetHeight: aFont
        true            SetUnderline: aFont
        VARIABLE_PITCH 0x04 or FF_SWISS or
                        SetPitchAndFamily: aFont

        s" CommonBullets" SetFaceName: bFont
        2                 SetCharSet: bfont
        30                SetHeight: bFont
        14                SetWidth: bFont
        FW_NORMAL         SetWeight: bFont
        VARIABLE_PITCH 0x04 or FF_MODERN or FF_DECORATIVE or
                          SetPitchAndFamily: bFont
        ;M

:M WindowTitle: ( -- title )         \ Title for the window.
        z" Non Stock Fonts " ;M

:M StartSize:   ( -- width height )  \ Set width and height of window
        600 180 ;M

:M StartPos:    ( -- x y )           \ Set the screen origin.
        80 100  ;M

:M Close:       ( -- )               \ Do anything the class needs.
        Destroy: tDC    \ delete the dc
        Destroy: aFont  \ delete the fonts no longer needed
        Destroy: bFont
        Close: super
        ;M

:M On_Init:     ( -- )

        \ Add a button.
        IDOK             SetID: Button_1
        self             Start: Button_1
        480 140 70 25     Move: Button_1
        s" CLOSE"      SetText: Button_1
                      GetStyle: Button_1 BS_DEFPUSHBUTTON OR
                      SetStyle: Button_1

        \ create the fonts
        Create: aFont
        Create: bFont
        ;M

:M On_Paint:  ( -- )          \ screen redraw procedure
        GetHandle: self GetDC: tDC
        if
             \ Output the first text string.
             \ Example of the Forth word s" and see the method TextOut: in dc.f
             \ Note TextOut: requires the length of the string.

             aFont SelectObject: tDC
             20 30 s" aFont AaBbCcDdEeFfGgHhIiJjKkLl"  TextOut: tDC

             bFont SelectObject: tDC drop
             20 80 s" bFont AaBbCcDdEeFfGgHhIiJjKkLl"  TextOut: tDC

             \ cleanup
             SelectObject: tDC drop
             Release: tDC
        then ;M

:M WM_COMMAND   ( hwnd msg wparam lparam -- res )
        over LOWORD    \ fetch the identity of the Ok button which is in wParam
        case           \ case .. of .. endof .. endcase is a Forth defined
                       \ switch construction
             IDOK of   \ IDOK is the identity of Button_1
                    Close: self
                  endof
        endcase
        0 ;M

;OBJECT         \ Complete the definition of the new object.

: DEMO          ( -- )
                Start: Fontdemo ;
demo

\ END OF LISTING.



--- NEW FILE: BitBlt.f ---
\ BitBlt.F    Examples of Raster Operations
\ Written by David R. Pochin
\ Changed to use the GDI class library by Dirk Busch

\ Examples of FillRect and BitBlt.

anew -BitBlt.f

needs CONTROLS.F
needs gdi/gdi.f

\ Define an Object that is a child of the Class Window
:OBJECT Bltdemo <SUPER WINDOW

gdiWindowDC   tDC
gdiSolidBrush tBrushRED
gdiSolidBrush tBrushGREEN
gdiSolidBrush tBrushBLACK

ButtonControl Button_1   \ a button

:M WindowTitle: ( -- title )
        z" BitBlt V.1.1 " ;M

:M StartSize:   ( -- width height )
        550 350 ;M

:M StartPos:    ( -- x y )
        100 100 ;M

:M Close:       ( -- )
        Destroy: tDC
        Destroy: tBrushRED
        Destroy: tBrushGREEN
        Destroy: tBrushGREEN
        Close: super
        ;M

\ Set up a Button and create Pens and Brushes.
:M On_Init:     ( -- )

        \ init the brushes
        255 SetRValue: tBrushRED
          0 SetGValue: tBrushRED
          0 SetBValue: tBrushRED
        Create: tBrushRED

          0 SetRValue: tBrushGREEN
        255 SetGValue: tBrushGREEN
          0 SetBValue: tBrushGREEN
        Create: tBrushGREEN

\       0 SetRValue: tBrushBLACK \ Note that Black is the default
\       0 SetGValue: tBrushBLACK \ color, so we don't need to
\       0 SetBValue: tBrushBLACK \ set the color.
        Create: tBrushBLACK

        \ create a pushbutton to close the demo
        IDOK               SetID:   Button_1
        self               Start:   Button_1
        420 300 70 25      Move:    Button_1
        s" CLOSE"          SetText: Button_1
                          GetStyle: Button_1 BS_DEFPUSHBUTTON OR
                          SetStyle: Button_1
        ;M

\ Note: This demo was originaly written using the 'old' WindDC class.
\ The BitBlt: method of the gdiDC class is useig a different stack
\ layout. So this method was added for compatiblity.
:M BitBlt:      ( blitmode sourcex,y sourcedc sizex,y destinationx,y -- )
        2>r 2>r >r swap r> 2r> swap 2r> swap
        8reverse \ nXDest nYDest nWidth nHeight hdcSrc nXSrc nYSrc dwRop
        BitBlt: tDC ;M

:M SetUps: { left top right bottom -- }
        \ draw frames for blocks
         39  39 MoveTo: tDC 120 39 LineTo: tDC 120 120 LineTo: tDC
         39 120 LineTo: tDC  39 39 LineTo: tDC

        159  39 MoveTo: tDC 240 39 LineTo: tDC 240 120 LineTo: tDC
        159 120 LineTo: tDC 159 39 LineTo: tDC

        359  39 MoveTo: tDC 440 39 LineTo: tDC 440 120 LineTo: tDC
        359 120 LineTo: tDC 359 39 LineTo: tDC

         39 179 MoveTo: tDC 120 179 LineTo: tDC 120 260 LineTo: tDC
         39 260 LineTo: tDC  39 179 LineTo: tDC

        159 179 MoveTo: tDC 240 179 LineTo: tDC 240 260 LineTo: tDC
        159 260 LineTo: tDC 159 179 LineTo: tDC

        359 179 MoveTo: tDC 440 179 LineTo: tDC 440 260 LineTo: tDC
        359 260 LineTo: tDC 359 179 LineTo: tDC

        \ Make the source, original destination and destination blocks

        80 40 120  80 tBrushGREEN FillRect: tDC
        40 80  80 120 tBrushBLACK FillRect: tDC
        NOTSRCCOPY 40 40 GetHandle: tDC 80 80 160 40 BitBlt: self
        SRCCOPY   160 40 GetHandle: tDC 80 80 360 40 BitBlt: self

         40 220 120 260 tBrushBLACK FillRect: tDC
        200 180 240 260 tBrushBLACK FillRect: tDC
        SRCCOPY 160 180 GetHandle: tDC 80 80 360 180 BitBlt: self

        \ Setup the text
         55  16 s" Source" TextOut: tDC
        160  16 s" Destination" TextOut: tDC
        280  16 s" Blt" TextOut: tDC
        375  16 s" Result" TextOut: tDC
        260  50 s" PATPAINT" TextOut: tDC
        255 210 s" MERGECOPY" TextOut: tDC
        ;M

:M BitBlts:
        \ Top row of display. Alternatively use any of
        \  BLACKNESS WHITENESS NOTSRCCOPY SRCCOPY
        \  PATCOPY PATINVERT DSINVERT
        PATPAINT 40 40 GetHandle: tDC 80 80 360 40 BitBlt: self

        \ Bottom row of display. Aternatively use any of
        \ SRCERASE SRCINVERT SRCPAINT MERGEPAINT NOTSRCERASE
        \ SRCAND
        MERGECOPY 40 180 GetHandle: tDC 80 80 360 180 BitBlt: self
        ;M

:M On_Paint:  ( -- )          \ screen redraw procedure
        GetHandle: self GetDC: tDC
        if   tBrushRED SelectObject: tDC \ Use this brush as the current pattern

             SetUps: self
             BitBlts: self

             \ cleanup
             SelectObject: tDC drop
             Release: tDC
        then ;M

:M WM_COMMAND   ( hwnd msg wparam lparam -- res )
        OVER LOWORD ( Id )
        CASE    IDOK OF Close: self ENDOF
        ENDCASE
        0 ;M

;OBJECT

: DEMO  ( -- )
        Start: Bltdemo ;
DEMO

\ END OF LISTING


--- NEW FILE: TxtAlign.f ---
\ TextAlign.F
\ Written by David R. Pochin
\ Changed to use the GDI class library by Dirk Busch

anew -TextAlign

needs controls.f
needs gdi/gdi.f

:Object TextAlign  <Super Window

gdiFont     tFont
gdiWindowDC tDC

ButtonControl Button_1   \ a button

:M WindowTitle: ( -- title )
        z" Text Alignment" ;M

:M StartSize:   ( -- w h )      \ the width and height of our window
        230 200 ;M

:M StartPos:    ( -- x y )      \ the screen origin of our window
        100 100 ;M

:M SetLines:    ( -- )
         80  10 MoveTo: tDC
         80 110 LineTo: tDC
         10 140 MoveTo: tDC
        210 140 LineTo: tDC
        ;M

:M PrintText:   ( -- )

        \ select out Font into the DC
        tFont SelectObject: tDC

        \ draw some Text
        TA_LEFT SetTextAlign: tDC
        80 20 s" LEFT" TextOut: tDC

        TA_CENTER SetTextAlign: tDC drop
        80 50 s" CENTRE" TextOut: tDC

        TA_RIGHT SetTextAlign: tDC drop
        80 80  s" RIGHT" TextOut: tDC

        TA_TOP SetTextAlign: tDC drop
        30 140  s" TOP" TextOut: tDC

        TA_BOTTOM SetTextAlign: tDC drop
        70 140  s" BOTTOM" TextOut: tDC

        TA_BASELINE SetTextAlign: tDC drop
        155 140  s" BASE" TextOut: tDC

        SetTextAlign: tDC drop \ reset Text alignment
        SelectObject: tDC drop \ reset Font
        ;M

:M On_Paint:    ( -- )
        GetHandle: self GetDC: tDC
        if   SetLines: self
             PrintText: self
             Release: tDC
        then ;M

:M On_Init:     ( -- )  \ things to do at the start of window creation
        On_Init: super  \ do anything superclass needs

        \ init the pushbutton to close the application
        IDOK               SetID: Button_1
        self               Start: Button_1
        80 160 60 25        Move: Button_1
        s" CLOSE"        SetText: Button_1
        BS_DEFPUSHBUTTON  +Style: Button_1

        \ create a font
        s" Arial" SetFaceName: tFont
        10 SetHeight: tFont
        Create: tFont drop
        ;M

:M WM_COMMAND   ( hwnd msg wparam lparam -- res )
        OVER LOWORD ( Id )
        CASE    IDOK OF Close: self ENDOF
        ENDCASE
        0 ;M

:M Close:       ( -- )  \ Do anything the class needs.
        Destroy: tFont
        Destroy: tDC

        Close: SUPER
        ;M

;Object

: DEMO  ( -- )  \ start running the demo program
        Start: TextAlign ;

\ Runs on load.
demo

\ End of Listing.


--- NEW FILE: TextList.f ---
\ TextList.F    Example of Object Oriented Text Strings
\ Written by David R. Pochin
\ Changed to use the GDI class library by Dirk Busch

\ Examples of text foreground, background and mode options.

anew -TextList.f

needs controls.f
needs gdi/gdi.f

\ Define an Object that is a super object of the Class "Window".
:OBJECT Stringdemo <SUPER WINDOW

gdiWindowDC   tDC
ButtonControl Button_1   \ Declare a button

:M WindowTitle: ( -- title )         \ Title for the window.
        z" Text String Objects. Win32Forth " ;M

:M StartSize:   ( -- width height )  \ Set width and height of window
        500 270 ;M

:M StartPos:    ( -- x y )           \ Set the screen origin.
        200 100  ;M

:M DrawRect:    ( y2 x2 y1 x1 -- )   \ See method GetHandle: in dc.f
        4reverse Rectangle: tDC ;M

:M Close:       ( -- )               \ Do anything the class needs.
        Destroy: tDC
        Close: super
        ;M

:M On_Init:     ( -- )
        \ Add a button.
        IDOK               SetID: Button_1
        self               Start: Button_1
        190 220 70 25       Move: Button_1
        s" CLOSE"        SetText: Button_1
                        GetStyle: Button_1 BS_DEFPUSHBUTTON OR
                        SetStyle: Button_1
        ;M

:M On_Paint:  ( -- )          \ screen redraw procedure
        GetHandle: self GetDC: tDC
        if
                \ Output the first text string.
                \ Example of the Forth word s" and see the method TextOut: in dc.f
                \ Note TextOut: requires the length of the string.
                90 20 s" COUNTED STRING. DEFAULT SETTINGS"  TextOut: tDC

                \ Set TextColor and BkColor.
                \ See the methods in dc.f which call Windows functions.
                Color: LTBLUE SetTextColor: tDC
                Color: LTRED SetBackgroundColor: tDC

                \ Set up two rectangles to see Mode Effects.
                \ Again see the methods in dc.f
                Brush: LTYELLOW SelectObject: tDC
                205 220 50 100 DrawRect: self
                Brush: LTGREEN SelectObject: tDC drop
                205 340 50 220 DrawRect: self

                \ Output the second text string.
                \ Used the z" word this time, note the string count required '53'
                \ As expected TextOut: is a method in dc.f
                20 60 z" LTBLUE Foreground and LTRED Background. BkMode OPAQUE" 53 TextOut: tDC

                \ Change background mode.
                TRANSPARENT SetBackgroundMode: tDC
                15 90 s" LTBLUE Foreground and LTRED Background. BkMode TRANSPARENT" TextOut: tDC

                \ Change Text Color to White
                Color: LTGREEN SetTextColor: tDC drop
                10 120 s" LTRED Background and LTGREEN Foreground. BkMode TRANSPARENT" TextOut: tDC

                \ Reset background mode to Opaque.
                OPAQUE SetBackgroundMode: tDC drop
                10 150 s" LTRED Background and LTGREEN Foreground. BkMode OPAQUE" TextOut: tDC

                \ Back to Defaults.
                SetBackgroundMode: tDC drop
                SelectObject: tDC drop \ bursh
                SetBackgroundColor: tDC drop
                SetTextColor: tDC drop
                120 180 s" Back to DEFAULT conditions." TextOut: tDC

                \ clean up
                Release: tDC
        then
        ;M

:M WM_COMMAND   ( hwnd msg wparam lparam -- res )
        over LOWORD    \ fetch the identity of the Ok button which is in wParam
        case           \ case .. of .. endof .. endcase is a Forth defined
                       \ switch construction
             IDOK of   \ IDOK is the identity of Button_1
                    Close: self
                  endof
        endcase
        0 ;M

;OBJECT         \ Complete the definition of the new object.

: DEMO          ( -- )
        Start: Stringdemo ;
demo

\ END OF LISTING.

[Win32forth-cvs] win32forth-stc/demos/GdiDemo - New directory

[Dirk B. <db...@us...>]

Update of /cvsroot/win32forth/win32forth-stc/demos/GdiDemo
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv18553/GdiDemo

Log Message:
Directory /cvsroot/win32forth/win32forth-stc/demos/GdiDemo added to the repository

[Win32forth-cvs] win32forth-stc/Templates PopupWindow.f,NONE,1.1

[Jos v.d.V. <jo...@us...>]

Update of /cvsroot/win32forth/win32forth-stc/Templates
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv22542

Added Files:
	PopupWindow.f 
Log Message:
Jos: Added an other template

--- NEW FILE: PopupWindow.f ---
anew  -PopupWindow.f

\ Needed in a listview or treeview when you would like to have a popup menu.
\ The popup window could be activated when there is a right click on an item.

Needs Window.f
Needs Menu.f

defer    ClosePopupWindow            ' noop is ClosePopupWindow

POPUPBAR PopupOnItem     \   Define the Popup bar for a window here.
    POPUP " "
       MENUITEM  "Some action (Not yet defined)"  ClosePopupWindow  noop ;
ENDBAR

:Object    PopupWindow    <super  Window

: StartPopup    ( -- )  0 WM_RBUTTONDOWN GetHandle: self Call PostMessage drop ;
:noname         ( - )                   Close: Self   ;  is ClosePopupWindow
: CleanupClose  ( h_m w_l - res )       2drop ClosePopupWindow  ;

:M ClassInit:     ( -- )   ClassInit: super   PopupOnItem SetPopupBar: Self ;M
:M WindowStyle:   ( -- style )          WS_POPUP                ;M
:M ExWindowStyle: ( -- extended_style ) WS_EX_TOOLWINDOW        ;M
:M StartSize:     ( -- width height )   1 1                     ;M
:M StartPos:      ( -- x y )            mousex  mousey          ;M
:M WM_LBUTTONDOWN ( h m w l -- res )    CleanupClose            ;M
:M On_KillFocus:  ( h m w l -- res )    CleanupClose            ;M
:M On_Done:       ( h m w l -- res )    On_Done: super 0        ;M
:M SetParent:     ( HwndParent -- )     to parent               ;M
:M On_Paint:      ( -- )   hwnd start: PopupOnItem   StartPopup ;M

:M Start:         ( mousex mousey HwndParent -- )
        SetParent: Self
        to mousey to mousex
        Start: super
        ;M


;Object

\  screen-size swap 2/  swap 2/ 0 Start: PopupWindow      \ to show how it looks

\s
(( Use from an other window:

: StartPopupWindow ( -- )
           hWnd get-mouse-xy
           GetWindowRect: Self 2drop
           rot + >r + r>  Hwnd Start: PopupWindow
          ;  ))

\s

[Win32forth-cvs] win32forth-stc/Templates MinimalWindow.f, NONE, 1.1

[Jos v.d.V. <jo...@us...>]

Update of /cvsroot/win32forth/win32forth-stc/Templates
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv16019

Added Files:
	MinimalWindow.f 
Log Message:
Jos: Now it works thanks to George

--- NEW FILE: MinimalWindow.f ---
\ Needs NoConsole.f
Needs Window.f
Needs Menu.f
Needs Resources.f

Anew -MinimalWindow.f   \ With a start of a menubar

false value turnkey?

:Object MinimalWindow   <Super Window

:M On_Init:             ( -- )                    On_Init: super        ;M
:M ClassInit:           ( -- )                  ClassInit: super        ;M
:M WindowStyle:         ( -- style )   WindowStyle: Super  WS_CLIPCHILDREN or ;M
:M ParentWindow:        ( -- hwndParent | 0=NoParent )    parent        ;M
:M SetParent:           ( hwndparent -- )       to parent               ;M
:M WindowHasMenu:       ( -- f )                true                    ;M
:M WindowTitle:         ( -- ztitle )           z" Minimal window"      ;M
:M StartSize:           ( -- width height )     screen-size >r 2/ r> 2/ ;M
:M StartPos:            ( -- x y )              CenterWindow: Self      ;M
:M Close:               ( -- )                  Close: super            ;M

:M On_Done:             ( -- )
                        Close: self
                        0 call PostQuitMessage drop
                        On_Done: super 0
                ;M

:M msgBox: ( z$menu z$text - ) swap MB_OK   MessageBox: Self drop       ;M

;Object

MENUBAR ApplicationBar
    POPUP "File"
        MENUITEM        "Exit"          Close: MinimalWindow    ;
    POPUP "Help"
        MENUITEM        "Info"
                        z" Info"
                        z" A template for a \nminimal window."
                        msgBox: MinimalWindow                   ;
ENDBAR

: Minimal
   start: MinimalWindow
   ApplicationBar SetMenuBar: MinimalWindow
\   turnkey?
\      IF   MessageLoop bye
\      THEN
 ;

turnkey? [if]
        NoConsoleIO  NoConsoleInImage
        ' Minimal turnkey MinimalWindow.exe
        s" WIN32FOR.ICO" s" MinimalWindow.exe" AddAppIcon
        1 pause-seconds bye
[else]  Minimal
[then]

\s

[Win32forth-cvs] win32forth-stc/Templates - New directory

[Jos v.d.V. <jo...@us...>]

Update of /cvsroot/win32forth/win32forth-stc/Templates
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv15586/Templates

Log Message:
Directory /cvsroot/win32forth/win32forth-stc/Templates added to the repository

[Win32forth-cvs] win32forth-stc/src/lib RESOURCES.F,NONE,1.1

[Jos v.d.V. <jo...@us...>]

Update of /cvsroot/win32forth/win32forth-stc/src/lib
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv14819

Added Files:
	RESOURCES.F 
Log Message:
Jos: Needed for the template minimalwindow.f

--- NEW FILE: RESOURCES.F ---
\ Resources.f           Utilities to copy, add and enumerate resources in .dll and .exe files.
\                       Rod Oakford Feb 2005  ****Does not work in Win98, need NT, Win2k or later****
\
\                       s" Filename" ListResources enumerates all the resources
\                       e.g. s" w32fconsole.dll" ListResources will show the resources in w32fconsole.dll
\
\                       s" Filename" SourceFile sets the file to copy resources from
\                       s" Filename" ReplaceFile sets the file to replace resources into
\                       s" Filename" AddToFile sets the file to add resources into
\
\                       UpdateFile will add/replace the resources having used:
\
\                       CopyResource (need correct ID's)
\                       CopyIcon
\                       CopyCursor
\                       AddResource (putting all of the file data into the resource)
\                       AddIcon
\                       AddCursor
\                       AddBitmap
\
\                       EXAMPLES:
\
\                       s" Kernel.bin" SourceFile
\                       s" Win32For.exe" ReplaceFile
\                       100 CopyIcon
\                       UpdateFile
\                       will copy the icon (old Win32For.ico) from Kernel.bin into Win32For.exe
\
\                       s" Win32For.exe" ReplaceFile
\                       100 s" Win32For.ico" AddIcon
\                       UpdateFile
\                       will add the icon file Win32For.ico to Win32For.exe with ID 100
\
\                       s" Win32For.exe" ReplaceFile
\                       UpdateFile
\                       will remove all resources from Win32For.exe
\
\                       use s" Win32For.exe" AddToFile to add to the resources rather than delete exixting resources
\
\                       the Language identifier can be set in LanguageID, eg. 2057 to LanguageID for English (UK)
\
\ Changes:
\ Donnerstag, Juni 02 2005 dbu - removed abs>rel and rel>abs for version 6.11.xx
\ Samstag, Juni 04 2005 dbu - Check of the Windows version added
\                           - AddAppIcon and LoadAppIcon added
\                           - ReadFile renamed to ReadResFile
\                           - moved most of the code into system space

cr .( Loading Resources Utility...)

anew -Resources.f

in-system
internal

winver winnt4 < [if]

cr .( Sorry the Resources Utility requires Windows NT4, 2K or better.)

[else]

5 proc EnumResourceLanguages
4 proc EnumResourceNames
3 proc EnumResourceTypes
1 proc LoadLibrary
1 proc FreeLibrary
2 proc EndUpdateResource
3 proc FindResource
2 proc LoadResource
1 proc LockResource
2 proc SizeofResource
6 proc UpdateResource
2 proc BeginUpdateResource
6 proc LoadImage
2 proc LoadIcon

\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ \\\\\ Accessing the resource structures \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

Create SourceFileName 256 allot
Create UpdateFileName 256 allot
Create ResourceFileName 256 allot
0 value (NextResID)   \ first resource ID will be 1 unless otherwise set
: NextResID ( -- n )   (NextResID) 1+ dup to (NextResID) ;
0 value LanguageID     \ Language identifier
0 value hExe      \ handle of file to copy resources from
0 value ResData   \ pointer to resource data
0 value ResSize   \ size of resource
0 value hUpdate   \ handle of file to update resources in
0 value GroupResData   \ pointer to resource data for GroupIcon or GroupCursor
: DirEntries ( -- a )   GroupResData 6 + ;   \ address of Group Directory entries
: Entries ( -- n )   DirEntries 2 - w@ ;   \ number of entries in group directory
: nDirEntry ( i -- a )   14 * DirEntries + ;   \ address of directory entry for nth resource in group 
: nPlanes ( i -- a )   nDirEntry 4 + ;   \ address of Color Planes (and Bits per pixel) for icons or HotSpot for cursors
: nBytesInRes ( i -- a )   nDirEntry 8 + ;   \ address of size of nth resource in group
: nImageOffset ( i -- a )   nDirEntry 12 + ;   \ address of offset for data of nth resource in file or ID
: nHotSpot ( i -- n )   nPlanes @ ;   \ HotSpot for nth cursor in group
: nSize ( i -- n )   nBytesInRes @ ;   \ size of nth resource in group
: nID ( i -- ID )   nImageOffset w@ ;   \ ID of nth resource in group
: GroupResSize ( -- n )   Entries 14 * 6 + ;   \ size of Group Resource data
0 value FileData
0 value FileSize
: nImageAddress ( i -- a )   8 * FileData FileSize + + ;   \ to store HotSpots and ImageAddresses at end of file data


\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ \\\\\ Messages \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

[UNDEFINED] Messagebox [IF]
4 proc MessageBox
: MessageBox  ( szText szTitle style hOwnerWindow -- result )
        >r  3reverse r>
        Call MessageBox ;   [THEN]

: ResourceString ( n -- a n )   dup word-split nip IF  ASCIIZ->ASC-LEN  ELSE  (.)  THEN ;

: UpdateMessage ( File$ -- n )   \ IDYES or IDNO
        s" Do you want to save the resources into:\n" pad place
        count pad +place  s" ?" pad +place  pad count asciiz
        z" Update Resources"  MB_ICONEXCLAMATION MB_YESNO or  NULL  MessageBox ;
: SourceFileError ( File$ -- )
        s" Unable to open:\n" pad place  count pad +place  pad count asciiz
        z" Source File" MB_ICONEXCLAMATION MB_OK or NULL MessageBox drop ;
: ResourceFileError ( File$ -- )
        s" Invalid data in:\n" pad place  count pad +place  pad count asciiz
        z" Resource File" MB_ICONEXCLAMATION MB_OK or NULL MessageBox drop ;
: UpdateFileError ( File$" -- )
        s" Unable to open:\n" pad place  count pad +place  pad count asciiz
        z" Update File" MB_ICONEXCLAMATION MB_OK or NULL MessageBox drop ;
: UpdateResourceError ( ID -- )
        s" Failed to update resource " pad place  ResourceString pad +place  pad count asciiz
        z" Update Resource" MB_ICONEXCLAMATION MB_OK or NULL MessageBox drop ;
: LoadResourceError ( ID -- )
        s" Failed to load resource " pad place  ResourceString pad +place  pad count asciiz
        z" Load Resource" MB_ICONEXCLAMATION MB_OK or NULL MessageBox drop ;


\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ \\\\\ Enumerating resources in .exe and .dll files \\\\\\\\\\\\\\\\\\\\\\\\\\\
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

: .ResourceType ( n -- )
        Case
            RT_ACCELERATOR   of  s" RT_ACCELERATOR"  ( Accelerator table )                      Endof
            RT_ANICURSOR     of  s" RT_ANICURSOR"  ( Animated cursor )                          Endof
            RT_ANIICON       of  s" RT_ANIICON"  ( Animated icon )                              Endof
            RT_BITMAP        of  s" RT_BITMAP"  ( Bitmap resource )                             Endof
            RT_CURSOR        of  s" RT_CURSOR"  ( Hardware-dependent cursor resource )          Endof
            RT_DIALOG        of  s" RT_DIALOG"  ( Dialog box )                                  Endof
            RT_FONT          of  s" RT_FONT"  ( Font resource )                                 Endof
            RT_FONTDIR       of  s" RT_FONTDIR"  ( Font directory resource )                    Endof
            RT_GROUP_CURSOR  of  s" RT_GROUP_CURSOR"  ( Hardware-independent cursor resource )  Endof
            RT_GROUP_ICON    of  s" RT_GROUP_ICON"  ( Hardware-independent icon resource )      Endof
            RT_ICON          of  s" RT_ICON"  ( Hardware-dependent icon resource )              Endof
            RT_MENU          of  s" RT_MENU"  ( Menu resource )                                 Endof
            RT_MESSAGETABLE  of  s" RT_MESSAGETABLE"  ( Message-table entry )                   Endof
            RT_RCDATA        of  s" RT_RCDATA"  ( Application-defined resource {raw data} )     Endof
            RT_STRING        of  s" RT_STRING"  ( String-table entry )                          Endof
            RT_VERSION       of  s" RT_VERSION"  ( Version resource )                           Endof
            ( default )      dup ResourceString rot
        EndCase
        Type ;

: .ResourceName ( n -- )   ResourceString type ;

: .Language ( n -- )
        Case
            4105  of s" English (Canada)"   Endof
            1033  of s" English (U.S.)"     Endof
            2057  of s" English (U.K.)"     Endof
            1024  of s" Neutral (Default)"  Endof
            1031  of s" German (Germany)"   Endof
            0     of s" Neutral"            Endof
            ( default )  dup (.) rot
        EndCase
        Type ;

5 CallBack: GetResLang { hExe ResourceType ResourceName Language l  -- f }   Language to LanguageID  false ;
: ResourceLanguage ( ResourceName ResourceType -- )
        2>r 0 ['] GetResLang 2r> hExe call EnumResourceLanguages drop LanguageID ;

5 CallBack: EnumResLang { hExe ResourceType ResourceName Language l  -- f }
        ."   Language: "  Language .Language  true ;
: EnumResourceLanguages ( ResourceName ResourceType -- )
        2>r 0 ['] EnumResLang 2r> hExe call EnumResourceLanguages drop ;

4 CallBack: EnumResName { hExe ResourceType ResourceName l  -- f }
        cr ." ID: "  ResourceName .ResourceName  ResourceName ResourceType EnumResourceLanguages  true ;
: EnumResourceNames ( ResourceType -- )
        >r 0 ['] EnumResName r> hExe call EnumResourceNames drop ;

0 value ResourceNumber
3 CallBack: EnumResType { hExe ResourceType l  -- f }   1 +to ResourceNumber
        cr cr  ResourceType dup  .ResourceType  EnumResourceNames  true ;
: EnumResources ( -- )
        0 ['] EnumResType hExe call EnumResourceTypes drop ;

: CloseSourceFile ( -- )   hExe call FreeLibrary drop  0 to hExe ;

external

: SourceFile ( s" Filename" -- ) 
        2dup SourceFileName place  asciiz call LoadLibrary to hExe
        hExe 0= IF  SourceFileName SourceFileError  abort  THEN ;

: ListResources ( s" Filename" -- )
        SourceFile
        0 to ResourceNumber
        cr ." Enumerating resources in "  SourceFileName count type
        EnumResources
        CloseSourceFile
        cr  ResourceNumber 0= IF  ." No resources" cr  THEN ;


\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ \\\\\ Copying resources from .exe and .dll files \\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

: EndUpdate ( f -- )   \ TRUE=no changes are made to the executable file, FALSE=the changes are made
        hUpdate call EndUpdateResource drop
        CloseSourceFile ;

: UpdateFile ( -- )   \ ask whether to update resources
        UpdateFileName UpdateMessage  IDYES =
        IF  cr ." Resources updated in " UpdateFileName count type  cr  false
        ELSE  cr ." Update abandoned" cr  true
        THEN EndUpdate ;

: LoadResource ( ID ResourceType -- )
        hExe 0= IF  cr ." No source file to copy from"  abort  THEN
        over hExe call FindResource
        dup hExe call LoadResource call LockResource to ResData
        dup hExe call SizeofResource to ResSize
        IF  drop
        ELSE  LoadResourceError  true EndUpdate  abort
        THEN ;

: UpdateResource ( ID ResourceType -- )
        2dup 2>r ResSize ResData LanguageID
        2r> hUpdate call UpdateResource
        IF    cr .ResourceType  cr  ." ID: " .ResourceName  ."   Size: " ResSize .  cr  
        ELSE  UpdateResourceError  true EndUpdate  abort
        THEN  ( ResData ResSize 64 min dump cr ) ;

: BeginUpdate ( s" UpdateFileName" flag -- )   \ TRUE=existing resources are deleted,
        >r  UpdateFileName place  r>           \ FALSE=the updated executable file includes existing resources 
        UpdateFileName count asciiz call BeginUpdateResource to hUpdate
        hUpdate 0= IF  UpdateFileName UpdateFileError  CloseSourceFile  abort  THEN ;

: ReplaceFile ( s" Filename" -- )   TRUE BeginUpdate ;   \ TRUE=existing resources are deleted

: AddToFile ( s" Filename" -- )   FALSE BeginUpdate ;   \ FALSE=existing resources are kept

: CopyResource ( ID ResourceType -- )
        2dup ResourceLanguage drop  2dup LoadResource  UpdateResource ;

: CopyIcon ( ID -- )
        RT_GROUP_ICON CopyResource
        ResData to GroupResData
        Entries 0 DO  i nID  RT_ICON  CopyResource  LOOP ;

: CopyCursor ( ID -- )
        RT_GROUP_CURSOR CopyResource
        ResData to GroupResData
        Entries 0 DO  i nID  RT_CURSOR  CopyResource  LOOP ;

: CopyBitmap ( ID -- )   RT_BITMAP CopyResource ;


\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ \\\\\ Adding resources from .bmp, .ico and .cur files \\\\\\\\\\\\\\\\\\\\
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

: ReadResFile ( s" filename" -- )
        2dup ResourceFileName place
        r/o open-file IF  ResourceFileName SourceFileError true EndUpdate  abort  THEN  >r
        r@ file-size 2drop to FileSize          \ the bmp length
        Here to FileData
        FileData FileSize r@ read-file 2drop    \ read the bmp file
        r> close-file drop ;                    \ close file

: AddResource ( ID ResourceType s" filename" -- )
        ReadResFile
        FileData to ResData
        FileSize to ResSize
        0 to LanguageID
        UpdateResource
        ;

: AddBitmap ( ID s" filename" -- )
        ReadResFile
        FileData w@ 19778 <> IF  ResourceFileName ResourceFileError  true EndUpdate  abort  THEN
        FileData 14 + to ResData
        FileSize 14 - to ResSize
        0 to LanguageID
        RT_BITMAP UpdateResource
        ;

: IconFileData>ResData ( -- )   \ move group directory data truncating to 14 bytes per entry rather than 16
        Entries 0 DO
            i nDirEntry i 2* +  i nDirEntry 16 move
            i nImageOffset @ GroupResData + i nHotSpot  i nImageAddress 2!   \ store HotSpots and ImageOffsets temporarily at end of file data
            i nImageOffset @ DirEntries + 6 + @  i nPlanes !   \ add Color Planes and Bits per pixel to dir entry
            NextResID i nImageOffset w!   \ replace ImageOffset with ID
        LOOP ;
 
: CursorFileData>ResData ( -- )   \ move group directory data truncating to 14 bytes per entry rather than 16
        Entries 0 DO
            i nDirEntry i 2* +  i nDirEntry 16 move
            i nImageOffset @ 4 - GroupResData + i nHotSpot  i nImageAddress 2!   \ store HotSpots and ImageOffsets temporarily at end of file data
            i nDirEntry c@  i nDirEntry 1+ c@  i nDirEntry 2 + w!  i nDirEntry w!   \ width and height change to 2 bytes each
            i nImageOffset @ DirEntries + 6 + @  i nPlanes !   \ add Color Planes and Bits per pixel to dir entry
            NextResID i nImageOffset w!   \ replace ImageOffset with ID
            4  i nBytesInRes  +!   \ add 4 to ResSize to allow for Hotspot
        LOOP ;
 
: AddIcon ( ID s" filename" -- )
        ReadResFile
        FileData @ 65536 <> IF  ResourceFileName ResourceFileError  true EndUpdate  abort  THEN
        FileData to GroupResData
        IconFileData>ResData
        GroupResData to ResData
        GroupResSize to ResSize
        0 to LanguageID
        RT_GROUP_ICON UpdateResource
        Entries 0 DO  i nSize to ResSize  i nImageAddress 2@ swap to ResData drop
            i nID RT_ICON UpdateResource  LOOP ;

: AddCursor ( ID s" filename" -- )
        ReadResFile
        FileData @ 131072 <> IF  ResourceFileName ResourceFileError  true EndUpdate  abort  THEN
        FileData to GroupResData
        CursorFileData>ResData
        GroupResData to ResData
        GroupResSize to ResSize
        0 to LanguageID
        RT_GROUP_CURSOR UpdateResource
        Entries 0 DO  i nSize to ResSize  i nID  i nImageAddress 2@ swap to ResData ResData !
            RT_CURSOR UpdateResource  LOOP ;

in-application

[then]

\ ------------------------------------------------------------------------------
\ Some helper words for adding the Icon for a Application
\ ------------------------------------------------------------------------------

in-application

create AppIcon max-path allot

in-system
external

winver winnt4 < [if]

\ Add the Icon filename1 to the Application filename2
: AddAppIcon    ( s" filename1" s" filename2" -- )
        2drop AppIcon place ;

[else]

\ returns true if we can add the icon to the file
: AddAppIcon?   ( addr len -- f )
        r/w open-file 0= dup
        if   swap close-file drop
        else nip
        then ;

\ Add the Icon filename1 to the Application filename2
: AddAppIcon    ( s" filename1" s" filename2" -- )
	2swap "path-file drop 2swap \ look in the Forth-search-path for the icon-file
        2dup AddAppIcon?
        if   ReplaceFile 
             2dup 101 -rot AddIcon
             false EndUpdate
        else 2drop 
        then AppIcon place ;

[then]

in-application

[undefined] LoadIconFile [if]
: LoadIconFile  ( adr len -- hIcon ) \ load an icon from a ico-file
                asciiz >r LR_LOADFROMFILE 0 0 IMAGE_ICON r> NULL call LoadImage ;
[then]

\ Load the Icon for the application
: LoadAppIcon   ( -- hIcon )
        101 appinst call LoadIcon ?dup 0= 
        if   AppIcon count LoadIconFile
        then ;

module

\s \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ \\\\\ Examples \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

\ If you want to add resources to Win32For.exe make a copy of it first then run the copy to
\ fload this file because you can't add resources into Win32For.exe while it is running.

: L1    s" Win32For.exe" ListResources ;
: L2    s" zip32.dll" ListResources ;
: L3    s" w32fconsole.dll" ListResources ;
: L4    s" w32fHtmlDisplay.dll" ListResources ;
: L5    s" w32fScintilla.dll" ListResources ;
: L6    s" Wincon.dll" ListResources ;
: L7    s" Kernel.bin" ListResources ;

: C0    \ add WinEd.ico to Win32For.exe, deleting all other resources
        s" Win32For.exe" ReplaceFile
        101 s" src\res\WinEd.ico" AddIcon
        UpdateFile
        L1
        ;

: C1    \ add Win32For.ico to Win32For.exe, see the icon in explorer change
        s" Win32For.exe" AddToFile
        100 s" src\res\Win32For.ico" AddIcon
        UpdateFile
        L1
        ;

: D1    \ remove all resources from Win32For.exe
        s" Win32For.exe" ReplaceFile
        UpdateFile
        L1 ;

: C2    \ copy all PictureViewer resources   
        s" Kernel.bin" SourceFile
        s" PictureViewer.exe" ReplaceFile
        100 CopyIcon
        101 CopyIcon
        139 CopyIcon
        140 CopyIcon
        141 CopyIcon
        142 CopyIcon
        143 CopyIcon
        144 CopyIcon
        145 CopyIcon
        146 CopyIcon
        147 CopyIcon
        148 CopyIcon
        114 CopyCursor
        115 CopyCursor
        116 CopyCursor
        119 CopyCursor
        120 CopyCursor
        149 CopyCursor
        150 CopyCursor
        151 CopyCursor
        UpdateFile
        s" PictureViewer.exe" ListResources
        ;

: D2    \ remove all resources from PictureViewer.exe
        s" PictureViewer.exe" ReplaceFile
        UpdateFile
        s" PictureViewer.exe" ListResources
        ;

[Win32forth-cvs] win32forth-stc/src primutil.f,1.30,1.31

[Jos v.d.V. <jo...@us...>]

Update of /cvsroot/win32forth/win32forth-stc/src
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv14075

Modified Files:
	primutil.f 
Log Message:
Jos: Added  highlevel 3reverse

Index: primutil.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/primutil.f,v
retrieving revision 1.30
retrieving revision 1.31
diff -C2 -d -r1.30 -r1.31
*** primutil.f	3 May 2007 20:52:23 -0000	1.30
--- primutil.f	5 May 2007 19:01:05 -0000	1.31
***************
*** 112,115 ****
--- 112,119 ----
  in-application
  
+ : 3REVERSE   ( n1 n2 n3 -- n3 n2 n1 ) \ exchange first and third items on data stack
+                 swap rot ;
+ 
+ 
  : ROLL          ( n1 n2 .. nk k -- n2 n3 .. nk n1 )
  \  Rotate k values on the stack, bringing the deepest to the top.

[Win32forth-cvs] win32forth-stc/demos MDIDialogExample.f, NONE, 1.1 MDIExample.f, NONE, 1.1

[George H. <geo...@us...>]

Update of /cvsroot/win32forth/win32forth-stc/demos
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv14063/win32forth-stc/demos

Added Files:
	MDIDialogExample.f MDIExample.f 
Log Message:
gah:Added more demos and MDI files

--- NEW FILE: MDIExample.f ---
\ MDIExample.f        Example of an MDI application using EditControls by Rod Oakford
\                     Icon resource 100 and 101 needed in .exe
\                     otherwise default windows icon used

anew -MDIExample.f

INTERNAL
EXTERNAL

\- Turnkeyed?   : Turnkeyed? ( -- f )   sys-free 0= ;   \ for compatability with v5.2
[UNDEFINED] Messagebox [IF]
: MessageBox  ( szText szTitle style hOwnerWindow -- result )
        >r  -rot swap r>
        Call MessageBox ;   [THEN]

\ *D doc\classes\
\ *> mdi
\ *S Example (demos\MdiExample.f)
\ *+

Needs MDI
Needs Menu.f

0 value CurrentWindow
0 value ActiveChild
Create CurrentFile 256 allot


\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\       Messages and Dialogs
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

: ?SaveMessage ( -- n )   \ IDYES, IDNO or IDCANCEL
        s" Do you want to save " pad place
        CurrentFile count "to-pathend" pad +place
        s"  ?" pad +place  pad +NULL
        pad 1+ z" MDI Example"
        [ MB_ICONEXCLAMATION  MB_YESNOCANCEL or ] literal
        NULL MessageBox ;


\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\       Simple TextBox to place on child windows
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

:Class TextBox   <Super Control

:M Start: ( Parent -- )
        to Parent
        z" EDIT" Create-Control
        ;M

:M WindowStyle: ( -- style )
        [ WS_VISIBLE WS_CHILD or ES_MULTILINE or WS_VSCROLL or WS_HSCROLL or ] literal
        ;M

;Class


\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ Define application menu
\
\ The frame window of an MDI application should include
\ a menu bar with a Window menu. The Window menu should
\ include command items that arrange the child windows
\ within the client window or that close all child windows.
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

IdCounter 100 + value (NewID) \ Make sure there's a reasonable difference
: NewID ( <name> -- )   defined
        IF  drop
        ELSE (NewID)  dup 1+ to (NewID) swap count "constant
        THEN ;

NewID IDM_NEW
NewID IDM_CLOSE
NewID IDM_EXIT
NewID IDM_TILE
NewID IDM_ARRANGE
NewID IDM_CASCADE
NewID IDM_CLOSE_ALL
NewID IDM_OPEN_FILE

Create MenuTable (NewID) 200 - 4 * allot
: DoMenu ( ID -- )   200 - 4 * MenuTable + @ ?dup IF execute THEN ;
: SetMenu ( ID -- )  last @ name>  swap 200 - 4 * MenuTable + ! ;

MENUBAR MDIMenu
    POPUP "&File"
        MENUITEM     "&New...   \tCtrl+N"     IDM_NEW               DoMenu ;
        MENUITEM     "C&lose"                 IDM_CLOSE             DoMenu ;
\     9 RECENTFILES   RecentFiles             IDM_OPEN_FILE         DoMenu ;
        MENUSEPARATOR
        MENUITEM     "E&xit  \tAlt-F4"        IDM_EXIT              DoMenu ;
    POPUP "&Window"
        MENUITEM     "&Tile"                  IDM_TILE              DoMenu ;
        MENUITEM     "&Arrange"               IDM_ARRANGE           DoMenu ;
        MENUITEM     "Ca&scade"               IDM_CASCADE           DoMenu ;
        MENUITEM     "&Close all"             IDM_CLOSE_ALL         DoMenu ;
ENDBAR


\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\       Define application window
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

:Object Frame   <Super MDIFrameWindow

:M Classinit: ( -- )
        ClassInit: super
        MDIMenu to CurrentMenu
        ;M

:M WindowMenuNo: ( -- n )   1 ;M   \ the Window menu where the child window titles will be placed

:M WindowStyle: ( -- style )
        WindowStyle: SUPER
        WS_CLIPCHILDREN or
        ;M

:M ExWindowStyle: ( -- exstyle )
        WS_EX_ACCEPTFILES
        ;M

:M WM_DROPFILES { hndl message wParam lParam \ drop$ -- res }
        SetForegroundWindow: self
        MAXSTRING LocalAlloc: drop$
        0 0 -1 wParam Call DragQueryFile
        0 DO
            MAXCOUNTED drop$ 1+ i wParam Call DragQueryFile drop$ c!
            drop$ IDM_OPEN_FILE DoMenu
        LOOP
        wParam Call DragFinish
        ;M

:M MinSize: ( -- width height )   106  0  ;M

:M WindowTitle: ( -- z" )   z" MDI Example"  ;M

:M On_Size: ( h m w -- )
        0 0 Width Height Move: MDIClient
        ;M
(( This is equivalent to  :M WM_SIZE  ( h m w l -- f )   DefFrameProc ;M
   but if space for a Toolbar or StatusBar is needed MDIClient needs to be smaller ))

:M On_Init: ( -- )
        On_Init: super
        100 appinst Call LoadIcon   \ Win32For.ico
        GCL_HICON hWnd Call SetClassLong drop
        ;M

:M OnWmCommand:  ( hwnd msg wparam lparam -- hwnd msg wparam lparam )
        OnWmCommand: Super
        over LOWORD ( Menu ID )  dup 200 (NewID) within   \ intercept Menu commands
        IF  DoMenu  ELSE  drop  THEN
        ;M

:M WM_CLOSE ( h m w l -- res )
        CloseAll: self
        NotCancelled                    \ if we don't cancel the close
        IF
            WM_CLOSE WM: super          \ then just terminate the program
        ELSE
            1                           \ else abort program termination
        THEN
        ;M

:M On_Done: ( -- )
        Turnkeyed? IF  0 call PostQuitMessage drop  THEN
        On_Done: Super
        ;M

;Object


\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\       Define Child Window class
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

:Class MDIChild   <Super MDIChildWindow
    int EditWindow
    256 bytes FileName
    int Modified

:M WindowTitle: ( -- z" )
        CurrentFile count FileName place
        FileName +null  FileName 1+
        ;M

:M WindowStyle: ( -- style )
        WindowStyle: super
        WS_CLIPCHILDREN or
        GetActive: Frame  0= or  IF  WS_MAXIMIZE or  THEN   \ start new child maximised unless
        ;M                                                  \ the active child is not maximised

:M DefaultIcon: ( -- hIcon )
        101 appInst Call LoadIcon   \ App_icon.ico
        ;M

:M Start: ( parent -- )
        New> TextBox to EditWindow
        Start: super
        self start: EditWindow
        0 0 Width Height Move: EditWindow
        SetFocus: EditWindow
        True to Modified
        ;M

:M On_SetFocus: ( -- )              \ A child window can be selected by clicking on it,
        SetFocus: EditWindow        \ selecting it from the Window menu or using CTRL+F6
        EditWindow to CurrentWindow
        self to ActiveChild
        FileName count CurrentFile place CurrentFile +null
        ;M

:M On_Size: ( h m w l -- h m w l )
        0 0 Width Height Move: EditWindow   \ make TextBox fit child window
        ;M

:M On_Close: ( -- f )   \ True = close, False = cancel close
        Modified
        IF
            ?SaveMessage
            Case
                IDCANCEL  Of                 FALSE  Endof
                IDYES     Of                  TRUE  Endof
                ( otherwise IDNO )            TRUE  swap
            EndCase
        ELSE  TRUE
        THEN
        dup  dup to NotCancelled
        IF                                   \ if we don't cancel the close
            GetHandle: self Destroy: Frame   \ close child window first
            EditWindow dispose               \ so we can safely dispose
            self dispose                     \ of both the EditControl
        THEN                                 \ and the child window
        ;M

;Class


\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\       Activate Menu
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

0 value New#
: New ( -- )   1 +to New#  s" File " currentfile place
        New# (.) currentfile +place
        New> MDIChild to ActiveChild
        MDIClientWindow: Frame Start: ActiveChild ;             IDM_NEW SetMenu
: Close ( -- )   GetHandle: ActiveChild CloseChild: Frame ;   IDM_CLOSE SetMenu
: ExitApp ( -- )   bye ;                                       IDM_EXIT SetMenu
: Tile ( -- )   0 Tile: Frame ;                                IDM_TILE SetMenu
: Arrange ( -- )   Arrange: Frame ;                         IDM_ARRANGE SetMenu
: Cascade ( -- )   Cascade: Frame ;                         IDM_CASCADE SetMenu
: CloseAll ( -- )   CloseAll: Frame ;                     IDM_CLOSE_ALL SetMenu
: OpenFile ( File$ -- )   count currentfile place
        New> MDIChild to ActiveChild
        ( File opening stuff )
        MDIClientWindow: Frame Start: ActiveChild ;       IDM_OPEN_FILE SetMenu

\ ********** many menu items not implemented here **********


\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\       Handle MDI Accelerators: ALT+ - (minus), CTRL+ F4, CTRL+ F6
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

: DoMDIMsg ( pMsg f  -- pMsg f )
        dup MDIClient: Frame 0<> and
        IF
            drop dup MDIClient: Frame Call TranslateMDISysAccel 0=
        THEN
        ;
msg-chain chain-add DoMDIMsg


\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\       The word to start the application
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

: go   ( -- )
       zeromenu: mdimenu
       start: Frame
       0 to New#
       New
       Cascade
       Turnkeyed? IF  Begin key drop again  THEN
       ;

\ *-
\ *Z

MODULE

go

cr .( Save MDIExample.exe [Y/N]: )  key  dup emit  dup 121 = swap 89 = or  nostack
    [IF]  ' go turnkey MDIExample  5 pause-seconds  bye  [THEN]

--- NEW FILE: MDIDialogExample.f ---
\ $Id: MDIDialogExample.f,v 1.1 2007/05/05 10:23:53 georgeahubert Exp $
\ G.Hubert Monday, July 26 2004 - 21:52
\ Example of an MDI application using the MDIDialogWindow Class
\ with the MDI Classes by Rod Oakford
\ Icon resource 100 and 101 needed in .exe
\ otherwise default windows icon used

anew -MDIDialogExample.f

Needs MDI
Needs MdiDialog.f
Needs Controls.f
Needs Menu.f

0 value CurrentWindow
0 value ActiveChild
Create CurrentFile 256 allot


\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\       Messages and Dialogs
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

: ?SaveMessage ( -- n )   \ IDYES, IDNO or IDCANCEL
        s" Do you want to save " pad place
        CurrentFile count "to-pathend" pad +place
        s"  ?" pad +place  pad +NULL
        pad 1+ z" MDI Example"
        [ MB_ICONEXCLAMATION  MB_YESNOCANCEL or ] literal
        NULL MessageBox ;

\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ Define application menu
\
\ The frame window of an MDI application should include
\ a menu bar with a Window menu. The Window menu should
\ include command items that arrange the child windows
\ within the client window or that close all child windows.
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\


IdCounter 100 + value (NewID) \ Make sure there's a reasonable difference
: NewID ( <name> -- )   defined
        IF  drop
        ELSE (NewID)  dup 1+ to (NewID) swap count "constant
        THEN ;

NewID IDM_NEW
NewID IDM_CLOSE
NewID IDM_EXIT
NewID IDM_TILE
NewID IDM_ARRANGE
NewID IDM_CASCADE
NewID IDM_CLOSE_ALL
NewID IDM_OPEN_FILE

Create MenuTable (NewID) 200 - 4 * allot
: DoMenu ( ID -- )   200 - 4 * MenuTable + @ ?dup IF execute THEN ;
: SetMenu ( ID -- )  last @ name>  swap 200 - 4 * MenuTable + ! ;

MENUBAR MDIMenu
    POPUP "&File"
        MENUITEM     "&New...   \tCtrl+N"     IDM_NEW               DoMenu ;
        MENUITEM     "C&lose"                 IDM_CLOSE             DoMenu ;
        MENUSEPARATOR
        MENUITEM     "E&xit  \tAlt-F4"        IDM_EXIT              DoMenu ;
    POPUP "&Window"
        MENUITEM     "&Tile"                  IDM_TILE              DoMenu ;
        MENUITEM     "&Arrange"               IDM_ARRANGE           DoMenu ;
        MENUITEM     "Ca&scade"               IDM_CASCADE           DoMenu ;
        MENUITEM     "&Close all"             IDM_CLOSE_ALL         DoMenu ;
ENDBAR


\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\       Define application window
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

:Object Frame   <Super MDIFrameWindow

:M Classinit: ( -- )
        ClassInit: super
        MDIMenu to CurrentMenu
        ;M

:M WindowMenuNo: ( -- n )   1 ;M   \ the Window menu where the child window titles will be placed

:M WindowStyle: ( -- style )
        WindowStyle: SUPER
        WS_CLIPCHILDREN or
        ;M

:M ExWindowStyle: ( -- exstyle )
        WS_EX_ACCEPTFILES
        ;M

:M MinSize: ( -- width height )   106  0  ;M

:M WindowTitle: ( -- z" )   z" MDI Example"  ;M

:M On_Size: ( h m w -- )
        0 0 Width Height Move: MDIClient
        ;M

:M On_Init: ( -- )
        On_Init: super
        100 appinst Call LoadIcon   \ Win32For.ico
        GCL_HICON hWnd Call SetClassLong drop
        ;M

:M OnWmCommand:  ( hwnd msg wparam lparam -- hwnd msg wparam lparam )
        OnWmCommand: Super
        over LOWORD ( Menu ID )  dup 200 (NewID) within   \ intercept Menu commands
        IF  DoMenu  ELSE  drop  THEN
        ;M

:M WM_CLOSE ( h m w l -- res )
        CloseAll: self
        NotCancelled                    \ if we don't cancel the close
        IF
            WM_CLOSE WM: super          \ then just terminate the program
        ELSE
            1                           \ else abort program termination
        THEN
        ;M

:M On_Done: ( -- )
        Turnkeyed? IF  0 call PostQuitMessage drop  THEN
        On_Done: Super
        ;M

;Object

0 value check1

\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\       Define Child Window class
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

:Class MDIChild   <Super MDIDialogWindow
    256 bytes FileName

:M WindowTitle: ( -- z" )
        CurrentFile count FileName place
        FileName +null  FileName 1+
        ;M

:M WindowStyle: ( -- style )
        WindowStyle: super
        WS_CLIPCHILDREN or
        GetActive: Frame  0= or  IF  WS_MAXIMIZE or  THEN   \ start new child maximised unless
        ;M                                                  \ the active child is not maximised

:M DefaultIcon: ( -- hIcon )
        101 appInst Call LoadIcon   \ App_icon.ico
        ;M

:M On_SetFocus: ( -- )              \ A child window can be selected by clicking on it,
                                    \ selecting it from the Window menu or using CTRL+F6
        ;M

:M On_Close: ( -- f )   \ True = close, False = cancel close
        GetHandle: self Destroy: Frame
        self dispose true
        ;M

  EditControl Edit_1     \ an edit window
StaticControl Text_1     \ a static text window
ButtonControl Button_1   \ a button
ButtonControl Button_2   \ another button
 CheckControl Check_1    \ a check box
 RadioControl Radio_1    \ a radio button
 RadioControl Radio_2    \ another radio button

: CloseSample   ( -- )
                Close: [ self ] ;

:M On_Init:     ( -- )
                On_Init: super
                self               Start: Check_1
                4 25 60 20          Move: Check_1
                s" Hello"        SetText: Check_1

                self               Start: Radio_1
                80 25 80 20         Move: Radio_1
                s" Hello2"       SetText: Radio_1
                                GetStyle: Radio_1 \ get the default style
                [ WS_GROUP WS_TABSTOP OR ] literal  OR
                                SetStyle: Radio_1 \ Start a group

                self               Start: Radio_2
                80 45 120 20        Move: Radio_2
                s" Hello Again"  SetText: Radio_2

                self               Start: Text_1 \ start up static text
                                GetStyle: Text_1 \ get the default style
                [ WS_GROUP SS_CENTER OR WS_BORDER OR ] literal OR \ start a group and centre
                                SetStyle: Text_1 \ and border to style
                4  4 192 20         Move: Text_1 \ position the window
                s" Sample Text"  SetText: Text_1 \ set the window message

                self               Start: Edit_1
                3 72  60 25         Move: Edit_1
                s" 000,00"       SetText: Edit_1

                IDOK               SetID: Button_1
                self               Start: Button_1
                110 72 36 25        Move: Button_1
                s" OK"           SetText: Button_1
                                GetStyle: Button_1
                BS_DEFPUSHBUTTON OR
                                SetStyle: Button_1

                self               Start: Button_2
                150 72 45 25        Move: Button_2
                s" Beep"         SetText: Button_2
                ['] beep         SetFunc: Button_2
                ;M

:M On_Paint:    ( -- )          \ screen redraw procedure
                0 0 width height LTGRAY FillArea: dc
                ;M

:M ON_COMMAND:  ( hwnd msg wparam lparam -- res )
                over LOWORD ( ID )
                case
                IDOK            of hwnd destroy: frame self dispose         endof
                GetID: Check_1  of GetID: Check_1
                                   IsDlgButtonChecked: self to check1 beep  endof
                endcase 0
                ;M

:M ON_SETFOCUS: ( hwnd msg wparam lparam -- )
                SetFocus: Check_1
                On_SetFocus: Super
                ;M

;Class


\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\       Activate Menu
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

0 value New#
: New ( -- )   1 +to New#  s" File " currentfile place
        New# (.) currentfile +place
        New> MDIChild to ActiveChild
        MDIClientWindow: Frame Start: ActiveChild ;             IDM_NEW SetMenu
: Close ( -- )   GetHandle: ActiveChild CloseChild: Frame ;   IDM_CLOSE SetMenu
: ExitApp ( -- )   bye ;                                       IDM_EXIT SetMenu
: Tile ( -- )   0 Tile: Frame ;                                IDM_TILE SetMenu
: Arrange ( -- )   Arrange: Frame ;                         IDM_ARRANGE SetMenu
: Cascade ( -- )   Cascade: Frame ;                         IDM_CASCADE SetMenu
: CloseAll ( -- )   CloseAll: Frame ;                     IDM_CLOSE_ALL SetMenu
: OpenFile ( File$ -- )   count currentfile place
        New> MDIChild to ActiveChild
        ( File opening stuff )
        MDIClientWindow: Frame Start: ActiveChild ;       IDM_OPEN_FILE SetMenu

\ ********** many menu items not implemented here **********


\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\       Handle MDI Accelerators: ALT+ - (minus), CTRL+ F4, CTRL+ F6
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

: DoMDIMsg ( pMsg f  -- pMsg f )
        dup MDIClient: Frame 0<> and
        IF
            drop dup MDIClient: Frame Call TranslateMDISysAccel 0=
        THEN
        ;
msg-chain chain-add DoMDIMsg


\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\       The word to start the application
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

: go   ( -- )
       zeromenu: mdimenu
       start: Frame
       0 to New#
       New
       Cascade
       Turnkeyed? IF  Begin key drop again  THEN
       ;



go

[Win32forth-cvs] win32forth-stc/src/lib MDI.F, NONE, 1.1 MdiDialog.f, NONE, 1.1

[George H. <geo...@us...>]

Update of /cvsroot/win32forth/win32forth-stc/src/lib
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv14063/win32forth-stc/src/lib

Added Files:
	MDI.F MdiDialog.f 
Log Message:
gah:Added more demos and MDI files

--- NEW FILE: MDI.F ---
(This appears to be a binary file; contents omitted.)

--- NEW FILE: MdiDialog.f ---
\ $Id: MdiDialog.f,v 1.1 2007/05/05 10:23:55 georgeahubert Exp $

\ G.Hubert Saturday, July 17 2004 - 21:07

\ *D doc\classes\
\ *! MdiDialog W32F MdiDialog
\ *T MdiDialog -- Class for MDI windows containing controls.

\ *P MdiDialogWindows can be designed with ForthForm.

\ *P The file MdiDialog.f in the src\lib folder is not loaded by default. The file Mdi.f
\ ** is automatically loaded with this file if not already included.

needs mdi.f

\ *S Glossary

:CLASS MdiDialogWindow   <Super MdiChildWindow
\ *G Base class for Multi-document interface (MDI) child windows that contain controls.

:M ClassInit: ( -- )
\ *G Initialise the class.
        ClassInit: super +dialoglist ;M

:M ~:    ( -- )
\ *G Destructor method called when a dynamic object is freed by DISPOSE.
       -dialoglist ~: super ;M

;Class

\ *Z

[Win32forth-cvs] win32forth-stc/demos FILEDUMP.F, NONE, 1.1 ListViewDemo.f, NONE, 1.1 WINDILOG.F, NONE, 1.1

[George H. <geo...@us...>]

Update of /cvsroot/win32forth/win32forth-stc/demos
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv9931/win32forth-stc/demos

Added Files:
	FILEDUMP.F ListViewDemo.f WINDILOG.F 
Log Message:
gah:Added more demos

--- NEW FILE: WINDILOG.F ---
\ $Id: WINDILOG.F,v 1.1 2007/05/04 08:09:36 georgeahubert Exp $

\ WINDILOG.F    Example of a user created Dialog        by Freidrich Prinz

\ Modified for Win32Forth by Tom Zimmer

Require Controls.f

:OBJECT EditSample <SUPER WINDOW

      ListControl List_1     \ a list box
 ComboListControl CbList_1   \ a combo list box
     GroupControl Group_1    \ a frame around a group
      EditControl Edit_1     \ an edit window
    StaticControl Text_1     \ a static text window
    ButtonControl Button_1   \ a button
     CheckControl Check_1    \ a check box
     RadioControl Radio_1    \ a radio button
     RadioControl Radio_2    \ another radio button

:M ClassInit:   ( -- )
                ClassInit: super
                ;M

:M ExWindowStyle: ( -- style )
                ExWindowStyle: SUPER
                ;M

:M WindowStyle: ( -- style )
                WindowStyle: SUPER
                WS_BORDER OR
                WS_OVERLAPPED OR
                ;M

:M WindowTitle: ( -- title )
                z" " ;M

:M StartSize:   ( -- width height )
                300 350 ;M

:M StartPos:    ( -- x y )
                30 30 ;M

:M Close:       ( -- )
\                GetText: Edit_1  cr type cr
                Close: SUPER
                ;M

:M On_Init:     ( -- )
                self                Start: Check_1
                4 25 60 20           Move: Check_1
                s" Hello"         SetText: Check_1

                self                Start: Radio_1
                100 75 130 20        Move: Radio_1
                s" Hello Again 1" SetText: Radio_1
                WS_GROUP           +Style: Radio_1 \ Start a group

                self                Start: Radio_2
                100 95 130 20        Move: Radio_2
                BS_CENTER          +Style: Radio_2 \ and centering
                s" Hello Again 2" SetText: Radio_2

                self                Start: Group_1
                90 55 140 70         Move: Group_1
                s" Radios"        SetText: Group_1

                self                Start: List_1
                4 140 100 60         Move: List_1
                0 0 LB_RESETCONTENT GetID: List_1 SendDlgItemMessage: self drop
z" Ola1 " 0 LB_ADDSTRING    GetID: List_1 SendDlgItemMessage: self drop
z" Ola2 " 0 LB_ADDSTRING    GetID: List_1 SendDlgItemMessage: self drop
z" Ola3 " 0 LB_ADDSTRING    GetID: List_1 SendDlgItemMessage: self drop

                self                Start: CbList_1
                4 220 100 90         Move: CbList_1
                0 0 CB_RESETCONTENT GetID: CbList_1 SendDlgItemMessage: self drop
z" Ola4 " 0 CB_ADDSTRING    GetID: CbList_1 SendDlgItemMessage: self drop
z" Ola5 " 0 CB_ADDSTRING    GetID: CbList_1 SendDlgItemMessage: self drop
z" Ola6 " 0 CB_ADDSTRING    GetID: CbList_1 SendDlgItemMessage: self drop
z" Ola7 " 0 CB_ADDSTRING    GetID: CbList_1 SendDlgItemMessage: self drop
z" Ola8 " 0 CB_ADDSTRING    GetID: CbList_1 SendDlgItemMessage: self drop
z" Ola9 " 0 CB_ADDSTRING    GetID: CbList_1 SendDlgItemMessage: self drop
                0 0 CB_SETCURSEL    GetID: CbList_1 SendDlgItemMessage: self drop

                self                Start: Text_1 \ start up static text
                WS_GROUP           +Style: Text_1 \ End a group
                SS_CENTER          +Style: Text_1 \ and centering
                WS_BORDER          +Style: Text_1 \ and border to style
                4  4 192 20          Move: Text_1 \ position the window
                s" Sample Text"   SetText: Text_1 \ set the window message

                self                Start: Edit_1
                3 72  60 25          Move: Edit_1
                s" 000,00"        SetText: Edit_1

                IDOK                SetID: Button_1
                self                Start: Button_1
                126 172 70 25        Move: Button_1
                s" OK"            SetText: Button_1
                                 GetStyle: Button_1
                BS_DEFPUSHBUTTON   +Style: Button_1
                ;M

:M On_Paint:    ( -- )          \ screen redraw procedure
                0 0 StartSize: self LTGRAY FillArea: dc
                ;M

:M WM_COMMAND   ( hwnd msg wparam lparam -- res )
        over LOWORD ( ID )
        case
                IDOK            of Close: self          endof
                GetID: Check_1  of GetID: Check_1 IsDlgButtonChecked: self
                                   if      beep
                                   then                 endof
        endcase
        0 ;M

;OBJECT

: DEMO          ( -- )
                Start: EditSample ;

cr .( Type DEMO to run the dialog demo. )


--- NEW FILE: FILEDUMP.F ---
\ FILEDUMP.F    An example to use the scroll bar by Jih-tung Pai, 6/23/96

comment:
        It's a simple example to use the vertical scroll bar. The program is
based on WINBROWS.F. It can dump the file in HEX format just like DUMP does
to memory.

To use it--
1. type "fload filedump" to load the file
2. type "dump-file"

comment;

Require WinMsg.f
Require xfiledlg.f

only forth also definitions hidden also forth

FileOpenDialog filedump "Dump File" "All Files|*.*|"

:object dump-window <super window

int screen-cols
int screen-rows

Font fdFont

int cur-first-line \ current first line position
0 value first-line#    \ first line number
200 value last-line#   \ last line number
last-line# 20 - value last-top-line#
create cur-filename max-path allot
16 value bytes/line
0 value file-len \ length of the whole file
0 value file-ptr \ address of the memory for file

:m home: ( -- )
        first-line# to cur-first-line paint: self ;m

: "open-file    ( a1 n1 -- )
                2dup r/o open-file 0=
                if      Home: self
                        StartPos: self
                        200 + swap 200 + swap message-origin
                        s" Reading Text File..." _"message
                        >r 127 min cur-filename place
                        \ release/allocate the text buffer
                        file-ptr ?dup if free drop then
                        r@ file-size 2drop to file-len
                        file-len bytes/line / 1+ bytes/line * dup
                        malloc to file-ptr
                        bytes/line - file-ptr + bytes/line erase  \ erase the etra memory
                        \ read the file into memory
                        file-ptr file-len r@ read-file drop
                        to file-len
                        r> close-file drop
                        message-off
                        0 to cur-first-line
                        file-len bytes/line / 1+ to last-line#
                        cur-filename count settitle: self
                else    drop 2drop
                then    ;

: load-file     ( -- )
                gethandle: self Start: filedump dup c@
                if      count "open-file
                else    drop abort" No file selected"
                then    ;

\ ' load-file is load-file-defer

:M On_Init:     ( -- )
                On_Init: super
                 8  Width: fdFont
                14 Height: fdFont
  s" Courier" SetFaceName: fdFont
                   Create: fdFont
                load-file
                ;M

:m on_size: ( w -- )
        width char-width
        / to screen-cols
        height char-height
        / to screen-rows
        last-line# screen-rows - 0max to last-top-line#
        \ set the vertical scroll limits
        false last-top-line# first-line# SB_VERT
        GetHandle: self Call SetScrollRange drop

        ;m

:m startpos: 0 0 ;m

:m startsize: 75 char-width *  20 char-height * ;m

create line-buf 80 allot

: H.N.str       ( n1 n2 -- adr len )    \ display n1 a s a hex number of n2 digits
                BASE @ >R HEX >R
                0 <# R> 0 ?DO # LOOP #>
                R> BASE ! ;

: dump-line ( i -- adr len )
        bytes/line *
        dup 6 h.n.str line-buf place
        spcs 2 line-buf +place
        file-ptr + dup dup bytes/line + swap
        ?do i c@ 2 h.n.str line-buf +place
                spcs 1 line-buf +place
        loop bytes/line line-buf +place
        line-buf count ;

:m on_paint: ( -- )
                SaveDC: dc                      \ save device context
                Handle: fdFont SetFont: dc      \ set the font to be used
                screen-rows 0
                do 0 char-height i *
                        i cur-first-line + dup last-line# >
                        if  drop spcs 80
                        else dump-line
                        then textout: dc
                loop
                RestoreDC: dc
                ;m

:M WindowStyle: ( -- style )            \ return the window style
                WindowStyle: super
                WS_VSCROLL or           \ add vertical scroll bar
                ;M
:m vposition: ( n -- ) \ move to position n
        0max last-top-line# min
        to cur-first-line paint: self ;m

:m vscroll: ( n -- ) \ move n lines up or down
        cur-first-line + vposition: self ;m

:m end: ( -- ) \ move to end, in this case it's 100 bytes down to pad
        last-top-line# to cur-first-line paint: self ;m

:m vpage: ( n -- )  \ down or up n pages
        screen-rows 1- * vscroll: self ;m

:M WM_VSCROLL   ( h m w l -- res )
                swap word-split >r
        CASE
                SB_BOTTOM        of          End: self   endof
                SB_TOP           of         Home: self   endof
                SB_LINEDOWN      of    1 VScroll: self   endof
                SB_LINEUP        of   -1 VScroll: self   endof
                SB_PAGEDOWN      of    1   VPage: self   endof
                SB_PAGEUP        of   -1   VPage: self   endof
                SB_THUMBPOSITION of r@ VPosition: self   endof
                SB_THUMBTRACK    of r@ VPosition: self   endof
        ENDCASE r>drop
        \ position the vertical button in the scroll bar
        TRUE cur-first-line SB_VERT
        GetHandle: self Call SetScrollPos drop

                0 ;M

:m on_done: ( -- )
        file-ptr ?dup
        if free drop
        then
        Delete: fdFont
        on_done: super ;m

;object

: dump-file ( -- )
        start: dump-window ;

\ ***** program end *****

--- NEW FILE: ListViewDemo.f ---
\ Splitter window modified to prevent flicker - May 4th, 2006 Rod
\ ForthForm generated splitter-window template
\ Modify according to your needs
\ A primarly demo to show some interactions with a ListView

Anew -ListViewDemo.f

Needs ListView.f
Needs ChildWnd.f
Needs Menu.f
\ Needs NoConsole.f
\ Needs Resources.f

0 value turnkey?
20 constant FontHeight

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

\ ------------------------------------------------------------------------
\ Define the Listview for the left part of the window.
\ ------------------------------------------------------------------------
:object ListViewLeft <super ListView

:M WindowStyle: ( -- style )
        WindowStyle: super
        [ LVS_REPORT LVS_SHOWSELALWAYS OR LVS_SORTASCENDING or LVS_EDITLABELS or ] literal or
        ;M

:M WndClassStyle: ( -- style )
         \ CS_DBLCLKS only to prevent flicker in window on sizing.
         CS_DBLCLKS ;M

;object

\ ------------------------------------------------------------------------
\ Define the Listview for the lower right part of the window.
\ ------------------------------------------------------------------------
:object ListViewRightBottom <super ListView

:M WindowStyle: ( -- style )
        WindowStyle: super
        [ LVS_REPORT  LVS_SHOWSELALWAYS OR LVS_EDITLABELS or ] literal or
        ;M

:M WndClassStyle: ( -- style )
         \ CS_DBLCLKS only to prevent flicker in window on sizing.
         CS_DBLCLKS ;M

;object

\ ------------------------------------------------------------------------
\ Define the Window for the upper right part of the window.
\ ------------------------------------------------------------------------
: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 WndClassStyle: ( -- style )
         \ CS_DBLCLKS only to prevent flicker in window on sizing.
         CS_DBLCLKS ;M

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

:M On_size:     ( -- )
        \ need to repaint in this child-window as the position of the
        \ text depends on its size
        Paint: self ;M

:M On_Paint:    ( -- )
        SaveDC: dc                     \ save device context
        GetSize: Self white Fillarea: dc
        Out$ c@ 0<>
        if
             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
        then
        RestoreDC: dc
        ;M

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

;Object

\ ------------------------------------------------------------------------
\ Define the left part of the splitter window.
\ ------------------------------------------------------------------------
:Object LeftPane        <Super Child-Window

int SelectedItemLeft
LV_ITEM LvItem

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

:M WndClassStyle: ( -- style )
         \ CS_DBLCLKS only to prevent flicker in window on sizing.
         CS_DBLCLKS ;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

: 0GetParmsItem ( 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 ;

: GetParmsItem  ( nItem  - Z$text Lparm flNew )
        >r LVIF_TEXT LVIF_PARAM or SetMask: LvItem
        out$: RightTopPane SetpszText: LvItem
        maxstring SetcchTextMax: LvItem
        r@ SetiItem: LvItem
        Addr: LvItem GetItem: ListViewLeft drop  out$: RightTopPane
        GetlParam: LvItem r@ SelectedItemLeft <>
        if   r> to SelectedItemLeft true
        else r>drop 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:       ( parent -- )
        start: super
        -1 to SelectedItemLeft
        Self start: ListViewLeft
        ;M

;Object

\ ------------------------------------------------------------------------
\ Define the right part of the splitter window.
\ ------------------------------------------------------------------------
:Object RightBottomPane        <Super Child-Window

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

:M WndClassStyle: ( -- style )
         \ CS_DBLCLKS only to prevent flicker in window on sizing.
         CS_DBLCLKS ;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:       ( Parent -- )
        start: super
        Self start: ListViewRightBottom
        ;M

;Object

\ ------------------------------------------------------------------------
\ Define the menubar for the main window.
\ ------------------------------------------------------------------------
MENUBAR TestBar
    POPUP "&File"
        MENUITEM     "Bye"    bye ;
ENDBAR


\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ \\\\\ Splitter window \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

:Object Splitter <Super child-window

:M WindowStyle: ( -- style )   \ return the window style
        WindowStyle: super
        [ WS_DISABLED WS_CLIPSIBLINGS or ] literal or
        ;M

:M WndClassStyle: ( -- style )
         \ CS_DBLCLKS only to prevent flicker in window on sizing.
         CS_DBLCLKS ;M

:M On_Paint: ( -- )            \ screen redraw method
        0 0 Width Height LTGRAY FillArea: dc
        ;M

;Object

200 value LeftWidth
  2 value thickness
 30 value RightTopHeight

\ ------------------------------------------------------------------------
\ Define the the splitter window (this is the main window).
\ ------------------------------------------------------------------------
:Object SplitterWindow        <Super Window

0 value ToolBarHeight    \ set to height of toolbar if any
0 value StatusBarHeight  \ set to height of status bar if any

int dragging?
int mousedown?

: LeftHeight            ( -- n )
        Height StatusBarHeight - ToolBarHeight - ;

: RightBottomHeight     ( -- n )
        Height StatusBarHeight - ToolBarHeight - RightTopHeight - ;

: position-windows ( -- )
        0  ToolBarHeight  LeftWidth  LeftHeight  Move: LeftPane
        LeftWidth thickness +  ToolBarHeight  Width LeftWidth thickness + -  RightTopHeight  Move: RightTopPane
        LeftWidth thickness +  ToolBarHeight RightTopHeight +  Width LeftWidth thickness + -  RightBottomHeight  Move: RightBottomPane
        LeftWidth  ToolBarHeight  thickness  LeftHeight  Move: Splitter
        self OnPosition ;

: InSplitter?   ( -- f1 )   \ is cursor on splitter window
        hWnd get-mouse-xy
        0 height within
        swap  LeftWidth dup thickness + within  and ;

\ mouse click routines for Main Window to track the Splitter movement

: DoSizing      ( -- )
        mousedown? dragging? or 0= ?EXIT
        mousex ( 1+ ) width min  thickness 2/ -  to LeftWidth
        position-windows
        WINPAUSE ;

: On_clicked    ( -- )
        mousedown? 0= IF  hWnd Call SetCapture drop  THEN
        true to mousedown?
        InSplitter? to dragging?
        DoSizing ;

: On_unclicked ( -- )
        mousedown? IF  Call ReleaseCapture drop  THEN
        false to mousedown?
        false to dragging? ;

: On_DblClick ( -- )
        false to mousedown?
        InSplitter? 0= ?EXIT
        LeftWidth 8 >
        IF      0 thickness 2/ - to LeftWidth
        ELSE    132 Width 2/ min to LeftWidth
        THEN
        position-windows
        ;

:M WM_SETCURSOR ( h m w l -- )
        hWnd get-mouse-xy
        ToolBarHeight dup LeftHeight + within
        swap  0 width within and
        IF  InSplitter? IF  SIZEWE-CURSOR   ELSE  arrow-cursor  THEN  1
        ELSE  DefWindowProc: self
        THEN
        ;M

:M Classinit:   ( -- )
        ClassInit: super   \ init super class
        TestBar to CurrentMenu
        ['] On_clicked     SetClickFunc: self
        ['] On_unclicked   SetUnClickFunc: self
        ['] DoSizing       SetTrackFunc: self
        ['] On_DblClick    SetDblClickFunc: self
        ;M

:M WindowHasMenu: ( -- f )
                true ;M

:M WindowStyle: ( -- style )
                WindowStyle: Super
                WS_CLIPCHILDREN or ;M

:M WndClassStyle: ( -- style )
                \ CS_DBLCLKS only to prevent flicker in window on sizing.
                CS_DBLCLKS
                ;M

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

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

:M On_Init:     ( -- )
                self Start: LeftPane
                self Start: RightTopPane
                self Start: RightBottomPane
                self Start: Splitter
                self OnInit    \ perform user function
                ;M

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

LV_COLUMN lvc
:M 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  drop

        LVCF_FMT LVCF_WIDTH LVCF_TEXT LVCF_SUBITEM or or or   Setmask: lvc
        LVCFMT_LEFT                                            Setfmt: lvc
        120                                                     Setcx: lvc

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

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

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

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

LV_ITEM LvItem
: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
        dup>r                   SetiItem:    LvItem  \ Uses the index from "Jack"
        2                       SetiSubItem: LvItem
        z" 2043 VD"             SetpszText:  LvItem
        Addr: LvItem  r>        SetItemText: ListViewRightBottom


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

;Object

: main  ( -- )
        Start: SplitterWindow
        InitListViewColumns: SplitterWindow
        InitListViewItems: SplitterWindow
        true       LVS_EX_FULLROWSELECT SetExtendedStyle: ListViewRightBottom
;
\        turnkey? if MessageLoop bye then  ;

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

[Win32forth-cvs] win32forth-stc/src/lib Listview.f,NONE,1.1

[George H. <geo...@us...>]

Update of /cvsroot/win32forth/win32forth-stc/src/lib
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv9146/win32forth-stc/src/lib

Added Files:
	Listview.f 
Log Message:
gah:Added ListView.f

--- NEW FILE: Listview.f ---
\ $Id: Listview.f,v 1.1 2007/05/04 08:07:46 georgeahubert Exp $

\ ListView.f      ListView control by Prad

require Control.f

anew -ListView.f

cr  .( Loading ListView Class...)

internal
external

( -------------------------------------------------------------------)
( 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 ) hwndFrom ;M
:M GetidFrom:   ( -- idFrom )   idFrom   ;M
:M Getcode:     ( -- code )     code     ;M
:M SethwndFrom: ( hwndFrom -- ) to hwndFrom ;M
:M SetidFrom:   ( idFrom -- )   to idFrom   ;M
:M Setcode:     ( code -- )     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 )           mask       ;M
:M GetiItem:      ( -- iItem )          iItem      ;M
:M GetiSubItem:   ( -- iSubItem )       iSubItem   ;M
:M Getstate:      ( -- state )          state      ;M
:M GetstateMask:  ( -- stateMask )      stateMask  ;M
:M GetpszText:    ( -- pszText )        pszText    ;M
:M GetcchTextMax: ( -- cchTextMax )     cchTextMax ;M
:M GetiImage:     ( -- iImage )         iImage     ;M
:M GetlParam:     ( -- lParam)          lParam     ;M

:M SetMask:       ( mask -- ) _LV_ITEM /LV_ITEM erase to mask  ;M
:M SetiItem:      ( iItem -- )          to iItem      ;M
:M SetiSubItem:   ( iSubItem -- )       to iSubItem   ;M
:M Setstate:      ( state -- )          to state      ;M
:M SetstateMask:  ( stateMask -- )      to stateMask  ;M
:M SetpszText:    ( pszText -- )        to pszText    ;M
:M SetcchTextMax: ( cchTextMax -- )     to cchTextMax ;M
:M SetiImage:     ( iImage -- )         to iImage     ;M
:M SetlParam:     ( lParam-- )          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 )          mask       ;M
:M GetiItem:       ( -- iItem  )        iItem      ;M
:M GetiSubItem:    ( -- iSubItem )      iSubItem   ;M
:M Getstate:       ( -- state )         state      ;M
:M GetstateMask:   ( -- stateMask )     stateMask  ;M
:M GetpszText:     ( -- pszText )       pszText    ;M
:M GetcchTextMax:  ( -- cchTextMax )    cchTextMax ;M
:M GetiImage:      ( -- iImage )        iImage     ;M
:M GetlParam:      ( -- lParam )        lParam     ;M

:M SetMask:        ( mask -- ) _LV_DISPINFO /LV_DISPINFO erase to mask       ;M
:M SetiItem:       ( iItem -- )         to iItem      ;M
:M SetiSubItem:    ( iSubItem -- )      to iSubItem   ;M
:M Setstate:       ( state -- )         to state      ;M
:M SetstateMask:   ( stateMask -- )     to stateMask  ;M
:M SetpszText:     ( pszText -- )       to pszText    ;M
:M SetcchTextMax:  ( cchTextMax -- )    to cchTextMax ;M
:M SetiImage:      ( iImage -- )        to iImage     ;M
:M SetlParam:      ( lParam -- )        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 )           mask       ;M
:M Getfmt:        ( -- fmt )            fmt        ;M
:M Getcx:         ( -- cx )             cx         ;M
:M GetpszText:    ( -- pszText )        pszText    ;M
:M GetcchTextMax: ( -- cchTextMax )     cchTextMax ;M
:M GetiSubItem:   ( -- iSubItem )       iSubItem   ;M

:M Setmask:       ( mask -- ) _LV_COLUMN /LV_COLUMN erase to mask  ;M
:M Setfmt:        ( fmt -- )            to fmt        ;M
:M Setcx:         ( cx -- )             to cx         ;M
:M SetpszText:    ( pszText -- )        to pszText    ;M
:M SetcchTextMax: ( cchTextMax -- )     to cchTextMax ;M
:M SetiSubItem:   ( iSubItem -- )       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 )         flags       ;M
:M Getpsz:         ( -- psz )           psz         ;M
:M GetlParam:      ( -- lparam )        lparam      ;M
:M GetvkDirection: ( -- vkDirection )   vkDirection ;M

:M Setflags:       ( flags -- )         to flags       ;M
:M Setpsz:         ( psz -- )           to psz         ;M
:M SetlParam:      ( lparam -- )        to lparam      ;M
:M SetvkDirection: ( vkDirection -- )   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 ) flags ;M
:M GetiItem: ( -- iItem ) iItem ;M

:M Setflags: ( flags -- ) to flags ;M
:M SetiItem: ( iItem -- ) 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 ) wVKey  ;M
:M Getflags: ( -- flags ) 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 )           iItem     ;M
:M GetiSubItem:  ( -- iSubItem )        iSubItem  ;M
:M GetuNewState: ( -- uNewState )       uNewState ;M
:M GetuOldState: ( -- uOldState )       uOldState ;M
:M GetuChanged:  ( -- uChanged )        uChanged  ;M
:M GetlParam:    ( -- lParam )          lParam    ;M

:M SetiItem:     ( iItem -- )           to iItem     ;M
:M SetiSubItem:  ( iSubItem -- )        to iSubItem  ;M
:M SetuNewState: ( uNewState -- )       to uNewState ;M
:M SetuOldState: ( uOldState -- )       to uOldState ;M
:M SetuChanged:  ( uChanged -- )        to uChanged  ;M
:M SetlParam:    ( lParam -- )          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 Control

Comment:
    int nmhdr    // NMHDR           nmhdr
    int nmlv     // NM_LISTVIEW     nmlv
    int lvdi     // LV_DISPINFO     lvdi
    int lvkd     // LV_KEYDOWN      lvkd
Comment;

:M Start:               ( Parent -- )
        to Parent
        z" SysListView32" Create-Control
        ;M

( -------------------------------------------------------------------)
( Items and SubItems )

:M DeleteAllItems:    ( -- f ) 0 0 LVM_DELETEALLITEMS SendMessage:Self ;M
:M DeleteItem:        ( iitem -- f ) 0 swap LVM_DELETEITEM SendMessage:Self ;M
:M GetItem:           ( ptem -- f ) 0 LVM_GETITEM SendMessage:Self ;M
:M GetItemCount:      ( -- n ) 0 0 LVM_GETITEMCOUNT SendMessage:Self ;M
:M GetItemSpacing:    ( fsmall -- f ) 0 swap LVM_GETITEMSPACING SendMessage:Self ;M
:M GetItemState:      ( mask i -- f ) LVM_GETITEMSTATE SendMessage:Self ;M
:M GetItemText:       ( pitem iItem -- adr count )   >r dup r>
                      LVM_GETITEMTEXT SendMessage:Self swap 5 cells+ @ swap ;M
:M GetSelectedCount:  ( -- n ) 0 0 LVM_GETSELECTEDCOUNT SendMessage:Self ;M
:M InsertItem:        ( pitem -- index | -1 ) 0 LVM_INSERTITEM SendMessage:Self ;M
:M SetItem:           ( pitem -- index | -1 ) 0 LVM_SETITEM SendMessage:Self ;M
:M SetItemCount:      ( cItems -- ) 0 swap LVM_SETITEMCOUNT SendMessage:Self ;M
:M SetItemState:      ( pitem i -- f ) LVM_SETITEMSTATE SendMessage:Self ;M
:M SetItemText:       ( pitem i -- f ) LVM_SETITEMTEXT SendMessage:Self ;M
:M SetExtendedStyle:  ( fl lvs_ex_style - ) LVM_SETEXTENDEDLISTVIEWSTYLE
                                               SendMessage:SelfDrop    ;M
( -------------------------------------------------------------------)
( Callback Items )

:M GetCallBackMask:   ( -- mask ) 0 0 LVM_GETCALLBACKMASK SendMessage:Self ;M
:M ReDrawItems:       ( iLast iFirst -- f ) LVM_REDRAWITEMS SendMessage:Self ;M
:M SetCallBackMask:   ( mask -- f ) 0 swap LVM_SETCALLBACKMASK SendMessage:Self ;M
:M Update:            ( iItem -- f ) 0 swap LVM_UPDATE SendMessage:Self ;M

( -------------------------------------------------------------------)
( Columns )

:M DeleteColumn:      ( icol -- f ) 0 swap LVM_DELETECOLUMN SendMessage:Self ;M
:M GetColumn:         ( pcol icol -- f ) LVM_GETCOLUMN SendMessage:Self ;M
:M GetColumnWidth:    ( icol -- width|0 ) 0 swap LVM_GETCOLUMNWIDTH SendMessage:Self ;M
:M GetStringWidth:    ( psz -- width|0 ) 0 LVM_GETSTRINGWIDTH SendMessage:Self ;M
:M InsertColumn:      ( pcol icol -- index|-1 ) LVM_INSERTCOLUMN SendMessage:Self ;M
:M SetColumn:         ( pcol icol -- f ) LVM_SETCOLUMN SendMessage:Self ;M
:M SetColumnWidth:    ( cx icol -- ) LVM_SETCOLUMNWIDTH SendMessage:SelfDrop ;M

( -------------------------------------------------------------------)
( Arranging, Sorting and Finding )

:M Arrange:           ( code -- f ) 0 swap LVM_ARRANGE SendMessage:Self ;M
:M FindItem:          ( plvfi iStart -- index|-1 ) LVM_FINDITEM SendMessage:Self ;M
:M GetNextItem:       ( flags iStart -- index|-1 ) LVM_GETNEXTITEM SendMessage:Self ;M
:M SortItems:         ( pfnCompare lParamsort -- f ) LVM_SORTITEMS SendMessage:Self ;M

( -------------------------------------------------------------------)
( Items Positions and Scrolling )

:M EnsureVisible:     ( fPartialOK i -- f ) LVM_ENSUREVISIBLE SendMessage:Self ;M
:M GetCountPerPage:   ( -- n ) 0 0 LVM_GETCOUNTPERPAGE SendMessage:Self ;M
:M GetItemPosition:   ( ppt i -- f ) LVM_GETITEMPOSITION SendMessage:Self ;M
:M GetItemRect:       ( prc i -- f ) LVM_GETITEMRECT SendMessage:Self ;M
:M GetOrigin:         ( lpptOrg -- f ) 0 LVM_GETORIGIN SendMessage:Self ;M
:M GetTopIndex:       ( -- index|0 ) 0 0 LVM_GETTOPINDEX SendMessage:Self ;M
:M GetViewRect:       ( prc -- f ) 0 LVM_GETVIEWRECT SendMessage:Self ;M
:M HitTest:           ( pinfo -- index|-1 ) 0 LVM_HITTEST SendMessage:Self ;M
:M Scroll:            ( dy dx -- f ) LVM_SCROLL SendMessage:Self ;M
:M SetItemPosition:   ( x y i -- f ) >r word-join r> LVM_SETITEMPOSITION SendMessage:Self ;M
:M SetItemPosition32: ( lpptNewPos iItem -- f ) LVM_SETITEMPOSITION32 SendMessage:Self ;M

( -------------------------------------------------------------------)
( Colours )

:M GetBkColor:        ( -- col ) 0 0 LVM_GETBKCOLOR SendMessage:Self ;M
:M GetTextBkColor:    ( -- col ) 0 0 LVM_GETTEXTBKCOLOR SendMessage:Self ;M
:M GetTextColor:      ( -- col ) 0 0 LVM_GETTEXTCOLOR SendMessage:Self ;M
:M SetBkColor:        ( clrBk -- f ) 0 LVM_SETBKCOLOR SendMessage:Self ;M
:M SetTextBkColor:    ( clrText -- f ) 0 LVM_SETTEXTBKCOLOR SendMessage:Self ;M
:M SetTextColor:      ( clrText -- f ) 0 LVM_SETTEXTCOLOR SendMessage:Self ;M

( -------------------------------------------------------------------)
( Miscellaneous )

:M CreateDragImage:   ( lpptUpLeft iItem -- hndl|NULL ) LVM_CREATEDRAGIMAGE SendMessage:Self ;M
:M EditLabel:         ( iItem -- hndl|NULL ) 0 swap LVM_EDITLABEL SendMessage:Self ;M
:M GetEditControl:    ( -- ) 0 0 LVM_GETEDITCONTROL SendMessage:Self ;M
:M GetImageList:      ( iImageList -- hndl|NULL ) 0 swap LVM_GETIMAGELIST SendMessage:Self ;M
:M SetImageList:      ( himl iImageList -- hndl|NULL ) LVM_SETIMAGELIST SendMessage:Self ;M

( -------------------------------------------------------------------)
( -Window Message Processing performed by a list contol- )

Comment:

The following messages are processed by the window procedure of a ListView control.
To intercept a message eg WM_CHAR :-
:M WM_CHAR ( h m w l -- f )
        ( ****Add your code here**** )
        old-WndProc CallWindowProc ;M
Failure to send this message to the old window procedure will stop the control working properly.

WM_CHAR
WM_COMMAND
WM_CREATE
WM_DESTROY
WM_ERASEBKGND
WM_GETDLGCODE
WM_GETFONT
WM_HSCROLL
WM_KEYDOWN
WM_KILLFOCUS
WM_LBUTTONDBLCLK
WM_LBUTTONDOWN
WM_NCCREATE
WM_NOTIFY - processes notification messages from the header control.
            A list view control also sends WM_NOTIFY to its
            owner window when events occur in the control.
WM_NCCREATE
WM_NCDESTROY
WM_PAINT
WM_RBUTTONDOWN
WM_SETFOCUS
WM_SETFONT
WM_SETREDRAW
WM_TIMER
WM_VSCROLL
WM_WINDOWPOSCHANGED
WM_WININICHANGE

Comment;

;Class

( -------------------------------------------------------------------)
( Helper words for WM_NOTIFY handling
( -------------------------------------------------------------------)

: LVN_GetNotifyItem     ( addr -- Item )
        3 cells + @ ;

: LVN_GetNotifySubItem  ( addr -- SubItem )
        4 cells + @ ;

: LVN_GetNotifyNewState ( addr -- NewState )
        6 cells + @ ;

: LVN_GetNotifyOldState ( addr -- OldState )
        7 cells + @ ;

: LVN_GetNotifyChanged  ( addr -- Changed )
        8 cells + @ ;

: LVN_GetNotifyParam    ( addr -- lParam )
        10 cells + @ ;

module

\s  A simple demo:

( -------------------------------------------------------------------)
( -------------------------------------------------------------------)
( Example )
( Get it all started just to see if it works )

see demos\ListViewDemo.f

( -------------------------------------------------------------------)

[Win32forth-cvs] win32forth-stc/src Window.f,1.2,1.3

[George H. <geo...@us...>]

Update of /cvsroot/win32forth/win32forth-stc/src
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv7534/win32forth-stc/src

Modified Files:
	Window.f 
Log Message:
gah:Made TheWndProc a constant for correct working of child windows and apps that register their own window class(es)

Index: Window.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/Window.f,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** Window.f	1 May 2007 07:41:55 -0000	1.2
--- Window.f	4 May 2007 08:03:30 -0000	1.3
***************
*** 222,226 ****
  \ it is found we execute the method, otherwise we just call
  \ DefWindowProc.
! 4 callback: TheWndProc   ( hwnd msg wparam lparam -- res )
          GWL_USERDATA 4 pick Call GetWindowLong  ( object address )
          ?dup 0=
--- 222,226 ----
  \ it is found we execute the method, otherwise we just call
  \ DefWindowProc.
! 4 callback: (WndProc)   ( hwnd msg wparam lparam -- res )
          GWL_USERDATA 4 pick Call GetWindowLong  ( object address )
          ?dup 0=
***************
*** 252,255 ****
--- 252,256 ----
  
  \ 4 callback TheWndProc (wndproc)
+ ' (wndproc) constant TheWndProc \ For consistency with apps.
  
  \ -----------------------------------------------------------------
***************
*** 273,277 ****
  \ Fill in the defaults for the window class.
                  WndClassStyle: [ self ]                            to Style
!                 ['] TheWndProc                                     to wndProc
                  0                                                  to clsExtra
                  4                                                  to wndExtra
--- 274,278 ----
  \ Fill in the defaults for the window class.
                  WndClassStyle: [ self ]                            to Style
!                 TheWndProc                                         to wndProc
                  0                                                  to clsExtra
                  4                                                  to wndExtra

[Win32forth-cvs] win32forth-stc/demos ROMCALC.F,1.1,1.2

[Jos v.d.V. <jo...@us...>]

Update of /cvsroot/win32forth/win32forth-stc/demos
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv8497

Modified Files:
	ROMCALC.F 
Log Message:
Jos: Removed ROLL. Run extend.bat first to run this demo.

Index: ROMCALC.F
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/demos/ROMCALC.F,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** ROMCALC.F	3 May 2007 20:09:03 -0000	1.1
--- ROMCALC.F	3 May 2007 20:54:35 -0000	1.2
***************
*** 186,193 ****
    ;
  
- : ROLL          ( n1 n2 .. nk k -- n2 n3 .. nk n1 )
- \  ****Rotate k values on the stack, bringing the deepest to the top.
-                 DUP>R PICK SP@ DUP CELL+ R> CELLS CELL+ MOVE DROP ;
- 
  : (.rom) ( n x y t -- n%1000^tiefe x+? y | ) \ Paints a number ( 1 and 999 )
                                               \ * 1000^t. Corrects x,y and n.
--- 186,189 ----

[Win32forth-cvs] win32forth-stc/src primutil.f,1.29,1.30

[Jos v.d.V. <jo...@us...>]

Update of /cvsroot/win32forth/win32forth-stc/src
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv8041

Modified Files:
	primutil.f 
Log Message:
Jos: Added ROLL since it is ANS

Index: primutil.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth-stc/src/primutil.f,v
retrieving revision 1.29
retrieving revision 1.30
diff -C2 -d -r1.29 -r1.30
*** primutil.f	3 May 2007 09:00:02 -0000	1.29
--- primutil.f	3 May 2007 20:52:23 -0000	1.30
***************
*** 112,115 ****
--- 112,119 ----
  in-application
  
+ : ROLL          ( n1 n2 .. nk k -- n2 n3 .. nk n1 )
+ \  Rotate k values on the stack, bringing the deepest to the top.
+                 DUP>R PICK SP@ DUP CELL+ R> CELLS CELL+ MOVE DROP ;
+ 
  : 2constant     ( n m "name" )
                  create , ,

[Win32forth-cvs] win32forth-stc/demos WINCLOCK.F,NONE,1.1

[Jos v.d.V. <jo...@us...>]

Update of /cvsroot/win32forth/win32forth-stc/demos
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv32005

Added Files:
	WINCLOCK.F 
Log Message:
Jos: Again an other demo. The backwards compatabillty is very good. Just include a few lines with the needed lines and it works.

--- NEW FILE: WINCLOCK.F ---
\ GCLOCK.SEQ  A simple Graphic Clock program  by Tom Zimmer & Robert Smith

Needs Window.f
Needs Menu.f
Needs Childwnd.f

only forth also definitions

1280 value screen-mwidth
1024 value screen-mheight
400 to screen-width
300 to screen-height

\ ---------------------------------------------------------------
\       Define the BIT-WINDOW global drawing functions
\ ---------------------------------------------------------------

Windc demo-dc

  2 value bit-originx           \ we have a two pixel border around the bitmap
  2 value bit-originy
  0 value VGA-X                 \ VGA x coordinate in pixels
  0 value VGA-Y                 \ VGA y coordinate in pixels

-1 value prev-x
-1 value prev-y

: new-point-chk ( x y -- x y true | false )
        0max screen-height 4 - min swap 0max screen-width 4 - min swap
        bit-originy + swap bit-originx +  swap
        over prev-x = over prev-y = and
        if      2drop false ( don't draw )
        else    2dup to prev-y
                     to prev-x true ( do draw )
        then ;

: moveto        ( x y -- )
                new-point-chk
                if
                        MoveTo: demo-dc
                then    ;

: lineto        ( x y -- )
                new-point-chk
                if
                        LineTo: demo-dc
                then    ;

: line          ( x1 y1 x2 y2 -- )
                2swap moveto lineto ;

: line-color    ( color_object -- )
                LineColor: demo-dc ;

\ ---------------------------------------------------------------
\       Define the BIT-WINDOW window class
\ ---------------------------------------------------------------

:Class bit-window  <super child-window

int vga-bitmap

:M On_Paint:    ( -- )
                SRCCOPY 0 0 GetHandle: demo-dc GetSize: self 0 0 BitBlt: dc
                ;M

:M Clear:       ( -- )
                0 0 screen-mwidth screen-mheight BLACK FillArea: demo-dc
                ;M

:M WM_CREATE    ( hwnd msg wparam lparam -- res )
                get-dc
                0 call CreateCompatibleDC PutHandle: demo-dc
                screen-mwidth screen-mheight CreateCompatibleBitmap: dc
                to vga-bitmap
                vga-bitmap             SelectObject: demo-dc drop
                OEM_FIXED_FONT    SelectStockObject: demo-dc drop
                WHITE_PEN         SelectStockObject: demo-dc drop
                BLACK                    SetBkColor: demo-dc
                WHITE                  SetTextColor: demo-dc
                0 0 screen-mwidth screen-mheight BLACK FillArea: demo-dc
                release-dc
                0 ;M

:M On_Done:     ( -- )
                vga-bitmap call DeleteObject drop
                0 to vga-bitmap
                On_Done: super
                ;M

;Class

\ ---------------------------------------------------------------
\ Menu and push button support
\ ---------------------------------------------------------------

MENUBAR Demo-Menu-bar

    POPUP "&File"
        MENUITEM     "E&xit          \tAlt-F4"  bye ;

ENDBAR

:Object GCLOCK  <super window

 bit-window vga-bit-window

 0 constant marginSize  \ sets the clock white margin size in pixels

 marginSize constant bitorigx
 marginSize constant bitorigy

 bitorigx marginSize + 1+ constant bitrightmargin
 bitorigx marginSize + 1+ constant bitbottommargin

:M On_Init:     ( -- )          \ initialize the class
                On_Init: super                  \ first init super class
                2    SetId: vga-bit-window      \ then the child window
                self Start: vga-bit-window      \ then startup child window
\                Demo-menu-bar  SetMenuBar:  self
                ;M

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

:M WM_CLOSE     ( h m w l -- res )
                WM_CLOSE WM: Super
                bye
                0 ;M

:M Refresh:     ( -- )
                Paint: vga-bit-window
                ;M

:M StartSize:   ( -- width height )     \ starting window size
                480 480

                ;M

:M StartPos:    ( -- x y )              \ starting postion on screen
                CenterWindow: Self
                ;M

:M MinSize:     ( -- width height )     \ minimum window size
                100 100
                ;M

:M MaxSize:     ( -- width height )     \ maximum window size
                screen-mwidth screen-mheight
                ;M

:M WindowTitle: ( -- Zstring )          \ window caption
                z" WinClock"
                ;M

\ the l parameter has already been removed by WINDOW.F, and put
\ into Height and Width

:M On_Size:     ( h m w -- )                  \ handle resize message
                Clear: vga-bit-window
                bitorigx bitorigy
                Width  bitrightmargin  - dup to screen-width
                Height bitbottommargin - dup to screen-height
                Move: vga-bit-window
                ;M

;Object

: unload-clock  ( -- )
                DestroyWindow: GCLOCK ;

unload-chain chain-add-before unload-clock


create sintbl
          0 ,    25 ,    49 ,    74 ,    97 ,   120 ,   141 ,   160 ,
        178 ,   194 ,   207 ,   219 ,   228 ,   234 ,   238 ,   240 ,
        238 ,   234 ,   228 ,   219 ,   207 ,   194 ,   178 ,   160 ,
        141 ,   119 ,    97 ,    74 ,    49 ,    25 ,     0 ,   -25 ,
        -49 ,   -74 ,   -97 ,  -120 ,  -141 ,  -160 ,  -178 ,  -194 ,
       -207 ,  -219 ,  -228 ,  -234 ,  -238 ,  -240 ,  -238 ,  -234 ,
       -228 ,  -219 ,  -207 ,  -194 ,  -178 ,  -160 ,  -141 ,  -119 ,
        -97 ,   -74 ,   -49 ,   -25 ,     0 ,    25 ,    49 ,    74 ,
         97 ,   120 ,   141 ,   160 ,   178 ,   194 ,   207 ,   219 ,
        228 ,   234 ,   238 ,   240 ,   238 ,

320 value    center-x
175 value    center-y
240 value    scale-y

: >screenx      ( n1 -- n2 )
                screen-width 480 */ ;

: >screeny      ( n1 -- n2 )
                screen-width 480 */ ;
((
: makesin       ( -- )
                cr
                462 0
                do      i 0 d>f fsin f# 240.0 f* f>d 8 d.r
                        100 ms
                        10 ?cr
             6 +loop    ;

: xxy-scale     ( 6deg scale -- x1 y1 )
                >r
                dup       6 * 0 d>f fsin f# 240.0 f* f>d drop
                        >screenx dup r@  center-x */
                swap 1 and +        center-x +
                swap 15 + 6 * 0 d>f fsin f# 240.0 f* f>d drop
                        >screeny dup r>   scale-y */
                swap 1 and + negate center-y + ;
))

: sin      ( deg -- x )    60 mod sintbl +CELLS @ ;
: cos      ( deg -- y )    15 + sin negate ;
: roundup  ( x sx -- x' )  swap 1 and + ;


: xy-scale      ( 6deg scale -- x1 y1 )
                >r
                dup  sin >screenx dup r@  center-x */ roundup center-x +
                swap cos >screeny dup r>   scale-y */ roundup center-y + ;

-1 value last-hour
-1 value last-minute
-1 value last-hour-minute
-1 value last-second

 0 value this-hour
 0 value this-minute
 0 value this-second

: cxy           center-x center-y ;
: inner         20 xy-scale ;
: outer         center-x 20 - xy-scale ;
: innersc       center-x  3 / xy-scale ;
: outermin      center-x dup 10 / - xy-scale ;
: outerhr       center-x  2/  xy-scale ;

: .sec          ( sec -- )
                >r
                cxy r@ outer line
                r@ 1-  inner r@ outer line
                r@ 1+  inner r@ outer line
                cxy r@ 1- inner line
                cxy r@ 1+ inner line
                r>drop ;

: .min          ( min -- )
                >r
                cxy r@ outermin line
                r@ 1-  innersc r@ outermin line
                r@ 1+  innersc r@ outermin line
                cxy r@ 1- innersc line
                cxy r@ 1+ innersc line
                r>drop ;

: .hr           ( hr -- )
                >r
                cxy r@ outerhr line
                r@ 2 -  innersc r@  outerhr line
                r@ 2 +  innersc r@  outerhr line
                cxy r@ 2 - innersc line
                cxy r@ 2 + innersc line
                r>drop ;

: .second       ( -- )          \ draw second display
                black line-color
                last-second 60 mod .sec this-second TO last-second
                white line-color
                this-second 60 mod .sec ;

: .minute       ( -- )          \ draw minute display
                this-minute last-minute <>
                IF      black line-color
                        last-minute 60 mod .min
                        this-minute TO last-minute
                THEN
                ltgreen line-color
                this-minute 60 mod .min ;

: .hour         ( -- )          \ draw hour  display
                this-hour last-hour <>
                IF      black line-color
                        last-hour 5 * last-hour-minute 12 / + 60 mod .hr
                        this-hour   TO last-hour
                        this-minute TO last-hour-minute
                THEN
                ltblue line-color
                this-hour 5 * this-minute      12 /   + 60 mod .hr ;

: ?second       ( -- f )        \ f = true if second has changed.
                get-local-time
                time-buf 12 + w@ last-second <>
                IF      time-buf 12 + w@ TO this-second         \ seconds
                        time-buf 10 + w@ TO this-minute         \ minutes
                        time-buf  8 + w@ TO this-hour           \ hours
                        TRUE
                ELSE    FALSE
                THEN    ;

: init-vars     ( -- )
                ?second drop            \ to initialize LAST-SECOND
                this-second TO last-second
                this-minute TO last-minute
                this-minute TO last-hour-minute
                this-hour   TO last-hour ;

 1 value delay-ms
16 value cdiam
 0 value ccolor

create colors
        DKGRAY ,        RED ,           LTRED ,         GREEN ,
        LTGREEN ,       BLUE ,          LTBLUE ,        YELLOW ,
        LTYELLOW ,      MAGENTA ,       LTMAGENTA ,     CYAN ,
        LTCYAN ,        GRAY ,          WHITE ,         LTGRAY ,

: >color        ( n1 -- color_object )
                15 and colors  +cells @ ;

: show-circle   ( -- )
                1 +TO ccolor
                ccolor >color line-color
                60 0
                DO     \ draws dots (lines 1 pixel long)
                    I    cdiam xy-scale 2dup 1+ swap 1+ swap line
                LOOP    5 +TO cdiam
                cdiam center-x 30 - >
                IF      16 TO cdiam
                THEN  ;

: .hms          ( -- )
                .second         \ draw second
                .minute         \ draw minute
                .hour           \ draw hour
                show-circle ;   \ draw the circles

: show-border   ( -- )
                60 0
                do      white  line-color
                        i center-x  1-  xy-scale i 1+ center-x  1-  xy-scale line
                        i center-x 12 - xy-scale i 1+ center-x 12 - xy-scale line
                        i 5 mod
                        if      ltcyan line-color           \ 1 second markers
                                i center-x 12 - xy-scale i center-x 1- xy-scale line
                        else    yellow line-color           \ 5 second markers
                                i center-x 20 - xy-scale i center-x 1- xy-scale line
                        then
                loop    ;

: new-clock     ( -- )          \ draw a new clock,
                screen-width  2/ 1- TO center-x
                screen-height 2/ 1- TO center-y         \ calibrate screen center
                center-x center-x center-y */ TO scale-y          \ calibrate aspect ratio
                white line-color                        \ default color=white
                show-border
                show-circle ;                   \ display the circle

: show-time     ( -- )          \ show the time if it has changed
                ?second                         \ if second changed
                if      .hms                    \ and then the time
                then    ;

\ ---------------------------------------------------------------
\ Top Level program starts here
\ ---------------------------------------------------------------

: WinClock      { \ c-width c-height -- }
                Start: GCLOCK
                RANDOM-INIT                             \ initialize random numbers
                screen-width  2/ 1- TO center-x
                screen-height 2/ 1- TO center-y         \ calibrate screen center
                white line-color                        \ default color=white
                new-clock
                init-vars                       \ then initialize variable
                .hms                            \ show initial time
                screen-width  to c-width
                screen-height to c-height
                begin   c-width      c-height
                        screen-width screen-height d= 0=
                        if       1 to delay-ms
                                16 to cdiam
                                new-clock
                                screen-width to  c-width
                                screen-height to c-height
                        then
                        show-time               \ just keep showing the current time
                        show-circle
                        Refresh: GCLOCK
                        key? drop
                        delay-ms 1+ 200 min to delay-ms
                        delay-ms ms
                again   ;
false #if
' WinClock turnkey WinClock     \ build an application on disk
1 pause-seconds
#else
WinClock
#then