[Win32forth-cvs] win32forth/src/lib ButtonBar.f, NONE, 1.1 Buttons.f, NONE, 1.1 Calendar.f, NONE, 1

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

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

Modified Files:
	ExUtils.f excontrols.f 
Added Files:
	ButtonBar.f Buttons.f Calendar.f Label.f ListBox.f 
	ProgressBar.f ScrollBar.f TabControl.f TextBox.f TrackBar.f 
	UpDownControl.f 
Log Message:
Put extended controls in their own files. EAB

--- NEW FILE: ButtonBar.f ---
anew -ButtonBar.f

WinLibrary COMCTL32.DLL

needs sendmessage.f

INTERNAL
EXTERNAL

\ *T ExControls -- More (enhanced) classes for none standard windows controls.

\ ------------------------------------------------------------------------
\ *W <a name="VertButtonBar"></a>
\ *S VertButtonBar class
\ ------------------------------------------------------------------------
:Class VertButtonBar	<super VButtonBar
\ *G VertButtonBar control
\ *P This is an enhanced Version of the VButtonBar class.
\ *P Note: this control isn't one of the standard control of MS windows.
:M SetFont:     { fonthndl \ hb1 -- }
\ *G Set the font in the control.
                hbb to hb1
                begin  hb1
                while  fonthndl GetID: hb1 SetDlgItemFont: self
                       GetPrev: hb1 to hb1
                repeat ;M

:M Enable:     	{ flag \ hb1 -- }
\ *G Enable the control.
                hbb to hb1
                begin  hb1
                while  flag GetID: hb1 EnableDlgitem: self
                       GetPrev: hb1 to hb1
                repeat ;M

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

;Class
\ *G End of VertButtonBar class

\ ------------------------------------------------------------------------
\ *W <a name="HorizButtonBar"></a>
\ *S HorizButtonBar class
\ ------------------------------------------------------------------------
:Class HorizButtonBar	<super HButtonBar
\ *G HorizButtonBar control
\ *P This is an enhanced Version of the HButtonBar class.
\ *P Note: this control isn't one of the standard control of MS windows.

:M SetFont:     { fonthndl \ hb1 -- }
\ *G Set the font in the control.
                hbb to hb1
                begin  hb1
                while  fonthndl GetID: hb1 SetDlgItemFont: self
                       GetPrev: hb1 to hb1
                repeat ;M

:M Enable:     	{ flag \ hb1 -- }
\ *G Enable the control.
                hbb to hb1
                begin  hb1
                while  flag GetID: hb1 EnableDlgitem: self
                       GetPrev: hb1 to hb1
                repeat ;M

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

;Class
\ *G End of HorizButtonBar class

MODULE

--- NEW FILE: UpDownControl.f ---
anew -UpDownControl.f

WinLibrary COMCTL32.DLL

needs sendmessage.f
needs textbox.f

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:Self DROP ;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:Self  DROP ;M

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

:M SetHex: 	( -- )
\ *G Sets the radix base for the control to hexadecimal.
\ ** Hexadecimal numbers are always unsigned.
		0 16 UDM_SETBASE SendMessage:Self  DROP ;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:Self  DROP ;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

--- NEW FILE: Calendar.f ---
anew -Calendar.f

WinLibrary COMCTL32.DLL

needs sendmessage.f

INTERNAL
EXTERNAL

#IFNDEF wYear
\ Because _SystemTime is a user variable The following need to be set at run time
0 value wyear
0 value wmonth
0 value wDayOfWeek
0 value wDay
0 value wHour
0 value wMinute
0 value wSecond
0 value wMilliSeconds
16      Constant sizeof(_systemTime)

: set-time-pointers ( -- )
            _SystemTime
            dup     to wYear
            2 + dup to wMonth
            2 + dup to wDayOfWeek
            2 + dup to wDay
            2 + dup to wHour
            2 + dup to wMinute
            2 + dup to wSecond
            2 +     to wMilliSeconds ;
initialization-chain chain-add set-time-pointers
set-time-pointers

\ TODO: Move the SystemTime-struct into class. So that every instance of the
\ control becomes his own set of values.

Comment:

wYear
The year (1601 - 30827).

wMonth
The month.

January = 1
February = 2
March = 3
April = 4
May = 5
June = 6
July = 7
August = 8
September = 9
October = 10
November = 11
December = 12

wDayOfWeek
The day of the week.

Sunday = 0
Monday = 1
Tuesday = 2
Wednesday = 3
Thursday = 4
Friday = 5
Saturday = 6

wDay
The day of the month (0-31).
wHour
The hour (0-23).
wMinute
The minute (0-59).
wSecond
The second (0-59).
wMilliseconds
The millisecond (0-999).
Comment;

