\ input 98.12.7 8:10 pm NAB
\ Provides a standard dialog for
\ text input. Requires
\ 'Qrsrc.PRC' to be installed.
needs graphics
needs core-ext
needs Fonts
needs Events
needs Forms
needs Fields
needs zstrings
needs resources
(ID) p4ap (ID) util use-resources
4000 constant inputFormID
4001 constant inputFieldID
2variable inputfldptr
: inputfldlen ( -- len )
inputfldptr 2@
FldGetTextLength ;
: center-title ( c-addr u -- )
boldFont font >r
swap 2dup >abs FntCharsWidth
2/ negate 80 + 0 swap 2swap >abs
WinDrawInvertedChars
r> font drop ;
: get-input
\ ( a1 u1 max a2 u2 a3 u3
\ -- false | u4 true )
\ a1 u1: input string
\ max: max chars allowed
\ a2 u2: prompt string
\ a3 u3: title string
\ u4: new length
cursor-position 2>r
FrmGetActiveFormID >r
inputFormID PopupForm
center-title
21 7 at type \ prompt string
inputFieldID FieldFocus
\ Set max. field length:
inputFieldID GetObjectPtr
2dup inputfldptr 2! \ for later
FldSetMaxChars
2dup
inputFieldID string>Field drop
\ Loop until a button pressed:
begin
ekey ctlSelectEvent = if
drop inputfldlen swap
event >abs itemid if \ OK button
inputFieldID Field>string drop
true
else 2drop false then
r> FrmReturnToForm
2r> at exit
then
again ;
\ Example:
needs tools-ext
1 [if]
: string s" default" ; 40 allot
: test
string 2dup
40 s" Prompt:" s" Title" get-input
cr if
." You entered: " nip type
else ." Cancelled." 2drop then cr ;
[then]