mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-28 10:03:50 +02:00
373 lines
14 KiB
ObjectPascal
373 lines
14 KiB
ObjectPascal
{ $Id$ }
|
|
PROGRAM TestApp;
|
|
|
|
{&PMTYPE PM} { FULL GUI MODE }
|
|
|
|
{ ******************************* REMARK ****************************** }
|
|
{ This is a basic test program to test the app framework. In use will }
|
|
{ be menus, statuslines, windows, dialogs, scrollbars, statictext, }
|
|
{ radiobuttons, check boxes, list boxes and input lines. }
|
|
{ }
|
|
{ Working compilers: }
|
|
{ WINDOWS BPW, VP2, Delphi1, FPC WIN (0.9912) }
|
|
{ DOS has draw bugs but works for BP and FPC DOS (GO32V2) }
|
|
{ OS2 dows not work still some PM bits to do }
|
|
{ }
|
|
{ Not working: }
|
|
{ Delphi3, Delphi5 (sus 4) will compile but Tgroup.ForEach etc U/S. }
|
|
{ Sybil2 Win32 should work but to big for demo mode so unsure! }
|
|
{ }
|
|
{ Special things to try out: }
|
|
{ Check out the standard windows minimize etc icons. }
|
|
{ }
|
|
{ }
|
|
{ Comments: }
|
|
{ There is alot that may seem more complex than it needs to but }
|
|
{ I have much more elaborate objects operating such as bitmaps, }
|
|
{ bitmap buttons, percentage bars etc and they need these hooks. }
|
|
{ Basically the intention is to be able to port existing TV apps }
|
|
{ as a start point and then start to optimize and use the new }
|
|
{ GUI specific objects. I will try to get some documentation }
|
|
{ done on how everything works because some things are hard to }
|
|
{ follow in windows. }
|
|
{ ****************************** END REMARK *** Leon de Boer, 06Nov99 * }
|
|
|
|
{$I Platform.inc}
|
|
USES
|
|
{$IFDEF OS_OS2} Os2Def, os2PmApi, {$ENDIF}
|
|
Objects, Drivers, Views, Menus, Dialogs, App, { Standard GFV units }
|
|
{$ifdef TEST}
|
|
AsciiTab,
|
|
{$endif TEST}
|
|
{$ifdef DEBUG}
|
|
Gfvgraph,
|
|
{$endif DEBUG}
|
|
Gadgets;
|
|
|
|
|
|
CONST cmAppToolbar = 1000;
|
|
cmWindow1 = 1001;
|
|
cmWindow2 = 1002;
|
|
cmWindow3 = 1003;
|
|
cmAscii = 1010;
|
|
cmCloseWindow1 = 1101;
|
|
cmCloseWindow2 = 1102;
|
|
cmCloseWindow3 = 1103;
|
|
|
|
{---------------------------------------------------------------------------}
|
|
{ TTestAppp OBJECT - STANDARD APPLICATION WITH MENU }
|
|
{---------------------------------------------------------------------------}
|
|
TYPE
|
|
PTVDemo = ^TTVDemo;
|
|
TTVDemo = OBJECT (TApplication)
|
|
Clock: PClockView;
|
|
Heap: PHeapView;
|
|
P1,P2,P3 : PGroup;
|
|
{$ifdef TEST}
|
|
ASCIIChart : PAsciiChart;
|
|
{$endif TEST}
|
|
CONSTRUCTOR Init;
|
|
PROCEDURE Idle; Virtual;
|
|
PROCEDURE HandleEvent(var Event : TEvent);virtual;
|
|
PROCEDURE InitMenuBar; Virtual;
|
|
PROCEDURE InitDeskTop; Virtual;
|
|
PROCEDURE Window1;
|
|
PROCEDURE Window2;
|
|
PROCEDURE Window3;
|
|
PROCEDURE AsciiWindow;
|
|
PROCEDURE CloseWindow(var P : PGroup);
|
|
End;
|
|
|
|
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
|
|
{ TTvDemo OBJECT METHODS }
|
|
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
|
|
|
|
CONSTRUCTOR TTvDemo.Init;
|
|
VAR R: TRect;
|
|
BEGIN
|
|
Inherited Init;
|
|
{ Initialize demo gadgets }
|
|
|
|
GetExtent(R);
|
|
R.A.X := R.B.X - 9; R.B.Y := R.A.Y + 1;
|
|
Clock := New(PClockView, Init(R));
|
|
Insert(Clock);
|
|
|
|
GetExtent(R);
|
|
Dec(R.B.X);
|
|
R.A.X := R.B.X - 12; R.A.Y := R.B.Y - 1;
|
|
Heap := New(PHeapView, Init(R));
|
|
Insert(Heap);
|
|
END;
|
|
|
|
procedure TTVDemo.Idle;
|
|
|
|
function IsTileable(P: PView): Boolean; far;
|
|
begin
|
|
IsTileable := (P^.Options and ofTileable <> 0) and
|
|
(P^.State and sfVisible <> 0);
|
|
end;
|
|
|
|
{$ifdef DEBUG}
|
|
Var
|
|
WasSet : boolean;
|
|
{$endif DEBUG}
|
|
begin
|
|
inherited Idle;
|
|
{$ifdef DEBUG}
|
|
if WriteDebugInfo then
|
|
begin
|
|
WasSet:=true;
|
|
WriteDebugInfo:=false;
|
|
end
|
|
else
|
|
WasSet:=false;
|
|
{$endif DEBUG}
|
|
if WriteDebugInfo then
|
|
Clock^.Update;
|
|
Heap^.Update;
|
|
{$ifdef DEBUG}
|
|
if WasSet then
|
|
WriteDebugInfo:=true;
|
|
{$endif DEBUG}
|
|
if Desktop^.FirstThat(@IsTileable) <> nil then
|
|
EnableCommands([cmTile, cmCascade])
|
|
else
|
|
DisableCommands([cmTile, cmCascade]);
|
|
end;
|
|
|
|
PROCEDURE TTVDemo.HandleEvent(var Event : TEvent);
|
|
BEGIN
|
|
Inherited HandleEvent(Event); { Call ancestor }
|
|
If (Event.What = evCommand) Then Begin
|
|
Case Event.Command Of
|
|
cmWindow1 : Window1;
|
|
cmWindow2 : Window2;
|
|
cmWindow3 : Window3;
|
|
cmAscii : AsciiWindow;
|
|
cmCloseWindow1 : CloseWindow(P1);
|
|
cmCloseWindow2 : CloseWindow(P2);
|
|
cmCloseWindow3 : CloseWindow(P3);
|
|
Else Exit; { Unhandled exit }
|
|
End;
|
|
End;
|
|
ClearEvent(Event);
|
|
END;
|
|
|
|
{--TTvDemo------------------------------------------------------------------}
|
|
{ InitMenuBar -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 05Nov99 LdB }
|
|
{---------------------------------------------------------------------------}
|
|
PROCEDURE TTVDemo.InitMenuBar;
|
|
VAR R: TRect;
|
|
BEGIN
|
|
GetExtent(R); { Get view extents }
|
|
R.B.Y := R.A.Y + 1; { One line high }
|
|
MenuBar := New(PMenuBar, Init(R, NewMenu(
|
|
NewSubMenu('~F~ile', 0, NewMenu(
|
|
StdFileMenuItems(Nil)), { Standard file menu }
|
|
NewSubMenu('~E~dit', 0, NewMenu(
|
|
StdEditMenuItems(Nil)), { Standard edit menu }
|
|
NewSubMenu('~T~est', 0, NewMenu(
|
|
NewItem('Ascii Chart','',kbNoKey,cmAscii,hcNoContext,
|
|
NewItem('Window 1','',kbNoKey,cmWindow1,hcNoContext,
|
|
NewItem('Window 2','',kbNoKey,cmWindow2,hcNoContext,
|
|
NewItem('Window 3','',kbNoKey,cmWindow3,hcNoContext,
|
|
NewItem('Close Window 1','',kbNoKey,cmCloseWindow1,hcNoContext,
|
|
NewItem('Close Window 2','',kbNoKey,cmCloseWindow2,hcNoContext,
|
|
NewItem('Close Window 3','',kbNoKey,cmCloseWindow3,hcNoContext,
|
|
Nil)))))))),
|
|
NewSubMenu('~W~indow', 0, NewMenu(
|
|
StdWindowMenuItems(Nil)), Nil))))))); { Standard window menu }
|
|
END;
|
|
|
|
{--TTvDemo------------------------------------------------------------------}
|
|
{ InitDesktop -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 08Nov99 LdB }
|
|
{---------------------------------------------------------------------------}
|
|
PROCEDURE TTvDemo.InitDesktop;
|
|
VAR R: TRect; {ToolBar: PToolBar;}
|
|
BEGIN
|
|
GetExtent(R); { Get app extents }
|
|
Inc(R.A.Y); { Adjust top down }
|
|
Dec(R.B.Y); { Adjust bottom up }
|
|
(* ToolBar := New(PToolBar, Init(R.A.X*FontWidth,
|
|
R.A.Y*FontHeight, (R.B.X-R.A.X)*FontWidth, 20,
|
|
cmAppToolBar));
|
|
If (ToolBar <> Nil) Then Begin
|
|
R.A.X := R.A.X*FontWidth;
|
|
R.A.Y := R.A.Y*FontHeight + 25;
|
|
R.B.X := -R.B.X*FontWidth;
|
|
R.B.Y := -R.B.Y*Fontheight;
|
|
ToolBar^.AddTool(NewToolEntry(cmQuit, True,
|
|
'20X20EXIT', 'ToolBar.Res'));
|
|
ToolBar^.AddTool(NewToolEntry(cmNew, True,
|
|
'20X20NEW', 'ToolBar.Res'));
|
|
ToolBar^.AddTool(NewToolEntry(cmOpen, True,
|
|
'20X20LOAD', 'ToolBar.Res'));
|
|
Insert(ToolBar);
|
|
End;*)
|
|
Desktop := New(PDeskTop, Init(R));
|
|
END;
|
|
|
|
PROCEDURE TTvDemo.Window1;
|
|
VAR R: TRect; P: PGroup;
|
|
BEGIN
|
|
{ Create a basic window with static text and radio }
|
|
{ buttons. The buttons should be orange and white }
|
|
R.Assign(5, 1, 35, 16); { Assign area }
|
|
P := New(PWindow, Init(R, 'TEST WINDOW 1', 1)); { Create a window }
|
|
If (P <> Nil) Then Begin { Window valid }
|
|
R.Assign(5, 5, 20, 6); { Assign area }
|
|
P^.Insert(New(PInputLine, Init(R, 30)));
|
|
R.Assign(5, 8, 20, 9); { Assign area }
|
|
P^.Insert(New(PRadioButtons, Init(R,
|
|
NewSItem('Test',
|
|
NewSITem('Item 2', Nil))))); { Red radio button }
|
|
R.Assign(5, 10, 28, 11); { Assign area }
|
|
P^.Insert(New(PStaticText, Init(R,
|
|
'SOME STATIC TEXT'))); { Insert static text }
|
|
End;
|
|
Desktop^.Insert(P); { Insert into desktop }
|
|
P1:=P;
|
|
END;
|
|
|
|
PROCEDURE TTvDemo.AsciiWindow;
|
|
begin
|
|
{$ifdef TEST}
|
|
if ASCIIChart=nil then
|
|
begin
|
|
New(ASCIIChart, Init);
|
|
Desktop^.Insert(ASCIIChart);
|
|
end
|
|
else
|
|
ASCIIChart^.Focus;
|
|
{$endif TEST}
|
|
end;
|
|
|
|
|
|
PROCEDURE TTvDemo.CloseWindow(var P : PGroup);
|
|
BEGIN
|
|
If Assigned(P) then
|
|
BEGIN
|
|
Desktop^.Delete(P);
|
|
Dispose(P,Done);
|
|
P:=Nil;
|
|
END;
|
|
END;
|
|
PROCEDURE TTvDemo.Window2;
|
|
VAR R: TRect; P: PGroup;
|
|
BEGIN
|
|
{ Create a basic window with check boxes. The }
|
|
{ check boxes should be orange and white }
|
|
R.Assign(15, 3, 45, 18); { Assign area }
|
|
P := New(PWindow, Init(R, 'TEST WINDOW 2', 2)); { Create window 2 }
|
|
If (P <> Nil) Then Begin { Window valid }
|
|
R.Assign(5, 5, 20, 7); { Assign area }
|
|
P^.Insert(New(PCheckBoxes, Init(R,
|
|
NewSItem('Test check',
|
|
NewSITem('Item 2', Nil))))); { Create check box }
|
|
End;
|
|
Desktop^.Insert(P); { Insert into desktop }
|
|
P2:=P;
|
|
END;
|
|
|
|
PROCEDURE TTvDemo.Window3;
|
|
VAR R: TRect; P: PGroup; B: PScrollBar;
|
|
List: PStrCollection; Lb: PListBox;
|
|
BEGIN
|
|
{ Create a basic dialog box. In it are buttons, }
|
|
{ list boxes, scrollbars, inputlines, checkboxes }
|
|
R.Assign(32, 2, 77, 18); { Assign screen area }
|
|
P := New(PDialog, Init(R, 'TEST DIALOG')); { Create dialog }
|
|
If (P <> Nil) Then Begin { Dialog valid }
|
|
R.Assign(5, 5, 20, 7); { Allocate area }
|
|
P^.Insert(New(PCheckBoxes, Init(R,
|
|
NewSItem('Test',
|
|
NewSITem('Item 2', Nil))))); { Insert check box }
|
|
R.Assign(5, 2, 20, 3); { Assign area }
|
|
B := New(PScrollBar, Init(R)); { Insert scroll bar }
|
|
If (B <> Nil) Then Begin { Scrollbar valid }
|
|
B^.SetRange(0, 100); { Set scrollbar range }
|
|
B^.SetValue(50); { Set position }
|
|
P^.Insert(B); { Insert scrollbar }
|
|
End;
|
|
R.Assign(5, 10, 20, 11); { Assign area }
|
|
P^.Insert(New(PInputLine, Init(R, 60))); { Create input line }
|
|
R.Assign(5, 13, 20, 14); { Assign area }
|
|
P^.Insert(New(PInputLine, Init(R, 60))); { Create input line }
|
|
R.Assign(40, 8, 41, 14); { Assign area }
|
|
B := New(PScrollBar, Init(R)); { Create scrollbar }
|
|
P^.Insert(B); { Insert scrollbar }
|
|
R.Assign(25, 8, 40, 14); { Assign area }
|
|
Lb := New(PListBox, Init(R, 1, B)); { Create listbox }
|
|
P^.Insert(Lb); { Insert listbox }
|
|
List := New(PStrCollection, Init(10, 5)); { Create string list }
|
|
List^.AtInsert(0, NewStr('Zebra')); { Insert text }
|
|
List^.AtInsert(1, NewStr('Apple')); { Insert text }
|
|
List^.AtInsert(2, NewStr('Third')); { Insert text }
|
|
List^.AtInsert(3, NewStr('Peach')); { Insert text }
|
|
List^.AtInsert(4, NewStr('Rabbit')); { Insert text }
|
|
List^.AtInsert(5, NewStr('Item six')); { Insert text }
|
|
List^.AtInsert(6, NewStr('Jaguar')); { Insert text }
|
|
List^.AtInsert(7, NewStr('Melon')); { Insert text }
|
|
List^.AtInsert(8, NewStr('Ninth')); { Insert text }
|
|
List^.AtInsert(9, NewStr('Last item')); { Insert text }
|
|
Lb^.Newlist(List); { Give list to listbox }
|
|
R.Assign(30, 2, 40, 4); { Assign area }
|
|
P^.Insert(New(PButton, Init(R, '~O~k', 100, bfGrabFocus)));{ Create okay button }
|
|
R.Assign(30, 15, 40, 17); { Assign area }
|
|
Desktop^.Insert(P); { Insert dialog }
|
|
P3:=P;
|
|
End;
|
|
END;
|
|
|
|
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
|
|
{ MAIN PROGRAM START }
|
|
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
|
|
VAR I: Integer; R: TRect; P: PGroup; MyApp: TTvDemo;
|
|
{$IFDEF OS_OS2} Message: QMSg; Event: TEvent; {$ENDIF}
|
|
BEGIN
|
|
(*SystemPalette := CreateRGBPalette(256); { Create palette }
|
|
For I := 0 To 15 Do Begin
|
|
GetSystemRGBEntry(I, RGB); { Get palette entry }
|
|
AddToRGBPalette(RGB, SystemPalette); { Add entry to palette }
|
|
End;*)
|
|
|
|
MyApp.Init; { Initialize app }
|
|
|
|
|
|
MyApp.Run; { Run the app }
|
|
{$IFDEF OS_OS2}
|
|
while (MyApp.EndState = 0)
|
|
AND WinGetMsg(Anchor, Message, 0, 0, 0) Do Begin
|
|
WinDispatchMsg(Anchor, Message);
|
|
NextQueuedEvent(Event);
|
|
If (event.What <> evNothing)
|
|
Then MyApp.handleEvent(Event);
|
|
End;
|
|
{$ENDIF}
|
|
MyApp.Done; { Dispose of app }
|
|
|
|
{DisposeRGBPalette(SystemPalette);}
|
|
END.
|
|
|
|
|
|
{
|
|
$Log$
|
|
Revision 1.6 2001-05-31 21:40:10 pierre
|
|
* some debug stuff changed
|
|
|
|
Revision 1.5 2001/05/04 15:43:46 pierre
|
|
* several more fixes
|
|
|
|
Revision 1.4 2001/05/04 10:46:02 pierre
|
|
* various fixes for win32 api mode
|
|
|
|
Revision 1.3 2001/05/04 08:42:55 pierre
|
|
* some corrections for linux
|
|
|
|
Revision 1.2 2000/08/24 12:00:22 marco
|
|
* CVS log and ID tags
|
|
|
|
|
|
}
|