#THEN

\ ------------------------------------------------------------------------
\ *W <a name="MonthCalendar"></a>
\ *S MonthCalendar class
\ ------------------------------------------------------------------------
:Class MonthCalendar	<Super Control
\ *G Month Calendar control.
\ ** A month calendar control implements a calendar-like user interface. This
\ ** provides the user with a very intuitive and recognizable method of entering
\ ** or selecting a date.

int style

:M ClassInit:   ( -- )
\ *G Initialise the class.
                ClassInit: super
                0 to style
                ;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
                ICC_DATE_CLASSES 8 sp@ Call InitCommonControlsEx 3drop
                z" SysMonthCal32" Create-Control
                ;M

:M MinSize: 	( -- x y )
\ *G Return minimum size required to display a month.
                EraseRect: TempRect
                TempRect 0 MCM_GETMINREQRECT SendMessage:Self ?Win-Error
                Right: TempRect Bottom: TempRect
                ;M

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

:M GetDate:     ( -- day month year )
\ *G Retrieves the currently selected date.
\ *P \i day \d is the day of the month (0-31).
\ *P \i Month \d is the month (January = 1; December = 12)
\ *P \i year \d is the year (1601 - 30827).
                _SystemTime 0  MCM_GETCURSEL SendMessage:Self drop
                wday w@ wmonth w@ wyear w@ ;M

:M GetToday:    ( -- day month year )
\ *G Retrieves the date information for the date specified as "today".
\ *P \i day \d is the day of the month (0-31).
\ *P \i Month \d is the month (January = 1; December = 12)
\ *P \i year \d is the year (1601 - 30827).
                _systemtime 0 MCM_GETTODAY SendMessage:Self ?Win-Error
                wday w@ wmonth w@ wyear w@ ;M
;Class
\ *G End of MonthCalendar class

\ ------------------------------------------------------------------------
\ *W <a name="DateTimePicker"></a>
\ *S DateTimePicker class
\ ------------------------------------------------------------------------
:Class DateTimePicker   <Super Control
\ *G Date and Time Picker control

int style

:M ClassInit:   ( -- )
\ *G Initialise the class.
                ClassInit: super
                0 to style
                ;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
                ICC_DATE_CLASSES 8 sp@ Call InitCommonControlsEx 3drop
                z" SysDateTimePick32" Create-Control
                ;M

/*
Date and Time Picker Control Styles

The window styles listed here are specific to date and time picker controls.

Constants
DTS_APPCANPARSE
Allows the owner to parse user input and take necessary action. It enables users to edit
within the client area of the control when they press the F2 key. The control sends
DTN_USERSTRING notification messages when users are finished.

DTS_LONGDATEFORMAT
Displays the date in long format. The default format string for this style is
defined by LOCALE_SLONGDATEFORMAT, which produces output like "Friday, April 19, 1996".

DTS_RIGHTALIGN
The drop-down month calendar will be right-aligned with the control instead of
left-aligned, which is the default.

DTS_SHOWNONE
It is possible to have no date currently selected in the control. With this style,
the control displays a check box that users can check once they have entered or selected
a date. Until this check box is checked, the application will not be able to retrieve
 the date from the control because, in essence, the control has no date. This state can
 be set with the DTM_SETSYSTEMTIME message or queried with the DTM_GETSYSTEMTIME message.

DTS_SHORTDATEFORMAT
Displays the date in short format. The default format string for this style is defined
by LOCALE_SSHORTDATE, which produces output like "4/19/96".

DTS_SHORTDATECENTURYFORMAT
Version 5.80. Similar to the DTS_SHORTDATEFORMAT style, except the year is a
four-digit field. The default format string for this style is based on LOCALE_SSHORTDATE.
 The output looks like: "4/19/1996".

DTS_TIMEFORMAT
Displays the time. The default format string for this style is defined by
LOCALE_STIMEFORMAT, which produces output like "5:31:42 PM".

DTS_UPDOWN
Places an up-down control to the right of the DTP control to modify date-time values.
This style can be used in place of the drop-down month calendar, which is the default
style.

Remarks

The DTS_XXXFORMAT styles that define the display format cannot be combined. If none of
the format styles are suitable, use a DTM_SETFORMAT message to define a custom format.
*/

:M WindowStyle: ( -- style )
\ *G Get the window style of the control. Default style is: WS_BORDER.
                WindowStyle: super WS_BORDER or style or ;M
