home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
DP Tool Club 17
/
CD_ASCQ_17_101194.iso
/
vrac
/
ptgenr2.zip
/
BBDLG.PAS
next >
Wrap
Pascal/Delphi Source File
|
1994-08-01
|
37KB
|
1,280 lines
{ Created : 18-02-'91
Uses string identifiers 1920..1930
Uses object type identifiers 1920..1930
Last changes :
93-09-16 Created from PrintError a procedure type, else all of TurboVision
would be linked in because of the Application = nil check and
possibly subsequent call to MsgBox
93-09-22 Adapted to BBGui wrapper
93-09-24 Moved DisposeSItem from BBUtil to this unit
93-12-21 Added procedure PrintWarning
93-12-22 Enhanced TListViewer2 and TListBox2 to speed up selection by adding
support to select an item by typed characters
Removed cmBEditItem, cmBDeleteItem and cmBInsertItem. Their current
use was unclear
93-12-23 Fixed bug in InputString which would input only uppercase characters
Added procedure ShowHelpWindow which displays a given helpwindow
94-01-07 Added cmBEDitItem, cmBDeleteItem and cmBInsertItem again. These
commands were for buttons which should not be disabeld after
a ListBox releases its focus!
94-01-14 Added procedure ViewAsText, copied from tvfm
94-03-05 Added RegisterBBDlg procedure
}
{$IFDEF DPMI}
{$X+,S-,I-,V-}
{$ELSE}
{$X+,O+,F+,I-,R-,Q-,S-,V-,D-}
{$ENDIF}
unit BBDlg;
interface
uses Objects, Drivers, Menus, Views, Dialogs;
const
{ Message box classes }
mfWarning = $0000; { Display a Warning box }
mfError = $0001; { Dispaly a Error box }
mfInformation = $0002; { Display an Information Box }
mfConfirmation = $0003; { Display a Confirmation Box }
{ Message box button flags }
mfYesButton = $0100; { Put a Yes button into the dialog }
mfNoButton = $0200; { Put a No button into the dialog }
mfOKButton = $0400; { Put an OK button into the dialog }
mfCancelButton = $0800; { Put a Cancel button into the dialog }
mfHelpButton = $1000; { Put a Help button into the dialog }
mfYesNoCancel = mfYesButton + mfNoButton + mfCancelButton;
{ Standard Yes, No, Cancel dialog }
mfOKCancel = mfOKButton + mfCancelButton;
{ Standard OK, Cancel dialog }
mfOKCancelHelp = mfOKButton + mfCancelButton + mfHelpButton;
{ Standard OK, Cancel, Help dialog }
const
PassWordLen = 8;
{* allowed chars used by InputString *}
const
Numbers = '0123456789';
Capitals = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ';
LowerCase = 'abcdefghijklmnopqrstuvwxyz';
AllChars = '';
const
cmEditItem = 240; {* bind these two to *}
cmDeleteItem = 241; {* the keyboard *}
cmInsertItem = 242;
cmBEditItem = 243; {* these are for buttons which should *}
cmBDeleteItem = 244; {* not be disabled when a listbox releases *}
cmBInsertItem = 245; {* its focus *}
{* the following commands are defined so that existing code does not break *}
{* on the removal of language dependency from BBDlg *}
const
English = 0;
Dutch = 0;
{* the following commands are defined so that existing code does not
break on the removal of AnswerType *}
const
Yes = cmYes;
No = cmNo;
Cancel = cmCancel;
type
PPopupMenu = ^TPopupMenu;
TPopupMenu = object(TMenuPopup)
destructor Done; virtual;
end;
PSpinButton = ^TSpinButton;
TSpinButton = object(TRadioButtons)
constructor Init(var Bounds : TRect; AStrings : PSItem);
procedure Draw; virtual;
procedure HandleEvent(var Event : TEvent); virtual;
end;
PXInputLine = ^TXInputLine;
TXInputLine = object(TInputLine)
procedure HandleEvent(var Event : TEvent); virtual;
end;
const
RightMouseButtonIsEdit:Boolean = TRUE; {* when right mouse button is *}
{* pressed in list box, *}
{* activate EditItem method? *}
type
PListViewer2 = ^TListViewer2;
TListViewer2 = object(TListViewer)
TypedStr : PString;
TypedStrIndex : word;
constructor Init(var Bounds: TRect; ANumCols: Integer; AHScrollBar, AVScrollBar: PScrollBar);
procedure HandleEvent(var Event : TEvent); virtual;
procedure InsertItem; virtual;
procedure DeleteItem; virtual;
procedure EditItem; virtual;
end;
{* listbox record to be used by Get- or SetData *}
TListBoxRec = record
List: PCollection;
Selection: Word;
end;
PListBox2 = ^TListBox2;
TListBox2 = object(TListBox)
TypedStr : PString;
TypedStrIndex : word;
constructor Init(var Bounds: TRect; ANumCols: Integer; AVScrollBar: PScrollBar);
procedure HandleEvent(var Event : TEvent); virtual;
procedure InsertItem; virtual;
procedure DeleteItem; virtual;
procedure EditItem; virtual;
end;
PParamInputBox = ^TParamInputBox;
TParamInputBox = object(TListBox2)
procedure InsertItem; virtual;
procedure DeleteItem; virtual;
procedure EditItem; virtual;
end;
PStringInputBox = ^TStringInputBox;
TStringInputBox = object(TListBox2)
procedure InsertItem; virtual;
procedure DeleteItem; virtual;
procedure EditItem; virtual;
end;
procedure DisposeSItem(PS : PSItem);
procedure PrintError(const s : string; AHelpCtx : word);
procedure PrintWarning(const s : string; AHelpCtx : word);
function PromptUser(const s : string; AHelpCtx : word) : word;
function UserAnswer(const s : string; AHelpCtx : word) : word;
function popAnswer(const s : string; AHelpCtx : word) : word;
function InputString(Header : string; var s : string; len : word; AllowedChars : string; AHelpCtx : word) : word;
function InputWord(Header : string; var w : word; len : word; AHelpCtx : word) : word;
procedure InfoBox(const s : string; AHelpCtx : word);
function ExecDialog(P : PDialog; Data : pointer): word;
function CheckExecDialog(P : PDialog; Data: pointer; DataSize : word): word;
function PassWord(const s : string; AHelpCtx : word) : Boolean;
procedure InsertButtons(Dialog : PDialog; AOptions : word);
{ procedures to show a progress dialog box }
procedure OpenProgressDlg(const ATitle : string; ATotal : longint);
procedure CloseProgressDlg;
procedure SetProgressDlg(Position : longint);
procedure ProgressDlgNewText(const s : string);
{ procedure to popup a help window }
procedure ShowHelpWindow(const FileName : string; HelpCtx : word);
{ procedure to insert window with a text file as contents }
procedure ViewAsText(const FileName: FNameStr);
{ MessageBox displays the given string in a standard sized }
{ dialog box. Before the dialog is displayed the Msg and Params }
{ are passed to FormatStr. The resulting string is displayed }
{ as a TStaticText view in the dialog. }
function MessageBox(const Msg: string; Params: pointer; AOptions: word;
AHelpCtx : word): word;
{ MessageBoxRec allows the specification of a TRect for the }
{ message box to occupy. }
function MessageBoxRect(var R: TRect; const Msg: string; Params: pointer;
AOptions: word; AHelpCtx : word): word;
procedure RegisterBBDlg;
const
RPopupMenu: TStreamRec = (
ObjType: 1920;
VmtLink: Ofs(TypeOf(TPopupMenu)^);
Load: @TPopupMenu.Load;
Store: @TPopupMenu.Store
);
const
RSpinButton: TStreamRec = (
ObjType: 1921;
VmtLink: Ofs(TypeOf(TSpinButton)^);
Load: @TSpinButton.Load;
Store: @TSpinButton.Store
);
const
RXInputLine : TStreamRec = (
ObjType: 1922;
VmtLink: Ofs(TypeOf(TXInputLine)^);
Load: @TXInputLine.Load;
Store: @TXInputLine.Store
);
const
RListViewer2: TStreamRec = (
ObjType: 1923;
VmtLink: Ofs(TypeOf(TListViewer2)^);
Load: @TListViewer2.Load;
Store: @TListViewer2.Store
);
const
RListBox2: TStreamRec = (
ObjType: 1924;
VmtLink: Ofs(TypeOf(TListBox2)^);
Load: @TListBox2.Load;
Store: @TListBox2.Store
);
const
RParamInputBox: TStreamRec = (
ObjType: 1925;
VmtLink: Ofs(TypeOf(TParamInputBox)^);
Load: @TParamInputBox.Load;
Store: @TParamInputBox.Store
);
const
RStringInputBox: TStreamRec = (
ObjType: 1926;
VmtLink: Ofs(TypeOf(TStringInputBox)^);
Load: @TStringInputBox.Load;
Store: @TStringInputBox.Store
);
implementation
uses App, HelpFile, Editors, ViewText,
BBConst, BBGui, BBUtil, BBFile, BBError, BBStrRes;
const
cmProgressDlg_Add = 1000;
cmProgressDlg_Set = 1001;
type
PMyInputLine = ^TMyInputLine;
TMyInputLine = object(TXInputLine)
AllowedChars : string; {* if empty all chars are allowed *}
constructor Init(var Bounds : TRect; AMaxLen : integer; AnAllowedChars : string);
procedure HandleEvent(var Event : TEvent); virtual;
end;
PPasswordInputLine = ^TPasswordInputLine;
TPasswordInputLine = object(TInputLine)
procedure Draw; virtual;
end;
PPercentBar = ^TPercentBar;
TPercentBar = object(TView)
constructor Init(Bounds: TRect);
procedure Draw; virtual;
function GetPalette: PPalette; virtual;
procedure Update(APercent : word);
function Valid(Command: Word): Boolean; virtual;
private
Percent: Integer;
end;
PProgressDlg = ^TProgressDlg;
TProgressDlg = object(TDialog)
Percent : integer; {* 0..100% *}
Total : longint;
PercDisplay : PStaticText;
PercentBar : PPercentBar;
TextDisplay : PStaticText;
constructor Init(var Bounds : TRect; ATitle : TTitleStr; ATotal : longint);
procedure SetPerc(Position : longint);
procedure NewText(const s : string);
private
LastPosition : longint;
Limit : longint;
end;
const
ProgressDlg:PProgressDlg = nil;
procedure DisposeSItem(PS : PSItem);
{ PRE - PS = nil or not nil }
begin
if PS <> nil then begin
DisposeSItem(PS^.next);
DisposeStr(PS^.value);
Dispose(PS);
end;
end;
function MessageBox(const Msg : string; Params: pointer; AOptions: word;
AHelpCtx : word): word;
var
R: TRect;
begin
R.Assign(0, 0, 40, 9);
R.Move((Desktop^.Size.X - R.B.X) div 2, (Desktop^.Size.Y - R.B.Y) div 2);
MessageBox := MessageBoxRect(R, Msg, Params, AOptions, AHelpCtx);
end;
procedure InsertButtons(Dialog : PDialog; AOptions : word);
{* inserts language specific buttons in any dialog *}
const
ButtonName: array[0..4] of string[6] =
('~Y~es', '~N~o', 'O~K~', 'Cancel', 'Help');
const
Commands: array[0..4] of word =
(cmYes, cmNo, cmOK, cmCancel, cmHelp);
var
I, X, ButtonCount: Integer;
Control: PView;
R : TRect;
ButtonList: array[0..4] of PView;
begin
with Dialog^ do begin
X := -2;
ButtonCount := 0;
for I := 0 to 4 do
if AOptions and ($0100 shl I) <> 0 then begin
R.Assign(0, 0, 10, 2);
if I in [0, 2]
then begin
if Strings = nil
then Control := New(PButton, Init(R, ButtonName[I], Commands[i], bfDefault))
else begin
if rsGet(sButtonYes+I) = ''
then Control := New(PButton, Init(R, ButtonName[I], Commands[i], bfDefault))
else Control := New(PButton, Init(R, rsGet(sButtonYes+I), Commands[i],bfDefault));
end;
end
else begin
if Strings = nil
then Control := New(PButton, Init(R, ButtonName[I], Commands[i], bfNormal))
else begin
if rsGet(sButtonYes+I) = ''
then Control := New(PButton, Init(R, ButtonName[I], Commands[i], bfNormal))
else Control := New(PButton, Init(R, rsGet(sButtonYes+I), Commands[i], bfNormal));
end;
end;
Inc(X, Control^.Size.X + 2);
ButtonList[ButtonCount] := Control;
Inc(ButtonCount);
end;
X := (Size.X - X) shr 1;
for I := 0 to ButtonCount - 1 do begin
Control := ButtonList[I];
Insert(Control);
Control^.MoveTo(X, Size.Y - 3);
Inc(X, Control^.Size.X + 2);
end; { of for }
SelectNext(FALSE);
end; { of with }
end;
function MessageBoxRect(var R: TRect; const Msg: string; Params: pointer;
AOptions: word; AHelpCtx : word): word;
const
Titles: array[0..3] of string[11] =
('Warning','Error','Information','Confirm');
var
Dialog: PDialog;
Control: PView;
S: String;
begin
if Strings = nil
then
Dialog := New(PDialog,
Init(R, Titles[AOptions and $3]))
else
Dialog := New(PDialog,
Init(R, rsGet(sWarning + (AOptions and $3))));
with Dialog^ do begin
R.Assign(3, 2, Size.X - 2, Size.Y - 3);
FormatStr(S, Msg, Params^);
Control := New(PStaticText, Init(R, S));
Insert(Control);
InsertButtons(Dialog, AOptions);
end; { of with }
Dialog^.HelpCtx := AHelpCtx;
MessageBoxRect := DeskTop^.ExecView(Dialog);
Dispose(Dialog, Done);
end;
procedure PrintError(const s : string; AHelpCtx : word);
var
StackFrame : word;
begin
asm
mov StackFrame,bp
end;
if Application = nil
then BBGui.TextPrintError(s, AHelpCtx)
else begin
Beep;
LogError('Error: ' + s);
MessageBox(s, nil, mfError + mfOKButton, AHelpCtx);
if @DumpStack <> nil then DumpStack(nil, StackFrame);
end;
end;
procedure PrintWarning(const s : string; AHelpCtx : word);
begin
if Application = nil
then BBGui.TextPrintError(s, AHelpCtx)
else begin
Beep;
MessageBox(s, nil, mfWarning + mfOKButton, AHelpCtx);
LogError('Warning: ' + s);
end;
end;
function PromptUser(const s : string; AHelpCtx : word) : word;
begin
if Application = nil
then begin
writeln(s);
PromptUser := cmYes;
end
else
PromptUser := MessageBox(s, nil, mfInformation + mfOKButton, AHelpCtx);
end;
function UserAnswer(const s : string; AHelpCtx : word) : word;
begin
if Application = nil
then UserAnswer := TextUserAnswer(s, AHelpCtx)
else UserAnswer := MessageBox(s, nil, mfConfirmation + mfYesNoCancel, AHelpCtx);
end;
function popAnswer(const s : string; AHelpCtx : word) : word;
begin
popAnswer := UserAnswer(s, AHelpCtx);
end;
constructor TMyInputLine.Init (var Bounds : TRect; AMaxLen : integer; AnAllowedChars : string);
begin
inherited Init(Bounds, AMaxLen);
AllowedChars := AnAllowedChars;
end;
procedure TMyInputLine.HandleEvent (var Event : TEvent);
begin
if (AllowedChars <> '') and (Event.What and evKeyBoard <> 0) and
(Event.CharCode in [#32..#255]) then begin
if Pos(Event.CharCode, AllowedChars) = 0 then begin
Event.CharCode := UpCase(Event.CharCode);
if Pos(Event.CharCode, AllowedChars) = 0 then begin
ClearEvent(Event);
Beep;
end;
end;
end;
inherited HandleEvent(Event);
end;
function InputString(Header : string; var s : string; len : word;
AllowedChars : string; AHelpCtx : word) : word;
var
R: TRect;
Dialog : PDialog;
begin
R.Assign(0, 0, 40, 7);
R.Move((Desktop^.Size.X - R.B.X) div 2, (Desktop^.Size.Y - R.B.Y) div 2);
Dialog := New(PDialog, Init(R, Header));
Dialog^.HelpCtx := AHelpCtx;
if len < Dialog^.Size.X-1
then R.Assign(2,2, 2+2+len,3)
else R.Assign(2,2, Dialog^.Size.X-2, 3);
Dialog^.Insert(New(PMyInputLine, Init(R, len, AllowedChars)));
InsertButtons(Dialog, mfOKCancelHelp);
InputString := ExecDialog(Dialog, @s);
end;
function InputWord(Header : string; var w : word; len : word; AHelpCtx : word) : word;
var
s : string;
begin
s := '';
InputWord := InputString(Header, s, len, Numbers, AHelpCtx);
w := ValW(s);
end;
procedure InfoBox(const s : string; AHelpCtx : word);
begin
if Application = nil
then BBGui.TextInfoBox(s, AHelpCtx)
else MessageBox(s, nil, mfInformation + mfOKButton, AHelpCtx);
end;
function ExecDialog(P : PDialog; Data : pointer): word;
var
Result: Word;
begin
Result := cmCancel;
P := PDialog(Application^.ValidView(P));
if P <> nil then
begin
if Data <> nil then P^.SetData(Data^);
Result := DeskTop^.ExecView(P);
if (Result <> cmCancel) and (Data <> nil) then P^.GetData(Data^);
Dispose(P, Done);
end;
ExecDialog := Result;
end;
function CheckExecDialog(P : PDialog; Data: pointer; DataSize : word): word;
var
Result: Word;
begin
Result := cmCancel;
P := PDialog(Application^.ValidView(P));
if P <> nil then
begin
if Data <> nil then begin
if P^.DataSize <> DataSize then begin
PrintError('Internal error. DataSize mismatch -- CheckExecDialog --', hcNoContext);
Halt(1);
end;
P^.SetData(Data^);
end;
Result := DeskTop^.ExecView(P);
if (Result <> cmCancel) and (Data <> nil) then P^.GetData(Data^);
Dispose(P, Done);
end;
CheckExecDialog := Result;
end;
procedure TPasswordInputLine.Draw;
var
s : string;
i : integer;
begin
s := Data^;
for i := 1 to length(s) do Data^[i] := '*';
inherited Draw;
Data^ := s;
end;
function PassWord(const s : string; AHelpCtx : word) : Boolean;
var
R : TRect;
Dialog : PDialog;
es : string;
p : PPalette;
sc1,sc2 : char;
begin
R.Assign(0, 0, 40, 9);
R.Move((Desktop^.Size.X - R.B.X) div 2, (Desktop^.Size.Y - R.B.Y) div 2);
Dialog := New(PDialog, Init(R, rsGet(sPassword)));
Dialog^.HelpCtx := AHelpCtx;
R.Assign(2,2, 39,3);
Dialog^.Insert(New(PStaticText, Init(R, rsGet(sEnterPassword))));
R.Assign(4,4, 4+16+2,5);
Dialog^.Insert(New(PPasswordInputLine, Init(R, PassWordLen)));
InsertButtons(Dialog, mfOKCancel);
PButton(Dialog^.Current^.Prev)^.AmDefault := TRUE;
if DeskTop^.ExecView(Dialog) = cmCancel
then PassWord := FALSE
else begin
Dialog^.GetData(es);
if UpStr(es) = UpStr(s)
then PassWord := TRUE
else PassWord := FALSE;
end;
end;
{---------------------------------------------------------------------------}
{* TProgressDlg *}
{---------------------------------------------------------------------------}
constructor TPercentBar.Init(Bounds: TRect);
begin
inherited Init(Bounds);
Percent := 0;
end;
procedure TPercentBar.Draw;
var
Color : byte;
i : integer;
B : TDrawBuffer;
Temp : string;
PerSize : integer;
begin
if Percent = 100
then PerSize := Size.X
else PerSize := (longint(Percent)*Size.X) div 100;
Temp := RepChar(#177, Size.X);
for i := 1 to Size.X do begin
if i <= PerSize
then Color := GetColor(2) { use #20 for completed }
else Color := GetColor(1); { and #19 for incomplete 'area' of bar }
MoveChar(B[i-1], Temp[i], Color, 1); { copy temp str into buffer }
end; { of for i }
WriteBuf(0, 0, Size.X, 1, B); { write buffer into view }
end;
function TPercentBar.GetPalette: PPalette;
const P:string[2] = #19#20;
begin
GetPalette := @P;
end;
procedure TPercentBar.Update(APercent : word);
begin
Percent := APercent;
DrawView;
end;
function TPercentBar.Valid(Command: Word): Boolean;
begin
if Command = cmValid
then Valid := (Size.X >= 10) and (Size.Y = 1)
else Valid := inherited Valid(Command);
end;
constructor TProgressDlg.Init(var Bounds : TRect; ATitle : TTitleStr; ATotal : longint);
var
R : TRect;
begin
inherited Init(Bounds, ATitle);
if ATotal = 0
then Total := 1
else Total := ATotal;
Limit := Round(0.025 * Total);
R.Assign(Size.X-4-4,3, Size.X-4,4);
Percent := 0;
PercDisplay := New(PStaticText, Init(R, ' 0%'));
Insert(PercDisplay);
R.Assign(4,4, Size.X-4,5);
PercentBar := New(PPercentBar, Init(R));
Insert(PercentBar);
R.Assign(3,2, Size.X-3,3);
TextDisplay := New(PstaticText, Init(r, ''));
end;
procedure TProgressDlg.SetPerc(Position : longint);
begin
if (Position - LastPosition) < Limit then Exit;
LastPosition := Position;
Lock;
FreeStr(PercDisplay^.Text);
if Position >= Total
then begin
PercDisplay^.Text := NewStr('100%');
Percent := 100;
end
else begin
PercDisplay^.Text := NewStr(' '+StrW(Percent)+'%');
Percent := (Position*100) div Total;
end;
PercentBar^.Update(Percent);
Redraw;
Unlock;
end;
procedure TProgressDlg.NewText(const s : string);
begin
FreeStr(TextDisplay^.Text);
TextDisplay^.Text := NewStr(s);
TextDisplay^.Draw;
end;
procedure OpenProgressDlg(const ATitle : string; ATotal : longint);
var
R : TRect;
begin
if Application = nil
then TextOpenProgressDlg(ATitle, ATotal)
else begin
R.Assign(0, 0, 40, 8);
R.Move((Desktop^.Size.X - R.B.X) div 2, (Desktop^.Size.Y - R.B.Y) div 2);
ProgressDlg := New(PProgressDlg, Init(R, ATitle, ATotal));
DeskTop^.Insert(ProgressDlg);
end;
end;
procedure CloseProgressDlg;
begin
if Application = nil
then TextCloseProgressDlg
else begin
if ProgressDlg <> nil then begin
DeskTop^.Delete(ProgressDlg);
Discard(ProgressDlg);
end;
end;
end;
procedure SetProgressDlg(Position : longint);
begin
if Application = nil
then TextSetProgressDlg(Position)
else begin
if ProgressDlg <> nil then
ProgressDlg^.SetPerc(Position);
end;
end;
procedure ProgressDlgNewText(const s : string);
begin
if ProgressDlg <> nil then
ProgressDlg^.NewText(s);
end;
{---------------------------------------------------------------------------}
{* ShowHelpWindow *}
{---------------------------------------------------------------------------}
procedure ShowHelpWindow(const FileName : string; HelpCtx : word);
var
W : PWindow;
HFile : PHelpFile;
HelpStrm : PBufStream;
begin
HelpStrm := New(PBufStream, Init(FileName, stOpenRead, 1024));
HFile := New(PHelpFile, Init(HelpStrm));
if HelpStrm^.Status = stOk
then begin
W := New(PHelpWindow,Init(HFile, HelpCtx));
if Application^.ValidView(W) <> nil then begin
Application^.ExecView(W);
Dispose(W, Done);
end;
end
else begin
PrintError(rsGet1(word(HelpStrm^.Status), longint(@FileName)), hcNoContext);
Dispose(HFile, Done);
end;
end;
{---------------------------------------------------------------------------}
{* ViewAsText *}
{---------------------------------------------------------------------------}
procedure ViewAsText(const FileName : FNameStr);
{* copied from /bp/examples/dos/tvfm/tools.pas *}
var
T : PTextWindow;
R : TRect;
begin
R.Assign(0,0,72,15);
T := New(PTextWindow, Init(R, FileName));
T^.Options := T^.Options or ofCentered;
Desktop^.Insert(T);
end;
{---------------------------------------------------------------------------}
{* TPopUpMenuBox *}
{---------------------------------------------------------------------------}
destructor TPopupMenu.Done;
{ This destructor has to be defined, because TMenuPopup.Done won't dispose the
menulist
}
begin
DisposeMenu(Menu);
inherited Done;
end;
{---------------------------------------------------------------------------}
{* TSpinButton *}
{---------------------------------------------------------------------------}
constructor TSpinButton.Init(var Bounds : TRect; AStrings : PSItem);
begin
inherited Init(Bounds, AStrings);
SetCursor(1,0);
end;
procedure TSpinButton.Draw;
var
Buf : TDrawBuffer;
Attrs : word;
begin
if GetState(sfSelected)
then Attrs := GetColor($0402)
else Attrs := GetColor($0301);
MoveChar(Buf, ' ', Lo(Attrs), Size.X);
if Sel < Strings.Count then
MoveCStr(Buf, #17 + LeftJustify(PString(Strings.At(Sel))^, Size.X)+#16, Attrs);
WriteBuf(0,0, Size.X, Size.Y, Buf);
end;
procedure TSpinButton.HandleEvent(var Event : TEvent);
procedure HandleMouse;
var
MouseLoc : TPoint;
begin
if (Event.What and (evMouseDown+evMouseAuto) <> 0) then begin
repeat
MakeLocal(Event.Where, MouseLoc);
if MouseLoc.X = 0
then begin
if Sel = 0
then Sel := Strings.Count-1
else Dec(Sel);
end
else
if MouseLoc.X = Size.X-1
then begin
if Sel = Strings.Count-1
then Sel := 0
else Inc(Sel);
end
else begin
ClearEvent(Event);
Exit;
end;
MovedTo(Sel);
DrawView;
until not MouseEvent(Event, evMouseAuto); {Wait for mouse up}
ClearEvent(Event);
end;
end;
begin
TView.HandleEvent(Event);
HandleMouse;
inherited HandleEvent(Event);
end;
{---------------------------------------------------------------------------}
{* TXInputLine *}
{---------------------------------------------------------------------------}
procedure TXInputLine.HandleEvent (var Event : TEvent);
procedure ClipPaste(var Buf : PEditBuffer;
Offset, Length : word);
var
rec : string;
begin
rec := '';
{--- Check to make sure we don't exceed field length ---}
if Length > MaxLen then
Length := MaxLen;
{--- Copy contents of clipboard to input line ---}
Move(Buf^[Offset], Rec[1], Length);
{--- Set the length of the string ---}
Rec[0] := Char(Length);
{--- Set the data in the dialog ---}
SetData(rec);
end;
procedure ClipCopy;
var
s : string;
begin
GetData(s);
s := FTCopy(s, SelStart+1, SelEnd);
ClipBoard^.InsertText(@s[1], length(s), TRUE);
end;
const
Boundary = '!@#$%^&*()-+=[]{};''`:"~\ ,./|<>?';
var
s : string;
begin
inherited HandleEvent(Event);
case Event.What of
evKeyBoard : begin
case Event.KeyCode of
kbCtrlLeft : begin
if SelStart <> SelEnd then SelectAll(FALSE);
GetData(s);
{* go left if on boundary *}
while (CurPos > 0) and (Pos(s[CurPos], Boundary) <> 0) do Dec(CurPos);
{* go left, until boundary is found or edge is reached *}
while (CurPos > 0) and (Pos(s[CurPos], Boundary) = 0) do Dec(CurPos);
if CurPos < FirstPos then
Dec(FirstPos, FirstPos - CurPos);
DrawView;
end;
kbCtrlRight : begin
if SelStart <> SelEnd then SelectAll(FALSE);
GetData(s);
{* go right, until boundary is found or edge is reached *}
while (CurPos < length(s)) and (Pos(s[CurPos+1], Boundary) = 0) do Inc(CurPos);
{* go right if current character is a boundary *}
while (CurPos < length(s)) and (Pos(s[CurPos+1], Boundary) <> 0) do Inc(CurPos);
if CurPos > FirstPos + Size.X-2 then
Inc(FirstPos, CurPos - (Size.X - 2));
DrawView;
end;
kbShiftIns : begin
with ClipBoard^ do
ClipPaste(Buffer, BufPtr(SelStart), SelEnd - SelStart);
end;
kbCtrlIns : ClipCopy;
else Exit;
end; { of case }
ClearEvent(Event);
end;
evCommand : begin
case Event.Command of
cmPaste : with ClipBoard^ do
ClipPaste(Buffer, BufPtr(SelStart), SelEnd - SelStart);
cmCopy : ClipCopy;
else Exit;
end; { of case }
ClearEvent(Event);
end;
end; { of case }
end;
{---------------------------------------------------------------------------}
{* TListViewer2 and TListBox2 *}
{---------------------------------------------------------------------------}
constructor TListViewer2.Init(var Bounds: TRect; ANumCols: Integer;
AHScrollBar, AVScrollBar: PScrollBar);
begin
inherited Init(Bounds, ANumCols, AHScrollBar, AVScrollBar);
Options := Options or ofPostProcess;
TypedStr := NewStr(Spc(Size.X div NumCols + 1));
end;
procedure TListViewer2.HandleEvent(var Event : TEvent);
var
ColWidth : word;
i : integer;
P : TPoint;
begin
i := Focused;
if RightMouseButtonIsEdit and
(Event.What and (evMouseDown+evMouseUp) <> 0) and (Event.Buttons = mbRightButton)
then begin
if Event.What = evMouseDown then begin
MakeLocal(Event.Where, P);
inherited HandleEvent(Event);
if P.Y < Range-TopItem then
EditItem;
end;
end
else
inherited HandleEvent(Event);
if Focused <> i then
TypedStrIndex := 0;
case Event.What of
evCommand : begin
case Event.Command of
cmInsertItem, cmBInsertItem : InsertItem;
cmDeleteItem, cmBDeleteItem : if Focused < Range then DeleteItem;
cmEditItem, cmBEditItem : if Focused < Range then EditItem;
else Exit;
end; { of case }
end;
evBroadCast : begin
case Event.Command of
cmReceivedFocus : if Event.InfoPtr = @Self then
EnableCommands([cmInsertItem, cmDeleteItem]);
cmReleasedFocus : if Event.InfoPtr = @Self then
DisableCommands([cmInsertItem, cmDeleteItem]);
else Exit;
end; { of case }
end;
evKeyboard : begin
ColWidth := Size.X div NumCols + 1;
if (Event.CharCode in [#32..#255]) and (TypedStrIndex < ColWidth)
then begin
Inc(TypedStrIndex);
TypedStr^[TypedStrIndex] := UpCase(Event.CharCode);
TypedStr^[0] := Chr(TypedStrIndex);
for i := 0 to Range-1 do begin
if UpStr(Copy(GetText(i, ColWidth), 1, TypedStrIndex)) = TypedStr^ then begin
inherited FocusItem(i);
break;
end;
end;
end
else begin
case Event.KeyCode of
kbDel, kbBack : if TypedStrIndex > 0 then Dec(TypedStrIndex);
else Exit;
end; { of case }
end;
end;
else Exit;
end; { of case }
if Event.What and evBroadCast = 0 then ClearEvent(Event);
end;
procedure TListViewer2.InsertItem;
begin
Abstract;
end;
procedure TListViewer2.DeleteItem;
begin
Abstract;
end;
procedure TListViewer2.EditItem;
begin
Abstract;
end;
constructor TListBox2.Init(var Bounds: TRect; ANumCols: Integer; AVScrollBar: PScrollBar);
begin
inherited Init(Bounds, ANumCols, AVScrollBar);
Options := Options or ofPostProcess;
TypedStr := NewStr(Spc(Size.X div NumCols + 1));
end;
procedure TListbox2.HandleEvent(var Event : TEvent);
var
ColWidth : word;
i : integer;
P : TPoint;
begin
i := Focused;
if RightMouseButtonIsEdit and
(Event.What and (evMouseDown+evMouseUp) <> 0) and (Event.Buttons = mbRightButton)
then begin
if Event.What = evMouseDown then begin
MakeLocal(Event.Where, P);
inherited HandleEvent(Event);
if P.Y < Range-TopItem then
EditItem;
end;
end
else
inherited HandleEvent(Event);
if Focused <> i then
TypedStrIndex := 0;
case Event.What of
evCommand : begin
case Event.Command of
cmInsertItem, cmBInsertItem : begin
if (List^.Count < List^.Limit) or (List^.Delta > 0) then
InsertItem;
end;
cmDeleteItem, cmBDeleteItem : if Focused < Range then DeleteItem;
cmEditItem, cmBEditItem : if Focused < Range then EditItem;
else Exit;
end; { of case }
end;
evBroadCast : begin
case Event.Command of
cmReceivedFocus : if Event.InfoPtr = @Self then
EnableCommands([cmInsertItem, cmDeleteItem]);
cmReleasedFocus : if Event.InfoPtr = @Self then
DisableCommands([cmInsertItem, cmDeleteItem]);
else Exit;
end; { of case }
end;
evKeyboard : begin
ColWidth := Size.X div NumCols + 1;
if (Event.CharCode in [#32..#255]) and (TypedStrIndex < ColWidth)
then begin
Inc(TypedStrIndex);
TypedStr^[TypedStrIndex] := UpCase(Event.CharCode);
TypedStr^[0] := Chr(TypedStrIndex);
for i := 0 to Range-1 do begin
if UpStr(Copy(GetText(i, ColWidth), 1, TypedStrIndex)) = TypedStr^ then begin
inherited FocusItem(i);
break;
end;
end;
end
else begin
case Event.KeyCode of
kbDel, kbBack : if TypedStrIndex > 0 then Dec(TypedStrIndex);
else Exit;
end; { of case }
end;
end;
else Exit;
end; { of case }
if Event.What and evBroadCast = 0 then ClearEvent(Event);
end;
procedure TListbox2.InsertItem;
begin
Abstract;
end;
procedure TListbox2.DeleteItem;
begin
Abstract;
end;
procedure TListbox2.EditItem;
begin
Abstract;
end;
{---------------------------------------------------------------------------}
{* TParamInputBox *}
{---------------------------------------------------------------------------}
procedure TParamInputBox.InsertItem;
var
s : string;
begin
s := '';
if InputString('Parameter', s, 255, '', hcNoContext) = cmOK then begin
List^.AtInsert(Focused, NewStr(s));
SetRange(Range+1);
Inc(Focused);
DrawView;
end;
end;
procedure TParamInputBox.DeleteItem;
var
s : string;
begin
if Focused >= Range-1 then Exit;
if UserAnswer('Delete current item?', hcNoContext) = Yes then begin
List^.AtFree(Focused);
SetRange(Range-1);
DrawView;
end;
end;
procedure TParamInputBox.EditItem;
var
s : string;
begin
if Focused >= Range-1 then Exit;
s := GetStr(PString(List^.At(Focused)));
if InputString('Parameter', s, 255, '', hcNoContext) = cmOK then begin
List^.FreeItem(List^.At(Focused));
List^.AtPut(Focused, NewStr(s));
DrawView;
end;
end;
{---------------------------------------------------------------------------}
{* TStringInputBox *}
{---------------------------------------------------------------------------}
procedure TStringInputBox.InsertItem;
var
s : string;
begin
s := '';
if InputString('Parameter', s, 255, '', hcNoContext) = cmOK then begin
List^.Insert(NewStr(s));
SetRange(Range+1);
Inc(Focused);
DrawView;
end;
end;
procedure TStringInputBox.DeleteItem;
var
s : string;
begin
if UserAnswer('Delete current item?', hcNoContext) = Yes then begin
List^.AtFree(Focused);
SetRange(Range-1);
DrawView;
end;
end;
procedure TStringInputBox.EditItem;
var
s : string;
begin
s := GetStr(PString(List^.At(Focused)));
if InputString('Parameter', s, 255, '', hcNoContext) = cmOK then begin
List^.FreeItem(List^.At(Focused));
List^.Insert(NewStr(s));
DrawView;
end;
end;
{---------------------------------------------------------------------------}
{* RegisterBBDlg *}
{---------------------------------------------------------------------------}
procedure RegisterBBDlg;
begin
RegisterType(RPopupMenu);
RegisterType(RSpinButton);
RegisterType(RXInputLine);
RegisterType(RListViewer2);
RegisterType(RListBox2);
RegisterType(RParamInputBox);
RegisterType(RStringInputBox);
end;
begin
BBGui.CloseProgressDlg := CloseProgressDlg;
BBGui.InfoBox := InfoBox;
BBGui.OpenProgressDlg := OpenProgressDlg;
BBGui.PrintError := PrintError;
BBGui.SetProgressDlg := SetProgressDlg;
BBGui.UserAnswer := UserAnswer;
end. { of unit BBDlg }