paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-13 02:29:36 +02:00
Code Issues Packages Projects Releases Wiki Activity
c7290bfb78
fpc/packages/ide/wviews.pas

2846 lines
76 KiB
ObjectPascal
Raw Blame History

{
This file is part of the Free Pascal Integrated Development Environment
Copyright (c) 1998 by Berczi Gabor
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
{$I globdir.inc}
unit WViews;
interface
uses Objects,Drivers,Views,Menus,Dialogs,Outline;
const
evIdle = $8000;
cmCopyWin = 240;
cmPasteWin = 241;
cmSelectAll = 246;
cmUnselect = 247;
cmLocalMenu = 54100;
cmUpdate = 54101;
cmListFocusChanged = 54102;
mfUserBtn1 = $00010000;
mfUserBtn2 = $00020000;
mfUserBtn3 = $00040000;
mfUserBtn4 = $00080000;
mfCantCancel = $00100000;
cmUserBtn1 = $fee0;
cmUserBtn2 = $fee1;
cmUserBtn3 = $fee2;
cmUserBtn4 = $fee3;
CPlainCluster = #7#8#9#9;
type
longstring = ansistring;
PCenterDialog = ^TCenterDialog;
TCenterDialog = object(TDialog)
constructor Init(var Bounds: TRect; ATitle: TTitleStr);
end;
PAdvancedMenuBox = ^TAdvancedMenuBox;
TAdvancedMenuBox = object(TMenuBox)
function NewSubView(var Bounds: TRect; AMenu: PMenu;
AParentMenu: PMenuView): PMenuView; virtual;
function Execute: Word; virtual;
end;
PAdvancedMenuPopUp = ^TAdvancedMenuPopup;
TAdvancedMenuPopUp = object(TMenuPopup)
function NewSubView(var Bounds: TRect; AMenu: PMenu;
AParentMenu: PMenuView): PMenuView; virtual;
function Execute: Word; virtual;
end;
PAdvancedMenuBar = ^TAdvancedMenuBar;
TAdvancedMenuBar = object(TMenuBar)
constructor Init(var Bounds: TRect; AMenu: PMenu);
function NewSubView(var Bounds: TRect; AMenu: PMenu;
AParentMenu: PMenuView): PMenuView; virtual;
procedure Update; virtual;
function GetMenuItem(cm : word) : PMenuItem;
procedure HandleEvent(var Event: TEvent); virtual;
function Execute: Word; virtual;
end;
PAdvancedStaticText = ^TAdvancedStaticText;
TAdvancedStaticText = object(TStaticText)
procedure SetText(S: string); virtual;
end;
PAdvancedListBox = ^TAdvancedListBox;
TAdvancedListBox = object(TListBox)
Default: boolean;
procedure FocusItem(Item: sw_integer); virtual;
procedure HandleEvent(var Event: TEvent); virtual;
constructor Load(var S: TStream);
procedure Store(var S: TStream);
end;
PNoUpdateButton = ^TNoUpdateButton;
TNoUpdateButton = object(TButton)
procedure HandleEvent(var Event: TEvent); virtual;
end;
TLocalMenuListBox = object(TAdvancedListBox)
procedure HandleEvent(var Event: TEvent); virtual;
procedure LocalMenu(P: TPoint); virtual;
function GetLocalMenu: PMenu; virtual;
function GetCommandTarget: PView; virtual;
private
LastLocalCmd: word;
end;
TLocalMenuOutlineViewer = object(TOutlineViewer)
procedure HandleEvent(var Event: TEvent); virtual;
procedure LocalMenu(P: TPoint); virtual;
function GetLocalMenu: PMenu; virtual;
function GetCommandTarget: PView; virtual;
private
LastLocalCmd: word;
end;
PColorStaticText = ^TColorStaticText;
TColorStaticText = object(TAdvancedStaticText)
Color: word;
DontWrap: boolean;
Delta: TPoint;
constructor Init(var Bounds: TRect; AText: String; AColor: word; AWrap: boolean);
function GetPalette: PPalette; virtual;
procedure Draw; virtual;
constructor Load(var S: TStream);
procedure Store(var S: TStream);
end;
PHSListBox = ^THSListBox;
THSListBox = object(TLocalMenuListBox)
constructor Init(var Bounds: TRect; ANumCols: Word; AHScrollBar, AVScrollBar: PScrollBar);
function SaveToFile(const AFileName: string): boolean; virtual;
function SaveAs: Boolean; virtual;
end;
PDlgWindow = ^TDlgWindow;
TDlgWindow = object(TDialog)
constructor Init(var Bounds: TRect; ATitle: TTitleStr; ANumber: Sw_Integer);
procedure HandleEvent(var Event: TEvent); virtual;
procedure Update; virtual;
end;
PAdvancedStatusLine = ^TAdvancedStatusLine;
TAdvancedStatusLine = object(TStatusLine)
StatusText: PString;
function GetStatusText: string; virtual;
procedure SetStatusText(const S: string); virtual;
procedure ClearStatusText; virtual;
procedure Draw; virtual;
end;
PDropDownListBox = ^TDropDownListBox;
PDDHelperLB = ^TDDHelperLB;
TDDHelperLB = object(TLocalMenuListBox)
constructor Init(ALink: PDropDownListBox; var Bounds: TRect; ANumCols: Word; AScrollBar: PScrollBar);
procedure HandleEvent(var Event: TEvent); virtual;
procedure SetState(AState: Word; Enable: Boolean); virtual;
procedure SelectItem(Item: Sw_Integer); virtual;
function GetText(Item,MaxLen: Sw_Integer): String; virtual;
function GetLocalMenu: PMenu; virtual;
function GetCommandTarget: PView; virtual;
private
Link : PDropDownListBox;
LastTT: longint;
InClose: boolean;
end;
TDropDownListBox = object(TView)
Text: string;
Focused: sw_integer;
List: PCollection;
constructor Init(var Bounds: TRect; ADropLineCount: Sw_integer; AList: PCollection);
procedure HandleEvent(var Event: TEvent); virtual;
function GetText(Item: pointer; MaxLen: sw_integer): string; virtual;
procedure NewList(AList: PCollection); virtual;
procedure CreateListBox(var R: TRect);
procedure DropList(Drop: boolean); virtual;
function GetItemCount: sw_integer; virtual;
procedure FocusItem(Item: sw_integer); virtual;
function LBGetLocalMenu: PMenu; virtual;
function LBGetCommandTarget: PView; virtual;
procedure SetState(AState: Word; Enable: Boolean); virtual;
procedure Draw; virtual;
function GetPalette: PPalette; virtual;
destructor Done; virtual;
private
DropLineCount: Sw_integer;
ListDropped : boolean;
ListBox : PDDHelperLB;
SB : PScrollBar;
end;
PGroupView = ^TGroupView;
TGroupView = object(TLabel)
constructor Init(var Bounds: TRect; AText: String; ALink: PView);
procedure Draw; virtual;
end;
PPlainCheckBoxes = ^TPlainCheckBoxes;
TPlainCheckBoxes = object(TCheckBoxes)
function GetPalette: PPalette; virtual;
end;
PPlainRadioButtons = ^TPlainRadioButtons;
TPlainRadioButtons = object(TRadioButtons)
function GetPalette: PPalette; virtual;
end;
PScrollerRadioButtons = ^TScrollerRadioButtons;
TScrollerRadioButtons = object (TRadioButtons)
VScrollBar : PScrollBar;
Delta : TPoint;
constructor Init (Var Bounds: TRect; AStrings: PSItem; aVScrollBar:PScrollBar);
procedure HandleEvent (Var Event: TEvent); Virtual;
procedure MovedTo (Item: Sw_Integer); Virtual;
procedure ScrollDraw; Virtual;
procedure Draw; Virtual;
procedure DrawScrollMultiBox (Const Icon, Marker: String);
procedure ScrollTo (X,Y: Sw_Integer); Virtual;
procedure CentreSelected;
private
function FindSel (P: TPoint): Sw_Integer;
end;
PPanel = ^TPanel;
TPanel = object(TGroup)
constructor Init(var Bounds: TRect);
end;
PAdvMessageBox = ^TAdvMessageBox;
TAdvMessageBox = object(TDialog)
CanCancel: boolean;
procedure HandleEvent(var Event: TEvent); virtual;
end;
procedure InsertOK(ADialog: PDialog);
procedure InsertButtons(ADialog: PDialog);
procedure Bug(const S: string; Params: pointer);
procedure ErrorBox(const S: string; Params: pointer);
procedure WarningBox(const S: string; Params: pointer);
procedure InformationBox(const S: string; Params: pointer);
function OKCancelBox(const S: string; Params: pointer): word;
function ConfirmBox(const S: string; Params: pointer; CanCancel: boolean): word;
function ChoiceBox(const S: string; Params: pointer; Buttons: array of string; CanCancel: boolean): word;
procedure ShowMessage(Msg: string);
procedure HideMessage;
function SearchMenuItem(Menu: PMenu; Cmd: word): PMenuItem;
procedure SetMenuItemParam(Menu: PMenuItem; Param: string);
function IsSubMenu(P: PMenuItem): boolean;
function IsSeparator(P: PMenuItem): boolean;
function UpdateMenu(M: PMenu): boolean;
function SearchSubMenu(M: PMenu; Index: Sw_integer): PMenuItem;
procedure AppendMenuItem(M: PMenu; I: PMenuItem);
procedure RemoveMenuItem(Menu: PMenu; I: PMenuItem);
function GetMenuItemBefore(Menu:PMenu; BeforeOf: PMenuItem): PMenuItem;
procedure NotImplemented;
function ColorIndex(Color: byte): word;
var FormatParams : array[1..20] of ptrint;
FormatParamCount : integer;
FormatParamStrs : array[1..10] of string;
FormatParamStrCount: integer;
procedure ClearFormatParams;
procedure AddFormatParam(P: pointer);
procedure AddFormatParamInt(L: longint);
procedure AddFormatParamChar(C: AnsiChar);
procedure AddFormatParamStr(const S: string);
function FormatStrF(const Format: string; var Params): string;
function FormatStrStr(const Format, Param: string): string;
function FormatStrStr2(const Format, Param1,Param2: string): string;
function FormatStrStr3(const Format, Param1,Param2,Param3: string): string;
function FormatStrInt(const Format: string; L: PtrInt): string;
const UserButtonName : array[1..4] of string[40] = ('User~1~','User~2~','User~3~','User~4~');
procedure InitAdvMsgBox;
function AdvMessageBox(const Msg: String; Params: Pointer; AOptions: longint): Word;
function AdvMessageBoxRect(var R: TRect; const Msg: String; Params: Pointer; AOptions: longint): Word;
procedure DoneAdvMsgBox;
procedure RegisterWViews;
implementation
uses Mouse,
{ Resource,}
{$ifdef WinClipSupported}
WinClip,
FpConst,
{$endif WinClipSupported}
FVConsts,
App,MsgBox,StdDlg,
WConsts,WUtils;
{$ifndef NOOBJREG}
const
RAdvancedListBox: TStreamRec = (
ObjType: 1120;
VmtLink: Ofs(TypeOf(TAdvancedListBox)^);
Load: @TAdvancedListBox.Load;
Store: @TAdvancedListBox.Store
);
RColorStaticText: TStreamRec = (
ObjType: 1121;
VmtLink: Ofs(TypeOf(TColorStaticText)^);
Load: @TColorStaticText.Load;
Store: @TColorStaticText.Store
);
RHSListBox: TStreamRec = (
ObjType: 1122;
VmtLink: Ofs(TypeOf(THSListBox)^);
Load: @THSListBox.Load;
Store: @THSListBox.Store
);
RDlgWindow: TStreamRec = (
ObjType: 1123;
VmtLink: Ofs(TypeOf(TDlgWindow)^);
Load: @TDlgWindow.Load;
Store: @TDlgWindow.Store
);
{$endif}
{$ifdef USERESSTRINGS}
resourcestring
{$else}
const
{$endif}
sConfirm='Confirm';
sError='Error';
sInformation='Information';
sWarning='Warning';
const
MessageDialog : PCenterDialog = nil;
UserButtonCmd : array[Low(UserButtonName)..High(UserButtonName)] of word = (cmUserBtn1,cmUserBtn2,cmUserBtn3,cmUserBtn4);
{$ifdef WinClipSupported}
FromWinClipCmds : TCommandSet = ([cmPasteWin]);
{$endif WinClipSupported}
function ColorIndex(Color: byte): word;
begin
ColorIndex:=(Color and $0f)+(Color and $0f) shl 4;
end;
{*****************************************************************************
TCenterDialog
*****************************************************************************}
constructor TCenterDialog.Init(var Bounds: TRect; ATitle: TTitleStr);
begin
inherited Init(Bounds,ATitle);
Options:=Options or ofCentered;
end;
function TAdvancedMenuBox.NewSubView(var Bounds: TRect; AMenu: PMenu;
AParentMenu: PMenuView): PMenuView;
begin
NewSubView := New(PAdvancedMenuBox, Init(Bounds, AMenu, AParentMenu));
end;
function TAdvancedMenuBox.Execute: word;
type
MenuAction = (DoNothing, DoSelect, DoReturn);
var
AutoSelect: Boolean;
Action: MenuAction;
Ch: AnsiChar;
Res: Word;
ItemShown, P: PMenuItem;
{$ifdef WinClipSupported}
PPW: PMenuItem;
WinClipEmpty: boolean;
{$endif WinClipSupported}
Target: PMenuView;
R: TRect;
E: TEvent;
MouseActive: Boolean;
function IsDisabled(Item: PMenuItem): boolean;
var Found: boolean;
begin
Found:=Item^.Disabled or IsSeparator(Item);
if (Found=false) and (IsSubMenu(Item)=false) then
Found:=CommandEnabled(Item^.Command)=false;
IsDisabled:=Found;
end;
procedure TrackMouse;
var
Mouse: TPoint;
R: TRect;
begin
MakeLocal(E.Where, Mouse);
Current := Menu^.Items;
while Current <> nil do
begin
GetItemRect(Current, R);
if R.Contains(Mouse) then
begin
MouseActive := True;
Break;
end;
Current := Current^.Next;
end;
if (Current<>nil) and IsDisabled(Current) then
begin
Current:=nil;
MouseActive:=false;
end;
end;
procedure TrackKey(FindNext: Boolean);
procedure NextItem;
begin
Current := Current^.Next;
if Current = nil then Current := Menu^.Items;
end;
procedure PrevItem;
var
P: PMenuItem;
begin
P := Current;
if P = Menu^.Items then P := nil;
repeat NextItem until Current^.Next = P;
end;
begin
if Current <> nil then
repeat
if FindNext then NextItem else PrevItem;
until (Current^.Name <> nil) and (IsDisabled(Current)=false);
end;
function MouseInOwner: Boolean;
var
Mouse: TPoint;
R: TRect;
begin
MouseInOwner := False;
if (ParentMenu <> nil) and (ParentMenu^.Size.Y = 1) then
begin
ParentMenu^.MakeLocal(E.Where, Mouse);
ParentMenu^.GetItemRect(ParentMenu^.Current, R);
MouseInOwner := R.Contains(Mouse);
end;
end;
function MouseInMenus: Boolean;
var
P: PMenuView;
begin
P := ParentMenu;
while (P <> nil) and (P^.MouseInView(E.Where)=false) do
P := P^.ParentMenu;
MouseInMenus := P <> nil;
end;
function TopMenu: PMenuView;
var
P: PMenuView;
begin
P := @Self;
while P^.ParentMenu <> nil do P := P^.ParentMenu;
TopMenu := P;
end;
begin
AutoSelect := False; E.What:=evNothing;
Res := 0;
ItemShown := nil;
{$ifdef WinClipSupported}
PPW:=SearchMenuItem(Menu,cmPasteWin);
if Assigned(PPW) then
begin
WinClipEmpty:=GetTextWinClipboardSize=0;
SetCmdState(FromWinClipCmds,Not WinClipEmpty);
PPW^.disabled:=WinClipEmpty;
end;
{$endif WinClipSupported}
Current := Menu^.Default;
MouseActive := False;
if UpdateMenu(Menu) then
begin
if Current<>nil then
if Current^.Disabled then
TrackKey(true);
repeat
Action := DoNothing;
{$ifdef WinClipSupported}
If Assigned(PPW) then
begin
If WinClipEmpty and (GetTextWinClipboardSize>0) then
begin
WinClipEmpty:=false;
SetCmdState(FromWinClipCmds,true);
PPW^.disabled:=WinClipEmpty;
DrawView;
end
else if Not WinClipEmpty and (GetTextWinClipboardSize=0) then
begin
WinClipEmpty:=true;
SetCmdState(FromWinClipCmds,false);
PPW^.disabled:=WinClipEmpty;
DrawView;
end;
end;
{$endif WinClipSupported}
GetEvent(E);
case E.What of
evMouseDown:
if MouseInView(E.Where) or MouseInOwner then
begin
TrackMouse;
if Size.Y = 1 then AutoSelect := True;
end else Action := DoReturn;
evMouseUp:
begin
TrackMouse;
if MouseInOwner then
Current := Menu^.Default
else
if (Current <> nil) and (Current^.Name <> nil) then
Action := DoSelect
else
if MouseActive or MouseInView(E.Where) then Action := DoReturn
else
begin
Current := Menu^.Default;
if Current = nil then Current := Menu^.Items;
Action := DoNothing;
end;
end;
evMouseMove:
if E.Buttons <> 0 then
begin
TrackMouse;
if not (MouseInView(E.Where) or MouseInOwner) and
MouseInMenus then Action := DoReturn;
end;
evKeyDown:
case CtrlToArrow(E.KeyCode) of
kbUp, kbDown:
if Size.Y <> 1 then
TrackKey(CtrlToArrow(E.KeyCode) = kbDown) else
if E.KeyCode = kbDown then AutoSelect := True;
kbLeft, kbRight:
if ParentMenu = nil then
TrackKey(CtrlToArrow(E.KeyCode) = kbRight) else
Action := DoReturn;
kbHome, kbEnd:
if Size.Y <> 1 then
begin
Current := Menu^.Items;
if E.KeyCode = kbEnd then TrackKey(False);
end;
kbEnter:
begin
if Size.Y = 1 then AutoSelect := True;
Action := DoSelect;
end;
kbEsc:
begin
Action := DoReturn;
if (ParentMenu = nil) or (ParentMenu^.Size.Y <> 1) then
ClearEvent(E);
end;
else
Target := @Self;
Ch := GetAltChar(E.KeyCode);
if Ch = #0 then Ch := E.CharCode else Target := TopMenu;
P := Target^.FindItem(Ch);
if P = nil then
begin
P := TopMenu^.HotKey(E.KeyCode);
if (P <> nil) and CommandEnabled(P^.Command) then
begin
Res := P^.Command;
Action := DoReturn;
end
end else
if Target = @Self then
begin
if Size.Y = 1 then AutoSelect := True;
Action := DoSelect;
Current := P;
end else
if (ParentMenu <> Target) or (ParentMenu^.Current <> P) then
Action := DoReturn;
end;
evCommand:
if E.Command = cmMenu then
begin
AutoSelect := False;
if ParentMenu <> nil then Action := DoReturn;
end else Action := DoReturn;
end;
if ItemShown <> Current then
begin
ItemShown := Current;
DrawView;
end;
if (Action = DoSelect) or ((Action = DoNothing) and AutoSelect) then
if Current <> nil then with Current^ do if Name <> nil then
if Command = 0 then
begin
if E.What and (evMouseDown + evMouseMove) <> 0 then PutEvent(E);
GetItemRect(Current, R);
R.A.X := R.A.X + Origin.X;
R.A.Y := R.B.Y + Origin.Y;
R.B := Owner^.Size;
if Size.Y = 1 then Dec(R.A.X);
Target := TopMenu^.NewSubView(R, SubMenu, @Self);
Res := Owner^.ExecView(Target);
Dispose(Target, Done);
end else if Action = DoSelect then Res := Command;
if (Res <> 0) and CommandEnabled(Res) then
begin
Action := DoReturn;
ClearEvent(E);
end
else
Res := 0;
until Action = DoReturn;
end;
if E.What <> evNothing then
if (ParentMenu <> nil) or (E.What = evCommand) then PutEvent(E);
if Current <> nil then
begin
Menu^.Default := Current;
Current := nil;
DrawView;
end;
Execute := Res;
end;
function TAdvancedMenuPopup.NewSubView(var Bounds: TRect; AMenu: PMenu;
AParentMenu: PMenuView): PMenuView;
begin
NewSubView := New(PAdvancedMenuBox, Init(Bounds, AMenu, AParentMenu));
end;
function TAdvancedMenuPopup.Execute: word;
type
MenuAction = (DoNothing, DoSelect, DoReturn);
var
AutoSelect: Boolean;
Action: MenuAction;
Ch: AnsiChar;
Res: Word;
ItemShown, P: PMenuItem;
Target: PMenuView;
R: TRect;
E: TEvent;
MouseActive: Boolean;
function IsDisabled(Item: PMenuItem): boolean;
var Found: boolean;
begin
Found:=Item^.Disabled or IsSeparator(Item);
if (Found=false) and (IsSubMenu(Item)=false) then
Found:=CommandEnabled(Item^.Command)=false;
IsDisabled:=Found;
end;
procedure TrackMouse;
var
Mouse: TPoint;
R: TRect;
begin
MakeLocal(E.Where, Mouse);
Current := Menu^.Items;
while Current <> nil do
begin
GetItemRect(Current, R);
if R.Contains(Mouse) then
begin
MouseActive := True;
Break;
end;
Current := Current^.Next;
end;
if (Current<>nil) and IsDisabled(Current) then
begin
Current:=nil;
MouseActive:=false;
end;
end;
procedure TrackKey(FindNext: Boolean);
procedure NextItem;
begin
Current := Current^.Next;
if Current = nil then Current := Menu^.Items;
end;
procedure PrevItem;
var
P: PMenuItem;
begin
P := Current;
if P = Menu^.Items then P := nil;
repeat NextItem until Current^.Next = P;
end;
begin
if Current <> nil then
repeat
if FindNext then NextItem else PrevItem;
until (Current^.Name <> nil) and (IsDisabled(Current)=false);
end;
function MouseInOwner: Boolean;
var
Mouse: TPoint;
R: TRect;
begin
MouseInOwner := False;
if (ParentMenu <> nil) and (ParentMenu^.Size.Y = 1) then
begin
ParentMenu^.MakeLocal(E.Where, Mouse);
ParentMenu^.GetItemRect(ParentMenu^.Current, R);
MouseInOwner := R.Contains(Mouse);
end;
end;
function MouseInMenus: Boolean;
var
P: PMenuView;
begin
P := ParentMenu;
while (P <> nil) and (P^.MouseInView(E.Where)=false) do
P := P^.ParentMenu;
MouseInMenus := P <> nil;
end;
function TopMenu: PMenuView;
var
P: PMenuView;
begin
P := @Self;
while P^.ParentMenu <> nil do P := P^.ParentMenu;
TopMenu := P;
end;
begin
AutoSelect := False; E.What:=evNothing;
Res := 0;
ItemShown := nil;
Current := Menu^.Default;
MouseActive := False;
if UpdateMenu(Menu) then
begin
if Current<>nil then
if Current^.Disabled then
TrackKey(true);
repeat
Action := DoNothing;
GetEvent(E);
case E.What of
evMouseDown:
if MouseInView(E.Where) or MouseInOwner then
begin
TrackMouse;
if Size.Y = 1 then AutoSelect := True;
end else Action := DoReturn;
evMouseUp:
begin
TrackMouse;
if MouseInOwner then
Current := Menu^.Default
else
if (Current <> nil) and (Current^.Name <> nil) then
Action := DoSelect
else
if MouseActive or MouseInView(E.Where) then Action := DoReturn
else
begin
Current := Menu^.Default;
if Current = nil then Current := Menu^.Items;
Action := DoNothing;
end;
end;
evMouseMove:
if E.Buttons <> 0 then
begin
TrackMouse;
if not (MouseInView(E.Where) or MouseInOwner) and
MouseInMenus then Action := DoReturn;
end;
evKeyDown:
case CtrlToArrow(E.KeyCode) of
kbUp, kbDown:
if Size.Y <> 1 then
TrackKey(CtrlToArrow(E.KeyCode) = kbDown) else
if E.KeyCode = kbDown then AutoSelect := True;
kbLeft, kbRight:
if ParentMenu = nil then
TrackKey(CtrlToArrow(E.KeyCode) = kbRight) else
Action := DoReturn;
kbHome, kbEnd:
if Size.Y <> 1 then
begin
Current := Menu^.Items;
if E.KeyCode = kbEnd then TrackKey(False);
end;
kbEnter:
begin
if Size.Y = 1 then AutoSelect := True;
Action := DoSelect;
end;
kbEsc:
begin
Action := DoReturn;
if (ParentMenu = nil) or (ParentMenu^.Size.Y <> 1) then
ClearEvent(E);
end;
else
Target := @Self;
Ch := GetAltChar(E.KeyCode);
if Ch = #0 then Ch := E.CharCode else Target := TopMenu;
P := Target^.FindItem(Ch);
if P = nil then
begin
P := TopMenu^.HotKey(E.KeyCode);
if (P <> nil) and CommandEnabled(P^.Command) then
begin
Res := P^.Command;
Action := DoReturn;
end
end else
if Target = @Self then
begin
if Size.Y = 1 then AutoSelect := True;
Action := DoSelect;
Current := P;
end else
if (ParentMenu <> Target) or (ParentMenu^.Current <> P) then
Action := DoReturn;
end;
evCommand:
if E.Command = cmMenu then
begin
AutoSelect := False;
if ParentMenu <> nil then Action := DoReturn;
end else Action := DoReturn;
end;
if ItemShown <> Current then
begin
ItemShown := Current;
DrawView;
end;
if (Action = DoSelect) or ((Action = DoNothing) and AutoSelect) then
if Current <> nil then with Current^ do if Name <> nil then
if Command = 0 then
begin
if E.What and (evMouseDown + evMouseMove) <> 0 then PutEvent(E);
GetItemRect(Current, R);
R.A.X := R.A.X + Origin.X;
R.A.Y := R.B.Y + Origin.Y;
R.B := Owner^.Size;
if Size.Y = 1 then Dec(R.A.X);
Target := TopMenu^.NewSubView(R, SubMenu, @Self);
Res := Owner^.ExecView(Target);
Dispose(Target, Done);
end else if Action = DoSelect then Res := Command;
if (Res <> 0) and CommandEnabled(Res) then
begin
Action := DoReturn;
ClearEvent(E);
end
else
Res := 0;
until Action = DoReturn;
end;
if E.What <> evNothing then
if (ParentMenu <> nil) or (E.What = evCommand) then PutEvent(E);
if Current <> nil then
begin
Menu^.Default := Current;
Current := nil;
DrawView;
end;
Execute := Res;
end;
constructor TAdvancedMenuBar.Init(var Bounds: TRect; AMenu: PMenu);
begin
inherited Init(Bounds, AMenu);
EventMask:=EventMask or evBroadcast;
GrowMode:=gfGrowHiX;
end;
function TAdvancedMenuBar.NewSubView(var Bounds: TRect; AMenu: PMenu;
AParentMenu: PMenuView): PMenuView;
begin
NewSubView := New(PAdvancedMenuBox, Init(Bounds, AMenu, AParentMenu));
end;
procedure TAdvancedMenuBar.Update;
begin
UpdateMenu(Menu);
DrawView;
end;
function TAdvancedMenuBar.GetMenuItem(cm : word) : PMenuItem;
type
PItemChain = ^TItemChain;
TItemChain = record
Next : PMenuItem;
Up : PItemChain;
end;
var Cur : PMenuItem;
Up,NUp : PItemChain;
begin
Cur:=Menu^.Items;
Up:=nil;
if cm=0 then
begin
GetMenuItem:=nil;
exit;
end;
while assigned(Cur) and (Cur^.Command<>cm) do
begin
if (Cur^.Command=0) and assigned(Cur^.SubMenu) and
assigned(Cur^.Name) and
assigned(Cur^.SubMenu^.Items) then
{subMenu}
begin
If assigned(Cur^.Next) then
begin
New(Nup);
Nup^.Up:=Up;
Nup^.next:=Cur^.Next;
Up:=Nup;
end;
Cur:=Cur^.SubMenu^.Items;
end
else
{ normal item }
begin
if assigned(Cur^.Next) then
Cur:=Cur^.Next
else if assigned(Up) then
begin
Cur:=Up^.next;
NUp:=Up;
Up:=Up^.Up;
Dispose(NUp);
end
else
Cur:=Nil;
end;
end;
GetMenuItem:=Cur;
While assigned(Up) do
begin
NUp:=Up;
Up:=Up^.up;
Dispose(NUp);
end;
end;
procedure TAdvancedMenuBar.HandleEvent(var Event: TEvent);
begin
case Event.What of
evBroadcast :
case Event.Command of
cmCommandSetChanged : Update;
cmUpdate : Update;
end;
end;
inherited HandleEvent(Event);
end;
function TAdvancedMenuBar.Execute: word;
type
MenuAction = (DoNothing, DoSelect, DoReturn);
var
AutoSelect: Boolean;
Action: MenuAction;
Ch: AnsiChar;
Res: Word;
ItemShown, P: PMenuItem;
Target: PMenuView;
R: TRect;
E: TEvent;
MouseActive: Boolean;
function IsDisabled(Item: PMenuItem): boolean;
var Dis : boolean;
begin
Dis:=Item^.Disabled or IsSeparator(Item);
if (Dis=false) and (IsSubMenu(Item)=false) then
Dis:=CommandEnabled(Item^.Command)=false;
IsDisabled:=Dis;
end;
procedure TrackMouse;
var
Mouse: TPoint;
R: TRect;
begin
MakeLocal(E.Where, Mouse);
Current := Menu^.Items;
while Current <> nil do
begin
GetItemRect(Current, R);
if R.Contains(Mouse) then
begin
MouseActive := True;
Break;
end;
Current := Current^.Next;
end;
if (Current<>nil) and IsDisabled(Current) then
Current:=nil;
end;
procedure TrackKey(FindNext: Boolean);
procedure NextItem;
begin
Current := Current^.Next;
if Current = nil then Current := Menu^.Items;
end;
procedure PrevItem;
var
P: PMenuItem;
begin
P := Current;
if P = Menu^.Items then P := nil;
repeat NextItem until Current^.Next = P;
end;
begin
if Current <> nil then
repeat
if FindNext then NextItem else PrevItem;
until (Current^.Name <> nil) and (IsDisabled(Current)=false);
end;
function MouseInOwner: Boolean;
var
Mouse: TPoint;
R: TRect;
begin
MouseInOwner := False;
if (ParentMenu <> nil) and (ParentMenu^.Size.Y = 1) then
begin
ParentMenu^.MakeLocal(E.Where, Mouse);
ParentMenu^.GetItemRect(ParentMenu^.Current, R);
MouseInOwner := R.Contains(Mouse);
end;
end;
function MouseInMenus: Boolean;
var
P: PMenuView;
begin
P := ParentMenu;
while (P <> nil) and not P^.MouseInView(E.Where) do P := P^.ParentMenu;
MouseInMenus := P <> nil;
end;
function TopMenu: PMenuView;
var
P: PMenuView;
begin
P := @Self;
while P^.ParentMenu <> nil do P := P^.ParentMenu;
TopMenu := P;
end;
begin
AutoSelect := False; E.What:=evNothing;
Res := 0;
ItemShown := nil;
Current := Menu^.Default;
MouseActive := False;
if UpdateMenu(Menu) then
begin
if Current<>nil then
if Current^.Disabled then
TrackKey(true);
repeat
Action := DoNothing;
GetEvent(E);
case E.What of
evMouseDown:
if MouseInView(E.Where) or MouseInOwner then
begin
TrackMouse;
if Size.Y = 1 then AutoSelect := True;
end else Action := DoReturn;
evMouseUp:
begin
TrackMouse;
if MouseInOwner then
Current := Menu^.Default
else
if (Current <> nil) and (Current^.Name <> nil) then
Action := DoSelect
else
if MouseActive or MouseInView(E.Where) then Action := DoReturn
else
begin
Current := Menu^.Default;
if Current = nil then Current := Menu^.Items;
Action := DoNothing;
end;
end;
evMouseMove:
if E.Buttons <> 0 then
begin
TrackMouse;
if not (MouseInView(E.Where) or MouseInOwner) and
MouseInMenus then Action := DoReturn;
end;
evKeyDown:
case CtrlToArrow(E.KeyCode) of
kbUp, kbDown:
if Size.Y <> 1 then
TrackKey(CtrlToArrow(E.KeyCode) = kbDown) else
if E.KeyCode = kbDown then AutoSelect := True;
kbLeft, kbRight:
if ParentMenu = nil then
TrackKey(CtrlToArrow(E.KeyCode) = kbRight) else
Action := DoReturn;
kbHome, kbEnd:
if Size.Y <> 1 then
begin
Current := Menu^.Items;
if E.KeyCode = kbEnd then TrackKey(False);
end;
kbEnter:
begin
if Size.Y = 1 then AutoSelect := True;
Action := DoSelect;
end;
kbEsc:
begin
Action := DoReturn;
if (ParentMenu = nil) or (ParentMenu^.Size.Y <> 1) then
ClearEvent(E);
end;
else
Target := @Self;
Ch := GetAltChar(E.KeyCode);
if Ch = #0 then Ch := E.CharCode else Target := TopMenu;
P := Target^.FindItem(Ch);
if P = nil then
begin
P := TopMenu^.HotKey(E.KeyCode);
if (P <> nil) and CommandEnabled(P^.Command) then
begin
Res := P^.Command;
Action := DoReturn;
end
end else
if Target = @Self then
begin
if Size.Y = 1 then AutoSelect := True;
Action := DoSelect;
Current := P;
end else
if (ParentMenu <> Target) or (ParentMenu^.Current <> P) then
Action := DoReturn;
end;
evCommand:
if E.Command = cmMenu then
begin
AutoSelect := False;
if ParentMenu <> nil then Action := DoReturn;
end else Action := DoReturn;
end;
if ItemShown <> Current then
begin
ItemShown := Current;
DrawView;
end;
if (Action = DoSelect) or ((Action = DoNothing) and AutoSelect) then
if Current <> nil then with Current^ do if Name <> nil then
if Command = 0 then
begin
if E.What and (evMouseDown + evMouseMove) <> 0 then PutEvent(E);
GetItemRect(Current, R);
R.A.X := R.A.X + Origin.X;
R.A.Y := R.B.Y + Origin.Y;
R.B := Owner^.Size;
if Size.Y = 1 then Dec(R.A.X);
Target := TopMenu^.NewSubView(R, SubMenu, @Self);
Res := Owner^.ExecView(Target);
Dispose(Target, Done);
end else if Action = DoSelect then Res := Command;
if (Res <> 0) and CommandEnabled(Res) then
begin
Action := DoReturn;
ClearEvent(E);
end
else
Res := 0;
until Action = DoReturn;
end;
if E.What <> evNothing then
if (ParentMenu <> nil) or (E.What = evCommand) then PutEvent(E);
if Current <> nil then
begin
Menu^.Default := Current;
Current := nil;
DrawView;
end;
Execute := Res;
end;
procedure TAdvancedStaticText.SetText(S: string);
begin
if Text<>nil then DisposeStr(Text);
Text:=NewStr(S);
DrawView;
end;
procedure TAdvancedListBox.FocusItem(Item: sw_integer);
var OFocused: sw_integer;
begin
OFocused:=Focused;
inherited FocusItem(Item);
if Focused<>OFocused then
Message(Owner,evBroadcast,cmListFocusChanged,@Self);
end;
procedure TAdvancedListBox.HandleEvent(var Event: TEvent);
var eEvent : TEvent;
begin
case Event.What of
evMouseDown :
if MouseInView(Event.Where) {and (Event.Double)} then
begin
eEvent:=Event; {save for later use after inherited call}
inherited HandleEvent(Event);
if eEvent.Double then
if Range>Focused then
SelectItem(Focused);
end;
evBroadcast :
case Event.Command of
cmListItemSelected :
Message(Owner,evBroadcast,cmDefault,nil);
end;
end;
inherited HandleEvent(Event);
end;
constructor TColorStaticText.Init(var Bounds: TRect; AText: String; AColor: word; AWrap: boolean);
begin
inherited Init(Bounds,AText);
DontWrap:=not AWrap;
Color:=AColor;
end;
function TColorStaticText.GetPalette: PPalette;
begin
GetPalette:=nil;
end;
procedure TColorStaticText.Draw;
procedure MoveColorTxt(var b;const curs:string;c:word);
var
p : ^word;
i : sw_integer;
col : byte;
tilde : boolean;
begin
tilde:=false;
col:=lo(c);
p:=@b;
i:=0;
while (i<length(Curs)) do
begin
Inc(i);
case CurS[i] of
#1 :
begin
Inc(i);
Col:=ord(curS[i]);
end;
#2 :
begin
if tilde then
col:=hi(Color)
else
col:=lo(Color)
end;
'~' :
begin
tilde:=not tilde;
if tilde then
col:=hi(Color)
else
col:=lo(Color)
end;
else
begin
p^:=(col shl 8) or ord(curs[i]);
inc(p);
end;
end;
end;
end;
var
C: word;
Center: Boolean;
I, J, L, P, Y: Sw_Integer;
B: TDrawBuffer;
S: String;
T: string;
CurS: string;
TildeCount,Po: Sw_integer;
TempS: string;
begin
if Size.X=0 then Exit;
C:=Color;
if (C and $0f)=((C and $f0) shr 4) then
C:=GetColor(C and $0f);
if DontWrap=false then
begin
GetText(S);
L := Length(S);
P := 1;
Y := 0;
Center := False;
while Y < Size.Y do
begin
MoveChar(B, ' ', Lo(C), Size.X);
if P <= L then
begin
if S[P] = #3 then
begin
Center := True;
Inc(P);
end;
I := P;
repeat
J := P;
while (P <= L) and (S[P] = ' ') do Inc(P);
while (P <= L) and (S[P] <> ' ') and (S[P] <> #13) do Inc(P);
until (P > L) or (P >= I + Size.X) or (S[P] = #13);
TildeCount:=0; TempS:=copy(S,I,P-I);
repeat
Po:=Pos('~',TempS);
if Po>0 then begin Inc(TildeCount); Delete(TempS,1,Po); end;
until Po=0;
if P > I + Size.X + TildeCount then
if J > I then P := J else P := I + Size.X;
T:=copy(S,I,P-I);
if Center then J := (Size.X - {P + I}CStrLen(T)) div 2 else J := 0;
MoveColorTxt(B[J],T,C);
while (P <= L) and (S[P] = ' ') do Inc(P);
if (P <= L) and (S[P] = #13) then
begin
Center := False;
Inc(P);
if (P <= L) and (S[P] = #10) then Inc(P);
end;
end;
WriteLine(0, Y, Size.X, 1, B);
Inc(Y);
end;
end { Wrap=false } else
begin
GetText(S);
I:=1;
for Y:=0 to Size.Y-1 do
begin
MoveChar(B, ' ', Lo(C), Size.X);
CurS:='';
if S<>'' then
begin
P:=Pos(#13,S);
if P=0 then P:=length(S)+1;
CurS:=copy(S,1,P-1);
CurS:=copy(CurS,Delta.X+1,High(CurS));
CurS:=copy(CurS,1,MaxViewWidth);
Delete(S,1,P);
end;
if CurS<>'' then
MoveColorTxt(B,CurS,C);
WriteLine(0,Y,Size.X,1,B);
end;
end;
end;
constructor TColorStaticText.Load(var S: TStream);
begin
inherited Load(S);
S.Read(Color,SizeOf(Color));
S.Read(DontWrap,SizeOf(DontWrap));
S.Read(Delta,SizeOf(Delta));
end;
procedure TColorStaticText.Store(var S: TStream);
begin
inherited Store(S);
S.Write(Color,SizeOf(Color));
S.Write(DontWrap,SizeOf(DontWrap));
S.Write(Delta,SizeOf(Delta));
end;
constructor THSListBox.Init(var Bounds: TRect; ANumCols: Word; AHScrollBar, AVScrollBar: PScrollBar);
begin
inherited Init(Bounds,ANumCols,AVScrollBar);
HScrollBar:=AHScrollBar;
if assigned(VScrollBar) then
VScrollBar^.SetStep(Bounds.B.Y-Bounds.A.Y-2,1);
if assigned(HScrollBar) then
HScrollBar^.SetStep(Bounds.B.X-Bounds.A.X-2,1);
end;
function THSListBox.SaveToFile(const AFileName: string): boolean;
var OK: boolean;
S: PBufStream;
i, count : sw_integer;
st : string;
begin
New(S, Init(AFileName,stCreate,4096));
OK:=Assigned(S) and (S^.Status=stOK);
if OK then
begin
if assigned(List) then
Count:=List^.Count
else
Count:=0;
for i:=0 to Count-1 do
begin
st:=GetText(i,High(st));
S^.Write(St[1],length(St));
if i<Count then
S^.Write(EOL[1],length(EOL));
OK:=(S^.Status=stOK);
if not OK then
break;
end;
end;
if Assigned(S) then Dispose(S, Done);
SaveToFile:=OK;
end;
function THSListBox.SaveAs: Boolean;
var
DefExt,Title,Filename : string;
Re : word;
begin
SaveAs := False;
Filename:='listbox.txt';
DefExt:='*.txt';
Title:='Save list box content';
Re:=Application^.ExecuteDialog(New(PFileDialog, Init(DefExt,
Title, label_name, fdOkButton, FileId)), @FileName);
if Re <> cmCancel then
SaveAs := SaveToFile(FileName);
end;
constructor TDlgWindow.Init(var Bounds: TRect; ATitle: TTitleStr; ANumber: Sw_Integer);
begin
inherited Init(Bounds,ATitle);
Number:=ANumber;
Flags:=Flags or (wfMove + wfGrow + wfClose + wfZoom);
end;
procedure TDlgWindow.Update;
begin
DrawView;
end;
procedure TDlgWindow.HandleEvent(var Event: TEvent);
begin
case Event.What of
evBroadcast :
case Event.Command of
cmUpdate : Update;
end;
end;
inherited HandleEvent(Event);
end;
procedure TLocalMenuListBox.LocalMenu(P: TPoint);
var M: PMenu;
MV: PAdvancedMenuPopUp;
R: TRect;
Re: word;
begin
M:=GetLocalMenu;
if M=nil then Exit;
if LastLocalCmd<>0 then
M^.Default:=SearchMenuItem(M,LastLocalCmd);
Desktop^.GetExtent(R);
MakeGlobal(P,R.A); {Desktop^.MakeLocal(R.A,R.A);}
New(MV, Init(R, M));
Re:=Application^.ExecView(MV);
if M^.Default=nil then LastLocalCmd:=0
else LastLocalCmd:=M^.Default^.Command;
Dispose(MV, Done);
if Re<>0 then
Message(GetCommandTarget,evCommand,Re,@Self);
end;
function TLocalMenuListBox.GetLocalMenu: PMenu;
begin
GetLocalMenu:=nil;
{ Abstract;}
end;
function TLocalMenuListBox.GetCommandTarget: PView;
begin
GetCommandTarget:=@Self;
end;
procedure TLocalMenuListBox.HandleEvent(var Event: TEvent);
var DontClear: boolean;
P: TPoint;
begin
case Event.What of
evMouseDown :
if MouseInView(Event.Where) then
begin
if (Event.Buttons=mbRightButton) then
begin
MakeLocal(Event.Where,P); Inc(P.X); Inc(P.Y);
LocalMenu(P);
ClearEvent(Event);
end;
end;
evKeyDown :
begin
DontClear:=false;
case Event.KeyCode of
kbAltF10 : Message(@Self,evCommand,cmLocalMenu,@Self);
else DontClear:=true;
end;
if DontClear=false then ClearEvent(Event);
end;
evCommand :
begin
DontClear:=false;
case Event.Command of
cmLocalMenu :
begin
P:=Cursor; Inc(P.X); Inc(P.Y);
LocalMenu(P);
end;
else DontClear:=true;
end;
if not DontClear then ClearEvent(Event);
end;
end;
inherited HandleEvent(Event);
end;
procedure TLocalMenuOutlineViewer.LocalMenu(P: TPoint);
var M: PMenu;
MV: PAdvancedMenuPopUp;
R: TRect;
Re: word;
begin
M:=GetLocalMenu;
if M=nil then Exit;
if LastLocalCmd<>0 then
M^.Default:=SearchMenuItem(M,LastLocalCmd);
Desktop^.GetExtent(R);
MakeGlobal(P,R.A); {Desktop^.MakeLocal(R.A,R.A);}
New(MV, Init(R, M));
Re:=Application^.ExecView(MV);
if M^.Default=nil then LastLocalCmd:=0
else LastLocalCmd:=M^.Default^.Command;
Dispose(MV, Done);
if Re<>0 then
Message(GetCommandTarget,evCommand,Re,@Self);
end;
function TLocalMenuOutlineViewer.GetLocalMenu: PMenu;
begin
GetLocalMenu:=nil;
{ Abstract;}
end;
function TLocalMenuOutlineViewer.GetCommandTarget: PView;
begin
GetCommandTarget:=@Self;
end;
procedure TLocalMenuOutlineViewer.HandleEvent(var Event: TEvent);
var DontClear: boolean;
P: TPoint;
begin
case Event.What of
evMouseDown :
if MouseInView(Event.Where) then
begin
if (Event.Buttons=mbRightButton) then
begin
MakeLocal(Event.Where,P); Inc(P.X); Inc(P.Y);
LocalMenu(P);
ClearEvent(Event);
end;
end;
evKeyDown :
begin
DontClear:=false;
case Event.KeyCode of
kbAltF10 : Message(@Self,evCommand,cmLocalMenu,@Self);
else DontClear:=true;
end;
if DontClear=false then ClearEvent(Event);
end;
evCommand :
begin
DontClear:=false;
case Event.Command of
cmLocalMenu :
begin
P:=Cursor; Inc(P.X); Inc(P.Y);
LocalMenu(P);
end;
else DontClear:=true;
end;
if not DontClear then ClearEvent(Event);
end;
end;
inherited HandleEvent(Event);
end;
function TAdvancedStatusLine.GetStatusText: string;
var S: string;
begin
if StatusText=nil then S:='' else S:=StatusText^;
GetStatusText:=S;
end;
procedure TAdvancedStatusLine.SetStatusText(const S: string);
begin
if StatusText<>nil then DisposeStr(StatusText);
StatusText:=NewStr(S);
DrawView;
end;
procedure TAdvancedStatusLine.ClearStatusText;
begin
SetStatusText('');
end;
procedure TAdvancedStatusLine.Draw;
var B: TDrawBuffer;
C: word;
S: string;
begin
S:=GetStatusText;
if S='' then inherited Draw else
begin
C:=GetColor(1);
MoveChar(B,' ',C,Size.X);
MoveStr(B[1],S,C);
WriteLine(0,0,Size.X,Size.Y,B);
end;
end;
procedure Bug(const S: string; Params: pointer);
begin
ErrorBox(FormatStrStr(msg_bugcheckfailed,S),Params);
end;
procedure ErrorBox(const S: string; Params: pointer);
begin
AdvMessageBox(S,Params,mfError+mfInsertInApp+mfOKButton);
end;
procedure WarningBox(const S: string; Params: pointer);
begin
AdvMessageBox(S,Params,mfWarning+mfInsertInApp+mfOKButton);
end;
procedure InformationBox(const S: string; Params: pointer);
begin
AdvMessageBox(S,Params,mfInformation+mfInsertInApp+mfOKButton);
end;
function OKCancelBox(const S: string; Params: pointer): word;
begin
OKCancelBox:=AdvMessageBox(S,Params,mfInformation+mfInsertInApp+mfOKButton+mfCancelButton);
end;
function b2i(B: boolean): longint;
begin
if b then b2i:=1 else b2i:=0;
end;
function ConfirmBox(const S: string; Params: pointer; CanCancel: boolean): word;
begin
ConfirmBox:=AdvMessageBox(S,Params,mfConfirmation+mfInsertInApp+mfYesButton+mfNoButton+
b2i(CanCancel)*mfCancelButton+b2i(not CanCancel)*mfCantCancel);
end;
function ChoiceBox(const S: string; Params: pointer; Buttons: array of string; CanCancel: boolean): word;
var BtnMask,M: longint;
I,BtnCount: integer;
begin
BtnCount:=Min(High(Buttons)-Low(Buttons)+1,High(UserButtonName)-Low(UserButtonName)+1);
BtnMask:=0; M:=mfUserBtn1;
for I:=Low(Buttons) to Low(Buttons)+BtnCount-1 do
begin
UserButtonName[Low(UserButtonName)+I-Low(Buttons)]:=Buttons[I];
BtnMask:=BtnMask or M; M:=M shl 1;
end;
ChoiceBox:=AdvMessageBox(S,Params,mfConfirmation+BtnMask+
b2i(CanCancel)*mfCancelButton+b2i(not CanCancel)*mfCantCancel);
end;
function IsSeparator(P: PMenuItem): boolean;
begin
IsSeparator:=(P<>nil) and (P^.Name=nil) and (P^.HelpCtx=hcNoContext);
end;
function IsSubMenu(P: PMenuItem): boolean;
begin
IsSubMenu:=(P<>nil) and (P^.Name<>nil) and (P^.Command=0) and (P^.SubMenu<>nil);
end;
function SearchMenuItem(Menu: PMenu; Cmd: word): PMenuItem;
var P,I: PMenuItem;
begin
I:=nil;
if Menu=nil then P:=nil else P:=Menu^.Items;
while (P<>nil) and (I=nil) do
begin
if IsSubMenu(P) then
I:=SearchMenuItem(P^.SubMenu,Cmd);
if I=nil then
if P^.Command=Cmd then I:=P else
P:=P^.Next;
end;
SearchMenuItem:=I;
end;
procedure SetMenuItemParam(Menu: PMenuItem; Param: string);
begin
if Menu=nil then Exit;
if Menu^.Param<>nil then DisposeStr(Menu^.Param);
Menu^.Param:=NewStr(Param);
end;
function UpdateMenu(M: PMenu): boolean;
var P: PMenuItem;
IsEnabled: boolean;
begin
if M=nil then begin UpdateMenu:=false; Exit; end;
P:=M^.Items; IsEnabled:=false;
while (P<>nil) do
begin
if IsSubMenu(P) then
begin
P^.Disabled:=not UpdateMenu(P^.SubMenu);
if not P^.Disabled then
IsEnabled:=true;
end
else
begin
if not IsSeparator(P) and
Application^.CommandEnabled(P^.Command) then
begin
p^.disabled:=false;
IsEnabled:=true;
end;
end;
P:=P^.Next;
end;
UpdateMenu:=IsEnabled;
end;
function SearchSubMenu(M: PMenu; Index: Sw_integer): PMenuItem;
var P,C: PMenuItem;
Count: Sw_integer;
begin
P:=nil; Count:=-1;
if M<>nil then C:=M^.Items else C:=nil;
while (C<>nil) and (P=nil) do
begin
if IsSubMenu(C) then
begin
Inc(Count);
if Count=Index then P:=C;
end;
C:=C^.Next;
end;
SearchSubMenu:=P;
end;
procedure AppendMenuItem(M: PMenu; I: PMenuItem);
var P: PMenuItem;
begin
if (M=nil) or (I=nil) then Exit;
I^.Next:=nil;
if M^.Items=nil then M^.Items:=I else
begin
P:=M^.Items;
while (P^.Next<>nil) do P:=P^.Next;
P^.Next:=I;
end;
end;
procedure DisposeMenuItem(P: PMenuItem);
begin
if P<>nil then
begin
if IsSubMenu(P) then DisposeMenu(P^.SubMenu) else
if IsSeparator(P)=false then
if P^.Param<>nil then DisposeStr(P^.Param);
if P^.Name<>nil then DisposeStr(P^.Name);
Dispose(P);
end;
end;
procedure RemoveMenuItem(Menu: PMenu; I: PMenuItem);
var P,PrevP: PMenuItem;
begin
if (Menu=nil) or (I=nil) then Exit;
P:=Menu^.Items; PrevP:=nil;
while (P<>nil) do
begin
if P=I then
begin
if Menu^.Items<>I then PrevP^.Next:=P^.Next
else Menu^.Items:=P^.Next;
DisposeMenuItem(P);
Break;
end;
PrevP:=P; P:=P^.Next;
end;
end;
function GetMenuItemBefore(Menu: PMenu; BeforeOf: PMenuItem): PMenuItem;
var P,C: PMenuItem;
begin
P:=nil;
if Menu<>nil then C:=Menu^.Items else C:=nil;
while (C<>nil) do
begin
if C^.Next=BeforeOf then begin P:=C; Break; end;
C:=C^.Next;
end;
GetMenuItemBefore:=P;
end;
procedure NotImplemented;
begin
InformationBox(msg_functionnotimplemented,nil);
end;
procedure InsertButtons(ADialog: PDialog);
var R : TRect;
W,H : Sw_integer;
X : Sw_integer;
X1,X2: Sw_integer;
begin
with ADialog^ do
begin
GetExtent(R);
W:=R.B.X-R.A.X; H:=(R.B.Y-R.A.Y);
R.Assign(0,0,W,H+3); ChangeBounds(R);
X:=W div 2; X1:=X div 2+1; X2:=X+X1-1;
R.Assign(X1-3,H,X1+7,H+2);
Insert(New(PButton, Init(R, btn_OK, cmOK, bfDefault)));
R.Assign(X2-7,H,X2+3,H+2);
Insert(New(PButton, Init(R, btn_Cancel, cmCancel, bfNormal)));
SelectNext(true);
end;
end;
procedure InsertOK(ADialog: PDialog);
var BW: Sw_integer;
R: TRect;
begin
with ADialog^ do
begin
GetBounds(R); R.Grow(0,1); Inc(R.B.Y);
ChangeBounds(R);
BW:=10;
R.A.Y:=R.B.Y-2; R.B.Y:=R.A.Y+2;
R.A.X:=R.A.X+(R.B.X-R.A.X-BW) div 2; R.B.X:=R.A.X+BW;
Insert(New(PButton, Init(R, btn_OK, cmOK, bfDefault)));
SelectNext(true);
end;
end;
procedure ShowMessage(Msg: string);
var R: TRect;
Width: Sw_integer;
begin
Width:=length(Msg)+4*2;
if Width<(Desktop^.Size.X div 2) then Width:=(Desktop^.Size.X div 2);
R.Assign(0,0,Width,5);
New(MessageDialog, Init(R, ''));
with MessageDialog^ do
begin
Flags:=0;
GetExtent(R); R.Grow(-4,-2);
if copy(Msg,1,1)<>^C then Msg:=^C+Msg;
Insert(New(PStaticText, Init(R, Msg)));
end;
Application^.Insert(MessageDialog);
end;
procedure HideMessage;
begin
if MessageDialog<>nil then
begin
Application^.Delete(MessageDialog);
Dispose(MessageDialog, Done);
MessageDialog:=nil;
end;
end;
constructor TDDHelperLB.Init(ALink: PDropDownListBox; var Bounds: TRect; ANumCols: Word; AScrollBar: PScrollBar);
begin
inherited Init(Bounds,ANumCols,AScrollBar);
EventMask:=EventMask or (evMouseMove+evIdle);
{ Options:=Options or ofPreProcess;}
Link:=ALink;
end;
procedure TDDHelperLB.SetState(AState: Word; Enable: Boolean);
{var OState: longint;}
begin
{ OState:=State;}
inherited SetState(AState,Enable);
{ if (((State xor OState) and sfFocused)<>0) and (GetState(sfFocused)=false) then
Link^.DropList(false);}
end;
function TDDHelperLB.GetText(Item,MaxLen: Sw_Integer): String;
var P: pointer;
S: string;
begin
P:=List^.At(Item);
if Link=nil then S:='' else
S:=Link^.GetText(P,MaxLen);
GetText:=S;
end;
function TDDHelperLB.GetLocalMenu: PMenu;
begin
GetLocalMenu:=Link^.LBGetLocalMenu;
end;
function TDDHelperLB.GetCommandTarget: PView;
begin
GetCommandTarget:=Link^.LBGetCommandTarget;
end;
procedure TDDHelperLB.HandleEvent(var Event: TEvent);
const
MouseAutosToSkip = 4;
var
Mouse : TPoint;
OldItem, NewItem : Sw_Integer;
ColWidth : sw_integer;
Count : Sw_Word;
GoSelectItem: sw_integer;
MouseWhere: TPoint;
begin
GoSelectItem:=-1;
TView.HandleEvent(Event);
case Event.What of
evMouseDown :
if MouseInView(Event.Where)=false then
GoSelectItem:=-2
else
begin
ColWidth := Size.X div NumCols + 1;
OldItem := Focused;
MakeLocal(Event.Where, Mouse);
if MouseInView(Event.Where) then
NewItem := Mouse.Y + (Size.Y * (Mouse.X div ColWidth)) + TopItem
else
NewItem := OldItem;
Count := 0;
repeat
if NewItem <> OldItem then
begin
FocusItemNum(NewItem);
DrawView;
end;
OldItem := NewItem;
MakeLocal(Event.Where, Mouse);
if MouseInView(Event.Where) then
NewItem := Mouse.Y + (Size.Y * (Mouse.X div ColWidth)) + TopItem
else
begin
if NumCols = 1 then
begin
if Event.What = evMouseAuto then Inc(Count);
if Count = MouseAutosToSkip then
begin
Count := 0;
if Mouse.Y < 0 then NewItem := Focused-1
else if Mouse.Y >= Size.Y then NewItem := Focused+1;
end;
end
else
begin
if Event.What = evMouseAuto then Inc(Count);
if Count = MouseAutosToSkip then
begin
Count := 0;
if Mouse.X < 0 then NewItem := Focused-Size.Y
else if Mouse.X >= Size.X then NewItem := Focused+Size.Y
else if Mouse.Y < 0 then
NewItem := Focused - Focused mod Size.Y
else if Mouse.Y > Size.Y then
NewItem := Focused - Focused mod Size.Y + Size.Y - 1;
end
end;
end;
until not MouseEvent(Event, evMouseMove + evMouseAuto);
FocusItemNum(NewItem);
DrawView;
if Event.Double and (Range > Focused) then SelectItem(Focused);
ClearEvent(Event);
GoSelectItem:=Focused;
end;
evMouseMove,evMouseAuto:
if GetState(sfFocused) then
if MouseInView(Event.Where) then
begin
MakeLocal(Event.Where,Mouse);
FocusItemNum(TopItem+Mouse.Y);
ClearEvent(Event);
end;
evKeyDown :
begin
if (Event.KeyCode=kbEsc) then
begin
GoSelectItem:=-2;
ClearEvent(Event);
end else
if ((Event.KeyCode=kbEnter) or (Event.CharCode = ' ')) and
(Focused < Range) then
begin
GoSelectItem:=Focused;
NewItem := Focused;
end
else
case CtrlToArrow(Event.KeyCode) of
kbUp : NewItem := Focused - 1;
kbDown : NewItem := Focused + 1;
kbRight: if NumCols > 1 then NewItem := Focused + Size.Y else Exit;
kbLeft : if NumCols > 1 then NewItem := Focused - Size.Y else Exit;
kbPgDn : NewItem := Focused + Size.Y * NumCols;
kbPgUp : NewItem := Focused - Size.Y * NumCols;
kbHome : NewItem := TopItem;
kbEnd : NewItem := TopItem + (Size.Y * NumCols) - 1;
kbCtrlPgDn: NewItem := Range - 1;
kbCtrlPgUp: NewItem := 0;
else
Exit;
end;
FocusItemNum(NewItem);
DrawView;
ClearEvent(Event);
end;
evBroadcast :
case Event.Command of
cmReceivedFocus :
if (Event.InfoPtr<>@Self) and (InClose=false) then
begin
GoSelectItem:=-2;
end;
else
if Options and ofSelectable <> 0 then
if (Event.Command = cmScrollBarClicked) and
((Event.InfoPtr = HScrollBar) or (Event.InfoPtr = VScrollBar)) then
Select
else
if (Event.Command = cmScrollBarChanged) then
begin
if (VScrollBar = Event.InfoPtr) then
begin
FocusItemNum(VScrollBar^.Value);
DrawView;
end
else
if (HScrollBar = Event.InfoPtr) then
DrawView;
end;
end;
evIdle :
begin
MouseWhere.X:=MouseWhereX shr 3; MouseWhere.Y:=MouseWhereY shr 3;
if MouseInView(MouseWhere)=false then
if abs(GetDosTicks-LastTT)>=1 then
begin
LastTT:=GetDosTicks;
MakeLocal(MouseWhere,Mouse);
if ((Mouse.Y<-1) or (Mouse.Y>=Size.Y)) and
((0<=Mouse.X) and (Mouse.X<Size.X)) then
if Range>0 then
if Mouse.Y<0 then
FocusItemNum(Focused-(0-Mouse.Y))
else
FocusItemNum(Focused+(Mouse.Y-(Size.Y-1)));
end;
end;
end;
if (Range>0) and (GoSelectItem<>-1) then
begin
InClose:=true;
if GoSelectItem=-2 then
Link^.DropList(false)
else
SelectItem(GoSelectItem);
end;
end;
procedure TDDHelperLB.SelectItem(Item: Sw_Integer);
begin
inherited SelectItem(Item);
Link^.FocusItem(Focused);
Link^.DropList(false);
end;
constructor TDropDownListBox.Init(var Bounds: TRect; ADropLineCount: Sw_integer; AList: PCollection);
begin
inherited Init(Bounds);
Options:=Options or (ofSelectable);
EventMask:=EventMask or (evBroadcast);
DropLineCount:=ADropLineCount;
NewList(AList);
end;
procedure TDropDownListBox.HandleEvent(var Event: TEvent);
var DontClear: boolean;
Count: sw_integer;
begin
case Event.What of
evKeyDown :
if GetState(sfFocused) then
begin
DontClear:=false;
Count:=GetItemCount;
if Count>0 then
case Event.KeyCode of
kbUp :
if Focused>0 then
FocusItem(Focused-1);
kbDown :
if Focused<Count-1 then
FocusItem(Focused+1);
kbHome :
FocusItem(0);
kbEnd :
FocusItem(Count-1);
kbEnter,
kbPgDn :
DropList(true);
else DontClear:=true;
end;
if DontClear=false then ClearEvent(Event);
end;
evBroadcast :
case Event.Command of
cmReleasedFocus :
if (ListBox<>nil) and (Event.InfoPtr=ListBox) then
DropList(false);
cmListItemSelected :
if (ListBox<>nil) and (Event.InfoPtr=ListBox) then
begin
FocusItem(ListBox^.Focused);
Text:=GetText(List^.At(Focused),High(Text));
DrawView;
DropList(false);
end;
end;
evMouseDown :
if MouseInView(Event.Where) then
begin
DropList(not ListDropped);
ClearEvent(Event);
end;
end;
inherited HandleEvent(Event);
end;
function TDropDownListBox.GetText(Item: pointer; MaxLen: Sw_integer): string;
var S: string;
begin
S:=GetStr(Item);
GetText:=copy(S,1,MaxLen);
end;
procedure TDropDownListBox.NewList(AList: PCollection);
begin
if List<>nil then Dispose(List, Done); List:=nil;
List:=AList; FocusItem(0);
end;
procedure TDropDownListBox.CreateListBox(var R: TRect);
var R2: TRect;
begin
R2.Copy(R); R2.A.X:=R2.B.X-1;
New(SB, Init(R2));
Dec(R.B.X);
New(ListBox, Init(@Self,R,1,SB));
end;
procedure TDropDownListBox.DropList(Drop: boolean);
var R: TRect;
LB: PListBox;
begin
if (ListDropped=Drop) then Exit;
if Drop then
begin
R.Assign(Origin.X+1,Origin.Y+Size.Y,Origin.X+Size.X,Origin.Y+Size.Y+DropLineCount);
if Owner<>nil then Owner^.Lock;
CreateListBox(R);
if SB<>nil then
Owner^.Insert(SB);
if ListBox<>nil then
begin
ListBox^.NewList(List);
ListBox^.FocusItem(Focused);
Owner^.Insert(ListBox);
end;
if Owner<>nil then Owner^.UnLock;
end
else
begin
if Owner<>nil then Owner^.Lock;
if ListBox<>nil then
begin
{ ListBox^.List:=nil;}
LB:=ListBox; ListBox:=nil; { this prevents GPFs while deleting }
Dispose(LB, Done);
end;
if SB<>nil then
begin
Dispose(SB, Done);
SB:=nil;
end;
Select;
if Owner<>nil then Owner^.UnLock;
end;
ListDropped:=Drop;
DrawView;
end;
function TDropDownListBox.GetItemCount: sw_integer;
var Count: sw_integer;
begin
if assigned(List)=false then Count:=0 else
Count:=List^.Count;
GetItemCount:=Count;
end;
procedure TDropDownListBox.FocusItem(Item: sw_integer);
var P: pointer;
begin
Focused:=Item;
if assigned(ListBox) and (Item>=0) then
ListBox^.FocusItem(Item);
if (GetItemCount>0) and (Focused>=0) then
begin
P:=List^.At(Focused);
Text:=GetText(P,Size.X-4);
end;
DrawView;
end;
function TDropDownListBox.LBGetLocalMenu: PMenu;
begin
LBGetLocalMenu:=nil;
end;
function TDropDownListBox.LBGetCommandTarget: PView;
begin
LBGetCommandTarget:=@Self;
end;
procedure TDropDownListBox.SetState(AState: Word; Enable: Boolean);
begin
inherited SetState(AState,Enable);
if (AState and (sfSelected + sfActive + sfFocused)) <> 0 then DrawView;
end;
procedure TDropDownListBox.Draw;
var B: TDrawBuffer;
C,TextC: word;
LC: AnsiChar;
begin
if GetState(sfFocused)=false then
begin
C:=GetColor(2);
TextC:=GetColor(2);
end
else
begin
C:=GetColor(3);
TextC:=GetColor(3);
end;
MoveChar(B,' ',C,Size.X);
MoveStr(B[1],copy(Text,1,Size.X-2),TextC);
if ListDropped then LC:='^' else LC:='v';
MoveChar(B[Size.X-2],LC,C,1);
WriteLine(0,0,Size.X,Size.Y,B);
end;
function TDropDownListBox.GetPalette: PPalette;
const P: string[length(CListViewer)] = CListViewer;
begin
GetPalette:=@P;
end;
destructor TDropDownListBox.Done;
begin
if ListDropped then DropList(false);
inherited Done;
end;
constructor TGroupView.Init(var Bounds: TRect; AText: String; ALink: PView);
begin
inherited Init(Bounds,AText,ALink);
end;
procedure TGroupView.Draw;
var B: TDrawBuffer;
FrameC,LabelC: word;
begin
FrameC:=GetColor(1);
if Light then
LabelC:=GetColor(2)+GetColor(4) shl 8
else
LabelC:=GetColor(1)+GetColor(3) shl 8;
{ First Line }
MoveChar(B[0],''#$DA'',FrameC,1);
MoveChar(B[1],''#$C4'',FrameC,Size.X-2);
MoveChar(B[Size.X-1],''#$BF'',FrameC,1);
if Text<>nil then
begin
MoveCStr(B[1],' '+Text^+' ',LabelC);
end;
WriteLine(0,0,Size.X,1,B);
{ Mid Lines }
MoveChar(B[0],''#$B3'',FrameC,1);
MoveChar(B[1],' ',FrameC,Size.X-2);
MoveChar(B[Size.X-1],''#$B3'',FrameC,1);
WriteLine(0,1,Size.X,Size.Y-2,B);
{ Last Line }
MoveChar(B[0],''#$C0'',FrameC,1);
MoveChar(B[1],''#$C4'',FrameC,Size.X-2);
MoveChar(B[Size.X-1],''#$D9'',FrameC,1);
WriteLine(0,Size.Y-1,Size.X,1,B);
end;
function TPlainCheckBoxes.GetPalette: PPalette;
const P: string[length(CPlainCluster)] = CPlainCluster;
begin
GetPalette:=@P;
end;
function TPlainRadioButtons.GetPalette: PPalette;
const P: string[length(CPlainCluster)] = CPlainCluster;
begin
GetPalette:=@P;
end;
constructor TScrollerRadioButtons.Init (Var Bounds: TRect; AStrings: PSItem; aVScrollBar:PScrollBar);
var Y : sw_word;
begin
inherited init (Bounds, AStrings);
VScrollBar:=aVScrollBar;
EventMask := evMouseWheel + evMouseDown + evKeyDown + evCommand + evBroadcast;
Y:=Strings.count;
if (VScrollBar<> nil) and (Y>=size.Y) and (Size.Y>0) then
VScrollBar^.SetParams(0, 0,Y-Size.Y, Size.Y-1, VScrollBar^.ArStep); { Set vert scrollbar }
end;
procedure TScrollerRadioButtons.HandleEvent (Var Event: TEvent);
VAR I: Sw_Integer; Mouse: TPoint;
LinesScroll : sw_integer;
begin
If ((Options AND ofSelectable) <> 0) Then
begin
If (Event.What = evMouseWheel) Then Begin { Mouse wheel event }
if (Event.Wheel=mwDown) then { Mouse scroll down }
begin
LinesScroll:=1;
if Event.Double then LinesScroll:=LinesScroll+4;
ScrollTo(Delta.X, Delta.Y + LinesScroll);
ClearEvent(Event); { Event was handled }
end else
if (Event.Wheel=mwUp) then { Mouse scroll up }
begin
LinesScroll:=-1;
if Event.Double then LinesScroll:=LinesScroll-4;
ScrollTo(Delta.X, Delta.Y + LinesScroll);
ClearEvent(Event); { Event was handled }
end;
end else
if (Event.What = evMouseDown) Then Begin { Mouse down event }
if (VScrollBar<>nil) then begin { mouse click if we have scrollbar}
MakeLocal(Event.Where, Mouse); { Make point local }
I := FindSel(Mouse); { Find selected item }
If (I <> -1) Then { Check in view }
If ButtonState(I) Then Sel := I; { If enabled select }
DrawView; { Now draw changes }
Repeat
MakeLocal(Event.Where, Mouse); { Make point local }
Until NOT MouseEvent(Event, evMouseMove); { Wait for mouse up }
MakeLocal(Event.Where, Mouse); { Make point local }
If (FindSel(Mouse) = Sel) AND ButtonState(Sel) { If valid/selected }
Then Begin
Press(Sel); { Call pressed }
DrawView; { Now draw changes }
End;
ClearEvent(Event); { Event was handled }
end;
end;
end;
Inherited HandleEvent(Event); { Call ancestor }
If (Event.What = evBroadcast) AND
(Event.Command = cmScrollBarChanged) AND { Scroll bar change }
({(Event.InfoPtr = HScrollBar) OR} { Our scrollbar? }
(Event.InfoPtr = VScrollBar)) Then
begin
ScrollDraw;
ClearEvent(Event);
end;
end;
procedure TScrollerRadioButtons.ScrollTo (X,Y: Sw_Integer);
begin
if X>Size.X then X:=Size.X-1;
if X<0 then X:=0;
if (Y>(Strings.Count-Size.Y)) then Y:=(Strings.Count-Size.Y);
if Y<0 then Y:=0;
if Delta.Y<>Y then
begin
Delta.Y:=Y;
if (VScrollBar<>nil) then if VScrollBar^.Value<>Delta.Y then VScrollBar^.SetValue(Delta.Y);
DrawView;
end;
end;
function TScrollerRadioButtons.FindSel (P: TPoint): Sw_Integer;
var I, S, Vh: Sw_Integer; R: TRect;
begin
GetExtent(R); { Get view extents }
If R.Contains(P) Then Begin { Point in view }
Vh := Size.Y; { View height }
I := 0; { Preset zero value }
{While (P.X >= Column(I+Vh)) Do Inc(I, Vh);} { Inc view size }
S := I + P.Y+ Delta.Y; { Line to select }
If ((S >= 0) AND (S < Strings.Count)) { Valid selection }
Then FindSel := S Else FindSel := -1; { Return selected item }
End Else FindSel := -1; { Point outside view }
end;
procedure TScrollerRadioButtons.MovedTo (Item: Sw_Integer);
begin
if (Item<Delta.Y) then begin Delta.Y:=Item; end;
if (Item>=(Size.Y+Delta.Y)) then begin Delta.Y:=Item-Size.Y+1; end;
if (VScrollBar<>nil) then if VScrollBar^.Value<>Delta.Y then VScrollBar^.SetValue(Delta.Y);
inherited MovedTo(Item);
end;
procedure TScrollerRadioButtons.ScrollDraw;
begin
if (VScrollBar<> nil) then Delta.Y:=VScrollBar^.Value;
Drawview;
end;
procedure TScrollerRadioButtons.CentreSelected;
var Y : Sw_Integer;
begin
if (VScrollBar<> nil) then
begin
Y:=Sel-(Size.Y div 2);
if Y<0 then Y:=0;
if (Size.Y+Y) >= Strings.Count then Y:=Strings.Count-Size.Y;
if Y<0 then Y:=0;
if Delta.Y<>Y then
begin
Delta.Y:=Y;
VScrollBar^.SetValue(Y);
DrawView;
end;
end;
end;
procedure TScrollerRadioButtons.Draw;
begin
if VScrollBar=nil then begin inherited draw; exit; end;
if Size.Y >= Strings.Count then begin inherited draw; exit; end;
DrawScrollMultiBox(' ( ) ',' *');
end;
procedure TScrollerRadioButtons.DrawScrollMultiBox (Const Icon, Marker: String);
VAR I, J, Cur, Col: Sw_Integer;
CNorm, CSel, CDis, Color: Word; B: TDrawBuffer;
begin
CNorm := GetColor($0301); { Normal colour }
CSel := GetColor($0402); { Selected colour }
CDis := GetColor($0505); { Disabled colour }
For I := 0 To Size.Y-1 Do Begin { For each line }
MoveChar(B, ' ', Byte(CNorm), Size.X); { Fill buffer }
{For J := 0 To (Strings.Count - 1) DIV Size.Y + 1
Do}
J:=0;
Begin
Cur := {J*Size.Y} Delta.Y + I; { Current line }
If (Cur < Strings.Count) Then Begin
Col := {Column(Cur)}1; { Calc column }
If (Col + CStrLen(PString(Strings.At(Cur))^)+
5 < Sizeof(TDrawBuffer) DIV SizeOf(Word))
AND (Col < Size.X) Then Begin { Text fits in column }
If NOT ButtonState(Cur) Then
Color := CDis Else If (Cur = Sel) AND { Disabled colour }
(State and sfFocused <> 0) Then
Color := CSel Else { Selected colour }
Color := CNorm; { Normal colour }
MoveChar(B[Col], ' ', Byte(Color),
Size.X-Col); { Set this colour }
MoveStr(B[Col], Icon, Byte(Color)); { Transfer icon string }
WordRec(B[Col+2]).Lo := Byte(Marker[
MultiMark(Cur) + 1]); { Transfer marker }
MoveCStr(B[Col+5], PString(Strings.At(
Cur))^, Color); { Transfer item string }
If ShowMarkers AND (State AND sfFocused <> 0)
AND (Cur = Sel) Then Begin { Current is selected }
WordRec(B[Col]).Lo := Byte(SpecialChars[0]);
WordRec(B[{Column(Cur+Size.Y)}1-1]).Lo
:= Byte(SpecialChars[1]); { Set special character }
End;
End;
End;
End;
WriteBuf(0, I, Size.X, 1, B); { Write buffer }
End;
SetCursor({Column(Sel)}1+2,{Row(Sel)}Sel-Delta.Y);
end;
constructor TAdvancedListBox.Load(var S: TStream);
begin
inherited Load(S);
S.Read(Default,SizeOf(Default));
end;
procedure TAdvancedListBox.Store(var S: TStream);
begin
inherited Store(S);
S.Write(Default,SizeOf(Default));
end;
procedure TNoUpdateButton.HandleEvent(var Event: TEvent);
begin
if (Event.What<>evBroadcast) or (Event.Command<>cmCommandSetChanged) then
inherited HandleEvent(Event);
end;
constructor TPanel.Init(var Bounds: TRect);
begin
inherited Init(Bounds);
Options:=Options or (ofSelectable+ofTopSelect);
GrowMode:=gfGrowHiX+gfGrowHiY;
end;
procedure TAdvMessageBox.HandleEvent(var Event: TEvent);
var I: integer;
begin
if (not CanCancel) and (Event.What=evCommand) and (Event.Command=cmCancel) then
ClearEvent(Event);
inherited HandleEvent(Event);
case Event.What of
evCommand:
begin
for I:=Low(UserButtonCmd) to High(UserButtonCmd) do
if Event.Command=UserButtonCmd[I] then
if State and sfModal <> 0 then
begin
EndModal(Event.Command);
ClearEvent(Event);
end;
end;
end;
end;
procedure ClearFormatParams;
begin
FormatParamCount:=0; FillChar(FormatParams,sizeof(FormatParams),0);
FormatParamStrCount:=0;
end;
procedure AddFormatParam(P: pointer);
begin
Inc(FormatParamCount);
FormatParams[FormatParamCount]:=ptrint(P);
end;
procedure AddFormatParamInt(L: longint);
begin
Inc(FormatParamCount);
FormatParams[FormatParamCount]:=L;
end;
procedure AddFormatParamChar(C: AnsiChar);
begin
AddFormatParamInt(ord(C));
end;
procedure AddFormatParamStr(const S: string);
begin
Inc(FormatParamStrCount);
FormatParamStrs[FormatParamStrCount]:=S;
AddFormatParam(@FormatParamStrs[FormatParamStrCount]);
end;
function FormatStrF(const Format: string; var Params): string;
var S: string;
begin
S:='';
FormatStr(S,Format,Params);
FormatStrF:=S;
end;
function FormatStrStr(const Format, Param: string): string;
var S: string;
P: pointer;
begin
P:=@Param;
FormatStr(S,Format,P);
FormatStrStr:=S;
end;
function FormatStrStr2(const Format, Param1,Param2: string): string;
var S: string;
P: array[1..2] of pointer;
begin
P[1]:=@Param1; P[2]:=@Param2;
FormatStr(S,Format,P);
FormatStrStr2:=S;
end;
function FormatStrStr3(const Format, Param1,Param2,Param3: string): string;
var S: string;
P: array[1..3] of pointer;
begin
P[1]:=@Param1;
P[2]:=@Param2;
P[3]:=@Param3;
FormatStr(S,Format,P);
FormatStrStr3:=S;
end;
function FormatStrInt(const Format: string; L: PtrInt): string;
var S: string;
begin
FormatStr(S,Format,L);
FormatStrInt:=S;
end;
const
Cmds: array[0..3] of word =
(cmYes, cmNo, cmOK, cmCancel);
var
ButtonName: array[0..3] of string;
Titles: array[0..3] of string;
function AdvMessageBox(const Msg: String; Params: Pointer; AOptions: longint): Word;
var
R: TRect;
begin
R.Assign(0, 0, 0, 0);
AdvMessageBox := AdvMessageBoxRect(R, Msg, Params, AOptions);
end;
procedure GetStaticTextDimensions(const S: string; ViewWidth: integer; var MaxCols, Rows: integer);
var
Center: Boolean;
I, J, L, P, Y: Sw_Integer;
CurLine: string;
begin
MaxCols:=0;
L := Length(S);
P := 1;
Y := 0;
Center := False;
while (Y < 32767) and (P<=length(S)) do
begin
CurLine:='';
if P <= L then
begin
if S[P] = #3 then
begin
Center := True;
Inc(P);
end;
I := P;
repeat
J := P;
while (P <= L) and (S[P] = ' ') do Inc(P);
while (P <= L) and (S[P] <> ' ') and (S[P] <> #13) do Inc(P);
until (P > L) or (P >= I + ViewWidth) or (S[P] = #13);
if P > I + ViewWidth then
if J > I then P := J else P := I + ViewWidth;
if Center then J := (ViewWidth - P + I) div 2 else J := 0;
CurLine:=CurLine+copy(S,I,P-I);
{ MoveBuf(B[J], S[I], Color, P - I);}
while (P <= L) and (S[P] = ' ') do Inc(P);
if (P <= L) and (S[P] = #13) then
begin
Center := False;
Inc(P);
if (P <= L) and (S[P] = #10) then Inc(P);
end;
end;
if length(CurLine)>MaxCols then
MaxCols:=length(CurLine);
{ WriteLine(0, Y, Size.X, 1, B);}
Inc(Y);
end;
Rows:=Y;
end;
function AdvMessageBoxRect(var R: TRect; const Msg: String; Params: Pointer; AOptions: longint): Word;
var
I, X, ButtonCount: Sw_Integer;
Dialog: PAdvMessageBox;
Control: PView;
ButtonList: array[0..4] of PView;
S,BtnName: String;
Cols,Rows: integer;
begin
FormatStr(S, Msg, Params^);
if R.Empty then
begin
GetStaticTextDimensions(S,40,Cols,Rows);
if Cols<32 then Cols:=32; if Rows=0 then Rows:=1;
R.Assign(0,0,3+Cols+3,Rows+6);
if (AOptions and mfInsertInApp)= 0 then
R.Move((Desktop^.Size.X-(R.B.X-R.A.X)) div 2,(Desktop^.Size.Y-(R.B.Y-R.A.Y)) div 2)
else
R.Move((Application^.Size.X-(R.B.X-R.A.X)) div 2,(Application^.Size.Y-(R.B.Y-R.A.Y)) div 2);
end;
New(Dialog,Init(R, Titles[AOptions and $3]));
with Dialog^ do
begin
CanCancel:=(Options and mfCantCancel)=0;
R.Assign(3,2, Size.X-2,Size.Y-3);
Control := New(PStaticText, Init(R, S));
Insert(Control);
X := -2;
ButtonCount := 0;
for I := 0 to 3 do
if AOptions and ($10000 shl I) <> 0 then
begin
BtnName:=UserButtonName[I+1];
R.Assign(0, 0, Max(10,length(BtnName)+2), 2);
Control := New(PButton, Init(R, BtnName, UserButtonCmd[I+1], bfNormal));
Inc(X, Control^.Size.X + 2);
ButtonList[ButtonCount] := Control;
Inc(ButtonCount);
end;
for I := 0 to 3 do
if AOptions and ($0100 shl I) <> 0 then
begin
R.Assign(0, 0, 10, 2);
Control := New(PButton, Init(R, ButtonName[I], Cmds[i], bfNormal));
Inc(X, Control^.Size.X + 2);
ButtonList[ButtonCount] := Control;
Inc(ButtonCount);
end;
X := (Size.X - X) div 2;
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;
SelectNext(False);
end;
if AOptions and mfInsertInApp = 0 then
AdvMessageBoxRect := DeskTop^.ExecView(Dialog)
else
AdvMessageBoxRect := Application^.ExecView(Dialog);
Dispose(Dialog, Done);
end;
procedure InitAdvMsgBox;
begin
ButtonName[0] := slYes;
ButtonName[1] := slNo;
ButtonName[2] := slOk;
ButtonName[3] := slCancel;
Titles[0] := sWarning;
Titles[1] := sError;
Titles[2] := sInformation;
Titles[3] := sConfirm;
end;
procedure DoneAdvMsgBox;
begin
end;
procedure RegisterWViews;
begin
{$ifndef NOOBJREG}
RegisterType(RAdvancedListBox);
RegisterType(RColorStaticText);
RegisterType(RHSListBox);
RegisterType(RDlgWindow);
{$endif}
end;
END.
Reference in New Issue View Git Blame Copy Permalink