/*
Format Strings
A DTP format string consists of a series of elements that represent a particular piece of
information and define its display format. The elements will be displayed in the order
they appear in the format string.

Date and time format elements will be replaced by the actual date and time. They are
defined by the following groups of characters:

Element     Description
"d"     The one- or two-digit day.
"dd"    The two-digit day. Single-digit day values are preceded by a zero.
"ddd"   The three-character weekday abbreviation.
"dddd"  The full weekday name.
"h"     The one- or two-digit hour in 12-hour format.
"hh"    The two-digit hour in 12-hour format. Single-digit values are preceded by a zero.
"H"     The one- or two-digit hour in 24-hour format.
"HH"    The two-digit hour in 24-hour format. Single-digit values are preceded by a zero.
"m"     The one- or two-digit minute.
"mm"    The two-digit minute. Single-digit values are preceded by a zero.
"M"     The one- or two-digit month number.
"MM"    The two-digit month number. Single-digit values are preceded by a zero.
"MMM"   The three-character month abbreviation.
"MMMM"  The full month name.
"t"     The one-letter AM/PM abbreviation (that is, AM is displayed as "A").
"tt"    The two-letter AM/PM abbreviation (that is, AM is displayed as "AM").
"yy"    The last two digits of the year (that is, 1996 would be displayed as "96").
"yyyy"  The full year (that is, 1996 would be displayed as "1996").

To make the information more readable, you can add body text to the format string by
enclosing it in single quotes. Spaces and punctuation marks do not need to be quoted.

Note   Nonformat characters that are not delimited by single quotes will result in
unpredictable display by the DTP control.

For example, to display the current date with the format
"'Today is: 04:22:31 Tuesday Mar 23, 1996", the format string is
"'Today is: 'hh':'m':'s dddd MMM dd', 'yyyy". To include a single quote in your body text,
use two consecutive single quotes. For example, "'Don''t forget' MMM dd',' yyyy" produces
output that looks like: Don't forget Mar 23, 1996. It is not necessary to use quotes
with the comma, so "'Don''t forget' MMM dd, yyyy" is also valid, and produces the same
output.

*/

:M SetCustomFormat:   ( z"format"  -- )
\ *G set the display format for time or date
                0 DTM_SETFORMAT SendMessage:Self ?Win-Error
                ;M

:M GetTime:     ( -- hrs min secs )
\ *G get user selected time
                _SystemTime 0 DTM_GETSYSTEMTIME SendMessage:Self GDT_VALID =
                if      wHour w@ wMinute w@ wSecond w@
                else    0 0 0
                then    ;M

:M SetTime:     ( hr min sec -- )
\ *G set time for user to edit
                wSecond w! wMinute w! wHour w!
                0 wMilliSeconds w!
                _SystemTime GDT_VALID DTM_SETSYSTEMTIME SendMessage:Self ?Win-Error
                 ;M

:M GetDate:     ( -- day month year )
\ *G get user selected date
                GetTime: self 3dup or or 0<>
                if      3drop wDay w@ wMonth w@ wYear w@
                then    ;M

;Class
\ *G End of DateTimePicker class

MODULE

Index: excontrols.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/lib/excontrols.f,v
retrieving revision 1.18
retrieving revision 1.19
diff -C2 -d -r1.18 -r1.19
*** excontrols.f	4 Jun 2006 09:58:50 -0000	1.18
--- excontrols.f	6 Jun 2006 02:58:24 -0000	1.19
***************
*** 13,2498 ****
  IN-APPLICATION

! WinLibrary COMCTL32.DLL
! WinLibrary RichEd32.DLL
! 
! needs sendmessage.f
! 
! needs StatusBar.f   \ in separate file
! 
! internal
[...2473 lines suppressed...]
! MODULE

! \ *Z
--- 13,28 ----
  IN-APPLICATION

! needs StatusBar.f
! needs Textbox.f        \ textbox, passwordbox, multilinetextbox etc.
! needs Listbox.f        \ listbox, combobox etc.
! needs UpDownControl.f  \ updowncontrol, spinnercontrol
! needs Buttons.f        \ checkbox, radiobutton, pushbutton,groupbox
! needs Label.f          \ label, image labels etc.
! \ needs ProgressBar.f  \ load as needed
! \ needs TrackBar.f     \ ditto
! needs ScrollBar.f
! \ needs Calendar.f     \ calendar, date/time picker, load as needed
! needs TabControl.f
! \ needs ButtonBar.f    \ uncomment and complain if actually used :-)

! \s

--- NEW FILE: ProgressBar.f ---
anew -ProgressBar.f

WinLibrary COMCTL32.DLL

needs sendmessage.f

INTERNAL
EXTERNAL

\ ------------------------------------------------------------------------
\ *W <a name="Progressbar"></a>
\ *S Progressbar class
\ ------------------------------------------------------------------------
:Class Progressbar	<Super Control
\ *G Progressbar control
\ ** A progress bar is a window that an application can use to indicate the progress
\ ** of a lengthy operation. It consists of a rectangle that is gradually filled with
\ ** the system highlight color as an operation progresses.

int style

:M Start:       ( Parent -- )
\ *G Create the control.
                TO Parent Z" msctls_progress32" Create-Control ;M

: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 +Value: 	( n -- )
\ *G Advances the current position of the progress bar by a specified increment
\ ** and redraws the bar to reflect the new position.
		0 SWAP PBM_DELTAPOS SendMessage:Self  DROP ;M

:M GetValue: 	( -- n )
\ *G Returns the current position of the progress bar.
		0 0 PBM_DELTAPOS SendMessage:Self ;M

:M SetValue: 	( n -- )
\ *G Sets the current position for the progress bar and redraws the bar to
\ ** reflect the new position.
		0 SWAP PBM_SETPOS SendMessage:Self  DROP ;M

:M SetRange: 	( min max -- )
\ *G Sets the minimum and maximum values for the progress bar and redraws the
\ ** bar to reflect the new range.
\ *P \i min \d is the minimum range value. By default, the minimum value is zero.
\ *P \i max \d is the maximum range value. By default, the maximum value is 100.
		word-join 0 PBM_SETRANGE SendMessage:Self  ?Win-error ;M

: SetStep       ( n -- n1 )
		0 SWAP PBM_SETSTEP SendMessage:Self ;

:M SetStep: 	( n -- )
\ *G Specifies the step increment for the progress bar. The step increment is
\ the amount by which the progress bar increases its current position whenever
\ the StepIt: method is used. By default, the step increment is set to 10.
		SetStep DROP ;M

:M GetStep: 	( -- n )
\ *G Returns the current step increment for the progress bar.
		0 SetStep dup SetStep ;M

:M StepIt: 	( -- )
\ *G Advances the current position for the progress bar by the step increment
\ ** and redraws the bar to reflect the new position.
\ *P When the position exceeds the maximum range value, this method resets the current
\ ** position so that the progress indicator starts over again from the beginning.
		0 0 PBM_STEPIT SendMessage:Self  DROP ;M

;Class
\ *G End of Progressbar class

\ ------------------------------------------------------------------------
\ *W <a name="SmoothProgressbar"></a>
\ *S SmoothProgressbar class
\ ------------------------------------------------------------------------
:Class SmoothProgressbar <Super Progressbar
\ *G Progressbar control
\ ** A progress bar is a window that an application can use to indicate the progress
\ ** of a lengthy operation. It consists of a rectangle that is gradually filled with
\ ** the system highlight color as an operation progresses.
\ *P The progress bar displays progress status in a smooth scrolling bar instead of the
\ ** default segmented bar.

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

;Class
\ *G End of SmoothProgressbar class

MODULE

--- NEW FILE: Buttons.f ---
anew -Buttons.f

WinLibrary COMCTL32.DLL

needs sendmessage.f

INTERNAL
EXTERNAL

\ ------------------------------------------------------------------------
\ *W <a name="CheckBox"></a>
\ *S CheckBox class
\ ------------------------------------------------------------------------
:Class CheckBox          <super CheckControl
\ *G Class for check buttons
\ ** (enhanced Version of the CheckControl 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 IsButtonChecked?:    ( -- f )
\ *G send message to self through parent
		ID IsDlgButtonChecked: parent \ to checked
		;M

:M CheckButton:	( -- )
                BST_CHECKED ID CheckDlgButton: parent ;M

:M UnCheckButton:       ( -- )
		BST_UNCHECKED ID CheckDlgButton: parent ;M

:M Check:	( f -- )
		if     CheckButton: self
		else UnCheckButton: self
		then ;M

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

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

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

;Class
\ *G End of CheckBox class

\ ------------------------------------------------------------------------
\ *W <a name="RadioButton"></a>
\ *S RadioButton class
\ ------------------------------------------------------------------------
:Class RadioButton	<super RadioControl
\ *G Class for radio buttons
\ ** (enhanced Version of the RadioControl 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.
\ *P If you need more than one group of radio buttons within a dialog you must
\ ** add the BS_GROUP style to the first button of each group.
                to style ;M

:M IsButtonChecked?: ( -- f )
\ *G Check if the radio button is checked or unchecked.
                ID IsDlgButtonChecked: parent ;M

:M CheckButton:	( -- )
\ *G Set the button state to checked.
                BST_CHECKED ID CheckDlgButton: parent ;M

:M UnCheckButton: ( -- )
\ *G Set the button state to unchecked.
		BST_UNCHECKED ID CheckDlgButton: parent ;M

:M Check:   	( f -- )
\ *G Set the button state to either checked or unchecked.
		if     CheckButton: self
		else UnCheckButton: self
		then ;M

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

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

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

;Class
\ *G End of RadioButton class

\ ------------------------------------------------------------------------
\ *W <a name="GroupRadioButton"></a>
\ *S GroupRadioButton class
\ ------------------------------------------------------------------------
:Class GroupRadioButton	<super RadioButton
\ *G Class for radio buttons.
\ ** Use a GroupRadioButton object for the first radio button in every group
\ ** of radio buttons within your dialog.

:M WindowStyle: ( -- style )
\ *G Get the window style of the control. Default is BS_GROUP.
                WindowStyle: super
                WS_GROUP or ;M
;Class
\ *G End of GroupRadioButton class

\ ------------------------------------------------------------------------
\ *W <a name="PushButton"></a>
\ *S PushButton class
\ ------------------------------------------------------------------------
:Class PushButton	<super ButtonControl
\ *G Class for push buttons
\ ** (enhanced Version of the ButtonControl 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 Setfont:     ( handle -- )
\ *G Set the font in the control.
                1 swap WM_SETFONT SendMessage:Self drop ;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 PushButton class

\ ------------------------------------------------------------------------
\ *W <a name="DefPushButton"></a>
\ *S DefPushButton class
\ ------------------------------------------------------------------------
:Class DefPushButton	<Super PushButton
\ *G Class for the default push buttons

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

;Class
\ *G End of DefPushButton class

\ ------------------------------------------------------------------------
\ *W <a name="BitmapButton"></a>
\ *S BitmapButton class
\ ------------------------------------------------------------------------
:Class BitmapButton	<Super PushButton
\ *G BitmapButton control

int hbitmap     \ bitmap handle for button

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

:M DeleteBitmap: ( -- )
                hbitmap
                if      hbitmap Call DeleteObject drop
                        0 to hbitmap
                then
                ;M

:M SetBitmap:   ( hbitmap -- )
                dup hbitmap <>
                if    \  DeleteBitmap: self
                        to hbitmap
                        hbitmap IMAGE_BITMAP BM_SETIMAGE SendMessage:Self drop
                else    drop
                then    ;M

:M SetImage:    ( hbmp -- )
                SetBitmap: self ;M

:M GetBitmap:   ( -- hbitmap )
\                0 IMAGE_BITMAP BM_GETIMAGE SendMessage:Self to hbitmap
                hbitmap
                ;M

:M GetImage:    ( -- hbitmap )
                GetBitmap: self ;M

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

:M ToolString:  ( addr cnt -- )
                binfo place
                binfo count \n->crlf
                ;M

:M Close:       ( -- )
\     		DeleteBitmap: self
                Close: super
                ;M

;Class
\ *G End of BitmapButton class

\ ------------------------------------------------------------------------
\ *W <a name="IconButton"></a>
\ *S IconButton class
\ ------------------------------------------------------------------------
:Class IconButton 	<Super PushButton
\ *G IconButton control

int hicon

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

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

:M DeleteIcon: 	( -- )
                hicon
                if      hicon Call DeleteObject drop
                        0 to hicon
                then
                ;M

:M SetIcon:     ( hIcon -- )
\ *G set the icon image to use with the button
                dup hicon <>
                if    \  DeleteIcon: self
                        to hicon
                        hicon IMAGE_ICON BM_SETIMAGE SendMessage:Self  DROP
                else    drop
                then    ;M

:M SetImage:    ( hicon -- )
                SetIcon: self ;M

:M GetIcon:    	( -- hIcon)
\ *G get the icon image used with the button
\                0 IMAGE_ICON BM_GETIMAGE SendMessage:Self to hicon
                hicon
                ;M

:M GetImage:    ( -- hicon )
                GetIcon: self ;M

:M ToolString:  ( addr cnt -- )
		binfo place
		binfo count \n->crlf
                ;M

:M Close:       ( -- )
\    		 DeleteIcon: self
                Close: super
                ;M

;Class
\ *G End of IconButton class

\ ------------------------------------------------------------------------
\ *W <a name="GroupBox"></a>
\ *S GroupBox class
\ ------------------------------------------------------------------------
:Class GroupBox		<super GroupControl
\ *G GroupBox control
\ ** (enhanced Version of the GroupControl 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 Setfont:     ( handle -- )
\ *G Set the font in the control.
                1 swap WM_SETFONT SendMessage:Self  drop ;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 GroupBox class

MODULE

--- NEW FILE: ScrollBar.f ---
anew -ScrollBar.f

WinLibrary COMCTL32.DLL

needs sendmessage.f

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 of VertScroll class

\ ------------------------------------------------------------------------
\ *W <a name="SizeBox"></a>
\ *S SizeBox class
\ ------------------------------------------------------------------------
:Class SizeBox 		<Super ScrollBar
\ *G Size box control.

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

;Class
\ *G End of SizeBox class

MODULE

--- NEW FILE: TabControl.f ---
anew -TabControl.f.f

WinLibrary COMCTL32.DLL

needs sendmessage.f

INTERNAL
EXTERNAL

\ ------------------------------------------------------------------------
\ *W <a name="TabControl"></a>
\ *S TabControl class
\ ------------------------------------------------------------------------
:Class TabControl	<Super Control
\ *G Tab control.
\ *P A tab control is analogous to the dividers in a notebook or the labels in a
\ ** file cabinet. By using a tab control, an application can define multiple pages
\ ** for the same area of a window or dialog box. Each page consists of a certain
\ ** type of information or a group of controls that the application displays when
\ ** the user selects the corresponding tab.

Record: tc_Item
\ *G The TCITEM struct.
    INT mask         // value specifying which members to retrieve or set
    INT lpReserved1  // reserved; do not use
    INT lpReserved2  // reserved; do not use
    int pszText      // pointer to string containing tab text
    int cchTextMax   // size of buffer pointed to by the pszText member
    int iImage       // index to tab control's image
    int lParam       // application-defined data associated with tab
;Recordsize:  /tc_item

int style            \ additional styles to add before creation
int selchange-func   \ selection change function
int selchanging-func \ selection changing function

:M IsMask:      ( n -- )
\ *G Set the \i mask \d member of the TCITEM struct. Possible values are:
\ *L
\ *| TCIF_TEXT       | The pszText member is valid. |
\ *| TCIF_IMAGE      | The iImage member is valid. |
\ *| TCIF_PARAM      | The lParam member is valid. |
\ *| TCIF_RTLREADING | Displays the text of pszText using right-to-left reading order on Hebrew or Arabic systems. |
                to mask ;M

:M Mask:        ( -- n )
\ *G Get the \i mask \d member of the TCITEM struct.
                mask ;M

:M IsPszText:   ( addr -- )
\ *G Set the \i mask \d member of the TCITEM struct.
                to pszText ;M

:M PszText:     ( -- n )
\ *G Get the \i pszText \d member of the TCITEM struct.
                pszText ;M

:M IscchTextMax: ( n -- )
\ *G Set the \i pszText \d member of the TCITEM struct.
		to cchTextMax ;M

:M cchTextMax:  ( -- n )
\ *G Get the \i cchTextmax \d member of the TCITEM struct.
                cchTextmax ;M

:M IsiImage:    ( n -- )
\ *G Set the \i iImage \d member of the TCITEM struct.
                to iImage ;M

:M iImage:      ( -- n )
\ *G Get the \i iImage \d member of the TCITEM struct.
                iImage ;M

:M IsLparam:    ( n -- )
\ *G Set the \i lparam \d member of the TCITEM struct.
                to lparam ;M

:M LParam:      ( -- n )
\ *G Get the \i lparam \d member of the TCITEM struct.
                lparam ;M

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

\ You can cause the tabs to look like buttons by specifying the TCS_BUTTONS style. Tabs in this type of tab control
\ should serve the same function as button controls; that is, clicking a tab should carry out a command instead of
\ displaying a page. Because the display area in a button tab control is typically not used, no border is drawn
\ around it.
\
\ You can cause a tab to receive the input focus when clicked by specifying the TCS_FOCUSONBUTTONDOWN style. This
\ style is typically used only with the TCS_BUTTONS style. You can specify that a tab never receives the input
\ focus by using the TCS_FOCUSNEVER style.
\
\ By default, a tab control displays only one row of tabs. If not all tabs can be shown at once, the tab control
\ displays an up-down control so that the user can scroll additional tabs into view.  You can cause a tab control
\ to display multiple rows of tabs, if necessary, by specifying the TCS_MULTILINE style. In this way, all tabs can
\ be displayed at once. The tabs are left-aligned within each row unless you specify the TCS_RIGHTJUSTIFY style.
\ In this case, the width of each tab is increased so that each row of tabs fills the entire width of the tab control.
\
\ A tab control automatically sizes each tab to fit its icon, if any, and its label. To give all tabs the same width,
\ you can specify the TCS_FIXEDWIDTH style. The control sizes all the tabs to fit the widest label, or you can assign
\ a specific width and height by using the TCM_SETITEMSIZE message. Within each tab, the control centers the icon and
\ label with the icon to the left of the label. You can force the icon to the left, leaving the label centered, by
\ specifying the TCS_FORCEICONLEFT style. You can left-align both the icon and label by using the TCS_FORCELABELLEFT
\ style. You cannot use the TCS_FIXEDWIDTH style with the TCS_RIGHTJUSTIFY style.

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

:M AddStyle:    ( n -- )
\ *G Set any additional style of the control. Must be done before the control
\ ** is created. Possible values are:
\ *L
\ *| TCS_BOTTOM | Tabs appear at the bottom of the control. This value equals TCS_RIGHT. |
\ *| TCS_BUTTONS | Tabs appear as buttons, and no border is drawn around the display area. |
\ *| TCS_FIXEDWIDTH | All tabs are the same width. This style cannot be combined with the TCS_RIGHTJUSTIFY style. |
\ *| TCS_FLATBUTTONS | Selected tabs appear as being indented into the background while other tabs appear as being on the same plane as the background. This style only affects tab controls with the TCS_BUTTONS style. |
\ *| TCS_FOCUSNEVER | The tab control does not receive the input focus when clicked. |
\ *| TCS_FOCUSONBUTTONDOWN | The tab control receives the input focus when clicked. |
\ *| TCS_FORCEICONLEFT | Icons are aligned with the left edge of each fixed-width tab. This style can only be used with the TCS_FIXEDWIDTH style. |
\ *| TCS_FORCELABELLEFT | Labels are aligned with the left edge of each fixed-width tab; that is, the label is displayed immediately to the right of the icon instead of being centered. |
\ *| TCS_HOTTRACK | Items under the pointer are automatically highlighted. You can check whether or not hot tracking is enabled by calling SystemParametersInfo. |
\ *| TCS_MULTILINE | Multiple rows of tabs are displayed, if necessary, so all tabs are visible at once. |
\ *| TCS_MULTISELECT | Multiple tabs can be selected by holding down CTRL when clicking. This style must be used with the TCS_BUTTONS style. |
\ *| TCS_OWNERDRAWFIXED | The parent window is responsible for drawing tabs. |
\ *| TCS_RAGGEDRIGHT | Rows of tabs will not be stretched to fill the entire width of the control. This style is the default. |
\ *| TCS_RIGHT | Tabs appear vertically on the right side of controls that use the TCS_VERTICAL style. This value equals TCS_BOTTOM. |
\ *| TCS_RIGHTJUSTIFY | The width of each tab is increased, if necessary, so that each row of tabs fills the entire width of the tab control. |
\ *| TCS_SCROLLOPPOSITE | Unneeded tabs scroll to the opposite side of the control when a tab is selected. |
\ *| TCS_SINGLELINE | Only one row of tabs is displayed. The user can scroll to see more tabs, if necessary. This style is the default. |
\ *| TCS_TABS | Tabs appear as tabs, and a border is drawn around the display area. This style is the default. |
\ *| TCS_TOOLTIPS | The tab control has a tooltip control associated with it. |
\ *| TCS_VERTICAL | Tabs appear at the left side of the control, with tab text displayed vertically. This style is valid only when used with the TCS_MULTILINE style. To make tabs appear on the right side of the control, also use the TCS_RIGHT style. |
        to style ;M

:M TC_Item: 	( -- addr )
\ *G Get the address of the TCITEM struct.
        tc_item ;M

:M InsertTab:   ( index -- )
\ *G Inserts a new tab into the tab control.
\ *P \i mask \d and other members of the TCITEM struct must be set.
        tc_item swap TCM_INSERTITEM SendMessage:Self drop ;M

:M GetTabInfo:  ( index -- )
\ *G Retrieves information about a tab in the tab control.
        tc_item swap TCM_GETITEM SendMessage:Self ?win-error ;M

:M SetTabInfo:  ( index -- )
\ *G Sets some or all of a tab's attributes.
\ *P \i mask \d and other members of the TCITEM struct must be set.
        tc_item swap TCM_SETITEM SendMessage:Self ?win-error ;M

:M GetTabCount: ( -- n )
\ *G Retrieves the number of tabs in the tab control.
        0 0 TCM_GETITEMCOUNT SendMessage:Self ;M

:M DeleteTab:   ( index -- )
\ *G Removes an item from the tab control.
        0 swap TCM_DELETEITEM SendMessage:Self ?win-error ;M

:M DeleteAllTabs:   ( -- )
\ *G Removes all items from the tab control.
        0 0 TCM_DELETEALLITEMS SendMessage:Self ?win-error ;M

:M AdjustRect:  ( rect flag -- )
\ *G Calculates a tab control's display area given a window rectangle, or
\ ** calculates the window rectangle that would correspond to a specified
\ ** display area.
\ *P \i rect \d is the address of a RECT structure that specifies the given rectangle
\ ** and receives the calculated rectangle.
\ *P \i flag \d If this parameter is TRUE, prc specifies a display rectangle and receives
\ ** the corresponding window rectangle. If this parameter is FALSE, prc specifies a window
\ ** rectangle and receives the corresponding display area.
        TCM_ADJUSTRECT SendMessage:self drop ;M

:M ClientSize:  ( -- x y w h )
\ *G Return size of display area of the tab control.
        TempRect.addrof GetClientRect: self
        Temprect.addrof false AdjustRect: self
        temprect.left temprect.top temprect.right temprect.bottom ;M

:M WindowSize:	( 0 0 width height -- x y w h )
\ *G Given display area return window size required.
        SetRect: Temprect
        Temprect true AdjustRect: self
        temprect.left temprect.top temprect.right temprect.bottom ;M

:M GetSelectedTab: ( -- index )
\ *G Determines the currently selected tab in the tab control.
        0 0 TCM_GETCURSEL SendMessage:self ;M

:M SetSelectedTab: ( index --  )
\ *G Selects a tab in the tab control.
\ *P Note: A tab control does not send a TCN_SELCHANGING or TCN_SELCHANGE
\ ** notification message when a tab is selected using this message.
        0 swap TCM_SETCURSEL SendMessage:self drop ;M

:M GetRowCount: ( -- n )
\ *G Retrieves the current number of rows of tabs in a tab control.
		0 0 TCM_GETROWCOUNT SendMessage:self ;M

:M AutoSize:    ( -- )
\ *G Resize the control to fit in the client area of the parent window.
		tempRect.AddrOf GetClientRect: Parent
		0 0 Right: tempRect Bottom: tempRect \ x,y,h,w
		Move: self
		;M

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

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

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

:M WindowTitle: ( -- null$ )
\ *G SintillaControl asks for window title of parent
                z" " ;M

:M Handle_Notify:  { w l \ ncode tabid -- f }
\ *G Handle the notification messages of the tab control. This method must
\ ** be called within the WM_NOTIFY handler of the parent window.
\ *P Currently only these notification messages are handled:
\ *L
\ *| TCN_SELCHANGE | Notifies a tab control's parent window that the currently selected tab has changed. |
\ *| TCN_SELCHANGING | Notifies a tab control's parent window that the currently selected tab is about to change. |
        w LOWORD to tabID
        l 2 cells+ @  to ncode
        ncode
        case
            TCN_SELCHANGE   of    l On_SelChanged:  [ self ] endof
            TCN_SELCHANGING of    l On_SelChanging: [ self ] endof
            false swap \ default
        endcase ;M

:M On_SelChanged:  ( l -- f )
\ *G Handle the TCN_SELCHANGE notification message.
\ ** Default calls the \i change function \d set with the \i IsChangeFunc: \d method.
		self selchange-func dup 0= abort" SelChanged function not set!"
		execute ;M

:M On_SelChanging: ( l -- f )
\ *G Handle the TCN_SELCHANGING notification message.
\ ** Default calls the \i changeing function \d set with the \i IsChangingFunc: \d method.
		self selchanging-func dup 0= abort" SelChanging function not set!"
		execute ;M

:M IsChangeFunc:   ( cfa -- )
\ *G Set the \i change function \d. This function es executed when
\ ** the currently selected tab has changed.
                to selchange-func ;M

:M IsChangingFunc: ( cfa -- )
\ *G Set the \i changeing function \d. This function es executed when
\ ** the currently selected tab is about to change.
                to selchanging-func ;M

: default-func     ( lParam obj -- false )
\ *G The default \i change(-ing) function \d.
\ *P \i lParam \d is the adress of the Address of an NMHDR structure.
\ ** \i obj \d is the address of the TabControl object that has send the
\ ** notification message.
                2drop false ;

:M ClassInit:   ( -- )
\ *G Initialise the class.
		ClassInit: Super
		0 to style
		tc_item /tc_item erase
		-1  to iImage       \ default no image
		['] default-func to selchange-func
		['] default-func to selchanging-func
		;M

;Class
\ *G End of TabControl class

\ *P For a demo how to use the TabControl see: TabControlDemo.f

MODULE

--- NEW FILE: Label.f ---
anew -Label.f

WinLibrary COMCTL32.DLL

needs sendmessage.f

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:Self drop ;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:Self  DROP
		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

--- NEW FILE: ListBox.f ---
anew -ListBox.f

WinLibrary COMCTL32.DLL

needs sendmessage.f

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:Self drop ;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:Self drop ;M

:M SetSelection: ( n -- )
\ *G Select a string in the list of a combo box.
                0 swap CB_SETCURSEL SendMessage:Self drop ;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:Self drop ;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:Self  DROP ;M

:M Clear: 	( -- )
\ *G Remove all strings from the combo box
		0 0 CB_RESETCONTENT SendMessage:Self  DROP ;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

[truncated message content]