home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Power-Programmierung
/
CD1.mdf
/
pascal
/
library
/
dos
/
tvision
/
tvgraph7
/
tvgdemo1.pas
< prev
next >
Wrap
Pascal/Delphi Source File
|
1994-01-04
|
57KB
|
1,684 lines
{***************************************}
{ }
{ TVGraphic Library Demo1 }
{ }
{ COPYRIGHT (C) 1993,1994 }
{ RICHARD P. ANDRESEN }
{ }
{***************************************}
{This demo program provides source code that illustrates the
use of the TVGraphic library. It is part of the documentation
of TVGraphic.
Things to Study:
Both very simple and complex commented Draw methods.
TDemoApp.GetEvent to see how to generate evTimerTick events.
Also how to modify/respond
to events no matter what view is modal.
The process of initializing and shutting down a TVGraphic
application is completely shown.
Setting up Menu, StatusLine, MessageBar and DeskTop.
Saving the DeskTop
Note: The code used here to reload the DeskTop from disk is not
safe in Borland's Turbo Vision. View by View LowMemory checking
in TVGraphic's TGroup.Load makes it safe here.
DOS shell and critical error handling in graphic mode are illustrated.
Examples of setting the mouse cursor grid.
Examples of using evTimerTick event.
Setting up TScroller for text and/or graphics.
Loading a .BMP bitmap file.
Building a ToolBar.
The Help window now is non-modal (acts like a regular window) if called
while the Application is modal, otherwise Help is modal.
Examples of running Dialogs using both DeskTop^.ExecView() from TV1.0
and ExecuteDialog() as used in TV2.0 are shown.
Example of how to set up and use TVGraphic's TPanWindow with TSubWindows.
Users of TVGraphic may incorporate sections of this source code
into their own programs.
----------------------------------
Significant changes in TVDemo1 (ver 1.5) from earlier TVGraphic versions.
1. TCircles.HandleEvent changed so it doesn't overwrite menus
and other modal views.
2. Help window
now both modal and non-modal
added menu redraw if Help is modal
3. TScroller
show how to change scroller step sizes
better description in complex TScroller.Draw
example of incremental background drawing
example of writing highlighted strings with WriteCStr
4. Bitmaps
load and draw .BMP file in TDemoApp.LoadBMP .
Bitmapped buttons and Toolbar - see InitToolBar.
5. note on forcing screen to color mode in TDemoApp.Init .
6. Mouse cursor
let you set speed. Restore settings after DOS shell.
7. TDemoApp.GetEvent
A. evTimerTick events are now generated and sent to all views
automatically in TProgram.GetEvent. The code that generated them
in earlier versions should be commented out.
B. the updating of the mouse cursor position has been moved to
TProgram.GetEvent. The call in earlier versions to
MCur.Move(Event.Where) should be deleted.
}
program TVGDemo1;
{$F+,X+} {+X - use Extended syntax so can call a function as if
it were a procedure.}
uses CRT, DOS, Memory, MyGraph3, GObjects, GDrivers,
MCursor2, GMENU6,
GViews, GDialogs, GMsgBox, GStdDlg,
GApp, GColors, GWindow,
BMPDrvr, GBut;
{causes compiler to link in Bitmap to this unit}
procedure BAR1_BMP; external;
{$L BAR1.OBJ}
procedure BAR2_BMP; external;
{$L BAR2.OBJ}
procedure BAR3_BMP; external;
{$L BAR3.OBJ}
procedure BAR4_BMP; external;
{$L BAR4.OBJ}
procedure BAR7_BMP; external;
{$L BAR7.OBJ}
procedure BAR8_BMP; external;
{$L BAR8.OBJ}
const
ProgName = 'TVGDemo1';
Ver = '1.50';
const
dpTV1Dialog = 3;
WinNum : integer = 0;
hcMouseGrid = 1000;
hcColorSel = 1001;
cmBMPlikebuttons = 254;
cmTVlikeButtons = 255;
cmSetColors = 1100;
cmDosCriticalError = 1101;
cmCircleWindow = 1102;
cmScrollerWindow = 1103;
cmShowMessageBar = 1104;
cmAbout = 1105;
cmOptionsSave = 1106;
cmOptionsLoad = 1107;
cmTools = 1108;
cmBMP = 1109;
cmBitBut = 1110;
cmTEdit = 1111;
cmHourGlass = 1112;
cmDeskTopStyle = 1114;
cmDeskTopOptions = 1115;
cmVersion = 1116;
cmMouseGrids = 1117;
AString = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789';
var
OldExitProc : Pointer; { Saves exit procedure address }
Graphic : boolean; { true if screen is in graphic mode }
procedure GExitProc; far; {must be Far}
{Exit procedure - restore screen to text mode if program halts}
begin
ExitProc := OldExitProc; { Restore exit procedure address }
CloseGraph; { Shut down the graphics system }
end;
function GSystemError(ErrorCode: integer; Drive: byte): Integer; far;
{must be Far}
{GSystemError handles DOS Critical Errors while in graphics mode.
Not an example of drawing Views in TVGraphics
- see .Draw methods instead for that.
Note the saving and restoring of the Viewport (vital). Also of
TextSettings which may not be necessary in every program.}
{Caution - BOMBS unless you use FarSelectKey to get user input.}
const
SRetryOrCancel: string[30] = '~Enter~: Retry ~Esc~: Cancel';
var
P: Pointer;
S: string[63];
X,YOff : integer;
SS : string;
VPort : ViewPortType;
SaveText : TextSettingsType;
begin
P := Pointer(Drive + Ord('A'));
FormatStr(S, GetCritErrorStr(ErrorCode), P);
SS := S + ' ' + SRetryOrCancel;
X := (GetMaxX - (Length(SS))*Charlen) div 2;
GetViewSettings(VPort); {save current viewport}
SetViewPort(0,0,GetMaxX,GetMaxY,ClipOn); {set to full screen}
GetTextSettings(SaveText); {save current font, style}
SetTextStyle(font8x8,HorizDir,1);
YOff := CalcVertTextOffset(MenuBar^.Size.y);
SetColor(lightcyan);
SetFillStyle(solidfill, red);
{draw over menu bar so can erase by calling MenuBar^.Draw}
Bar3d(0, 0, GetMaxX, MenuBar^.Size.y, 0, false);
WriteCStrXY(X, YOff, SS, white, yellow);
SetColor(white);
OutTextXY(Charlen,YOff, Chr($10));
OutTextXY(GetMaxX-2*Charlen,YOff, Chr($11));
GSystemError := FarSelectKey; {get retry/cancel user input}
MenuBar^.Draw; {erase error message}
with SaveText do
SetTextStyle(Font, Direction, CharSize);
with VPort do
SetViewPort(X1, Y1, X2, Y2, Clip);
end;
{------ Heap View object ----------}
{displays available heap space, updates using timer tick}
type
PHeapView = ^THeapView;
THeapView = object(TView)
OldMem : LongInt;
constructor Init(var Bounds: TRect);
procedure Draw; virtual;
procedure HandleEvent(var Event : TEvent); virtual;
end;
constructor THeapView.Init(var Bounds: TRect);
begin
TView.Init(Bounds);
OldMem := 0;
EventMask := evTimerTick;
VFont := font8x8;
end;
procedure THeapView.Draw;
{Because the HeapView is outside of the default viewport in this
program, the viewport is changed and restored in this Draw routine.}
var
S: string;
C: word;
VPort : ViewPortType;
YOff : integer;
Glob : TRect;
begin
MCur.Hide; {hide mouse cursor}
GetViewSettings(VPort); {save current viewport}
GetScreenCoords(Glob); {set viewport to outline of this view}
SetViewPort(Glob.A.x, Glob.A.y, Glob.B.x, Glob.B.y,ClipOn);
GetVPRelCoords(Glob); {get view outline in viewport relative coords}
OldMem := MemAvail;
Str(OldMem, S);
C := GetColor(2); {get normal menu text color pair from palette}
SetColor(ForeColor(C)); {set text color}
SetFillStyle(solidfill,BackColor(C)); {set background color}
Bar(Glob.A.x, Glob.A.y, Glob.B.x, Glob.B.y); {draw background}
S := 'HEAP: ' + S;
SetTextStyle(VFont,HorizDir,1); {set text font}
{must set font Before calling CalcVertTextOffset}
YOff := CalcVertTextOffset(Size.y); {center text vertically in view}
OutTextXY(Glob.A.x+BXOffset,Glob.A.y+YOff,S); {write text}
with VPort do {restore viewport}
SetViewPort(X1, Y1, X2, Y2, Clip);
MCur.Show; {show mouse cursor}
end;
procedure THeapView.HandleEvent(var Event : TEvent);
begin
if (Event.What = evTimerTick) and (OldMem <> MemAvail) then DrawView;
end;
{-----------------------------------}
const
SArraySize = 34;
SArray : array[0..SArraySize] of Str80 = (
'',
' TVGraphic is a compiled library',
'written in Borland''s Turbo Vision and extending it',
'into DOS graphic mode by using the EGA/VGA driver.',
'TVGraphic requires Turbo Vision and the Graph unit.',
'',
'Currently based on TV 1.0, it includes fixes and',
'many upgrades from TV 2.0 plus other enhancements',
'aimed at pure graphics applications.',
'',
'A new partial screen redraw mechanism provides',
'automatic sizing of the viewport and the Clip variable.',
'',
'TView methods are included that calculate the',
'global coordinates needed for graphic drawing calls.',
'',
'Two FAST, clippable bit mapped fonts are included.',
'Optional user settable grid for mouse cursor.',
'Hooks are present for user modifications.',
'',
'A Window (or any TGroup descendent) may have an',
'interior larger than the screen which contains',
'SubWindows and TView descendants.',
'',
'Units are available for Pascal versions 6 and 7.',
'Full TV2.0 functionality, more links to the visual',
'design tool, Protected mode and VESA 800x600 are',
'likely for 1994.',
'',
'For information, comments, wish items, bugs, etc.',
' or software consulting/development',
'',
' Richard P Andresen CompuServe# 71222,1200',
' RR2 Box 900',
' Hinesburg,Vermont 05461');
const
TestStr : string =
'A GOOD LONG PIECE OF LENGTHY, MONOTONOUS, BORING, REPETITIVE TEXT.';
type
{A basic text oriented scrolling view with graphics too}
PMyScroller = ^TMyScroller;
TMyScroller = object (TScroller)
constructor Init(var Bounds: TRect;
AHScrollBar,AVScrollBar: PScrollBar);
procedure Draw; virtual;
procedure PartOfSetLimit(X, Y: Integer); virtual; {new with version 1.5}
end;
const {change constants here to set TMyScroller step sizes}
{also see discussion of changing vertical text offset in .Draw}
HSpacing = Charlen;
VSpacing = Boxheight;
constructor TMyScroller.Init(var Bounds: TRect;
AHScrollBar, AVScrollBar: PScrollBar);
begin
TScroller.Init(Bounds, AHScrollBar, AVScrollBar);
GrowMode := gfGrowHiX + gfGrowHiY;
SetLimit((3*Size.x div 2) div HSpacing, 2*Size.y div VSpacing);
end;
procedure TMyScroller.Draw;
const
Triangle: array[1..4] of TPoint = ((X: 200; Y: 70), (X: 400; Y:70),
(X: 300; Y: 170), (X: 200; Y: 70));
var
VPort : ViewPortType;
R,C : TRect;
HColor,Color,I,Err : integer;
Glob : TRect;
begin
MCur.Hide; {hide mouse cursor}
GetViewSettings(VPort); {save current viewport settings}
Move(VPort,C, Sizeof(C)); {copy viewport outline to C}
GetScreenCoords(R); {get outline of this view in screen coords}
R.Intersect(C); {find outline of view contained within the viewport}
{reset viewport to clip at this outline}
{Note that the viewport's size is set automatically by TVGraphic
whenever it redraws only a portion of the screen (a common occurance).
Thus the viewport may be larger than, smaller than
or cover only a part of this view when this Draw is called.
General discussion:
BECAUSE SCROLLERS HAVE A DRAWABLE INTERIOR LARGER THEN
THEIR SIZE, we must prevent drawing outside the View. If we drew
only text, we could alter the text strings that show to just fit
in the size of the window and not draw the rest. This is how
Turbo Vision works.
But since we are also drawing diagonal lines, not just text, and the
view and the viewport can be any size, we will limit drawing by
resetting the viewport for the duration of this Draw method.
To do this, we re-size (shrink) the viewport to match the rectangle
of this View that falls within the current viewport (as shown above).
VITAL - Because there may be other views to redraw, ALWAYS restore
a re-sized viewport to the values saved in VPort at the end of
a .Draw !! }
{Debugging note: When calling a view's Draw via it's DrawView method,
DrawView first checks the view's Exposed function. Exposed will
prevent Draw from being called if no part of the view overlaps
the Clip variable.
At the start of a partial redraw, the viewport is set to match
(cover) the Clip area.}
SetViewPort(R.A.x,R.A.y,R.B.x,R.B.y,ClipOn);
GetVPRelCoords(Glob); {get view's outline in Viewport Relative coords}
{Must call after setting viewport!}
Color := GetColor(1); {call palette for normal text color}
{note that GetColor returns both foreground
and background colors in single word}
{color for text - use ForeColor for foreground color}
{color for background - use BackColor}
HColor := GetColor(2); {call palette for Highlight text color}
SetFillStyle(solidfill,BackColor(Color));
Bar(Glob.A.x,Glob.A.y,Glob.B.x,Glob.B.y); {draw background}
SetColor(ForeColor(Color));
SetTextStyle(font8x14,HorizDir,1);
{draw scrolling text using scroller offset "Delta"}
{Note: we are assuming text is HSpacing wide by VSpacing tall.
These are the scroll step sizes this scroller was set to with
these constants in TMyScroller.PartOfSetLimit.}
{kludge for demo program - text varies with window title}
if PWindow(Owner)^.Title^[1] <> 'A' then begin
SetTextStyle(font8x14,HorizDir,1);
OutTextXY(Glob.A.x+HSpacing - (Delta.x*HSpacing),
Glob.A.y + (10-Delta.y)*VSpacing, TestStr);
{Draw some text that doesn't move as view scrolls}
SetTextStyle(font8x8,HorizDir,1);
{Can write text the usual way}
(* OutTextXY(Glob.A.x,Glob.A.y+200,'This line doesn''t scroll.');*)
{or write strings with imbedded highlights using the ~ delimiter.}
WriteCStrXY(Glob.A.x, Glob.A.y+200, 'This line ~doesn''t~ scroll.',
ForeColor(Color), ForeColor(HColor));
{Now for something Graphic:
Note that since we have set TScroller up as a text scroller, we
have to multiply Delta.x by HSpacing and Delta.y by VSpacing to
get graphic coords.
By changing the constants used in PartOfSetLimits and in the SetLimit
call in Init, and using these same constants in this Draw method,
you can get any scroll step size you want.
For a scroller of your own that is single pixel oriented
(rather than text spacing), you don't need to override
TScroller.PartOfSetLimit. You will probably want to set
GrowMode the same as in TMyScroller.Init.
Related subject:
TVGraphic's TView.VOffset field can be used in any view similarly
to how Delta is used by TScroller to offset/scroll the interior.
GetVPRelCoords automatically includes all VOffset's in its calculation.
TVGraphic expects VOffset to be maintained in pixel units.
TVGraphic's TPanWindow is an example of this. It does not have a
separate scroller view. This allows drawing to go all the way
to window edges.}
SetColor(red);
for I := 1 to 3 do {lines scroll since using Delta}
Line(Glob.A.x+Triangle[I].x-(Delta.x*HSpacing),Glob.A.y+Triangle[I].y-(Delta.y*VSpacing),
Glob.A.x+Triangle[I+1].x-(Delta.x*HSpacing),Glob.A.y+Triangle[I+1].y-(Delta.y*VSpacing));
SetColor(Yellow);
Circle(Glob.A.x+300 -(Delta.x*HSpacing),
Glob.A.y+120 -(Delta.y*VSpacing),
100);
end
else {normal scroller code}
{Optional - for speed improvement on large files, call OutTextXY
only when it is within the current viewport.}
{Remember - GetVPRelCoords(Glob) is viewport relative.}
{ByOffset
is automatically set in TVGraphic. It is a font dependent
value used to center text vertically in the standard Boxheight.
If you make VSpacing other than Boxheight, don't use ByOffset.
Use function CalcVertTextOffset -
YOffset := CalcVertTextOffset(VSpacing) to find the offset to
center text in arbitrary vertical spacing.}
{TVGraphic Version 1.0 code, works but I should now start at 0.}
(* for I := 1 to SArraySize do
if ((Glob.A.y + (I+1-Delta.y)*VSpacing) > 0)
and ((Glob.A.y + (I-2-Delta.y)*VSpacing) < Glob.B.y) then
OutTextXY(Glob.A.x+HSpacing - (Delta.x*HSpacing) +1,
Glob.A.y + (I-Delta.y)*VSpacing + BYOffset, SArray[I]);*)
for I := 0 to (Size.y+1) div VSpacing +1 do begin
{If you want to draw the background incrementally, use the
following line instead of the earlier call to Bar.}
(* Bar(Glob.A.x, Glob.A.y + (I)*VSpacing,
Glob.B.x, Glob.A.y + (I+1)*VSpacing-1); *)
if (I+Delta.y <= SArraySize) then
OutTextXY(Glob.A.x+HSpacing - (Delta.x*HSpacing) +1,
Glob.A.y + I*VSpacing + BYOffset, SArray[I+Delta.y]);
end;
with VPort do {restore viewport}
SetViewPort(X1,Y1,X2,Y2,Clip);
MCur.Show; {show mouse cursor}
end;
{ADDED Version 1.5}
procedure TMyScroller.PartOfSetLimit(X, Y : integer);
var
YSize,XSize : integer;
begin
XSize := (Size.x+1) div HSpacing;
YSize := (Size.y+1) div VSpacing;
Limit.X := X;
Limit.Y := Y;
if HScrollBar <> nil then
HScrollBar^.SetParams(HScrollBar^.Value, 0, X - XSize, XSize - 1,
HScrollBar^.ArStep);
if VScrollBar <> nil then
VScrollBar^.SetParams(VScrollBar^.Value, 0, Y - YSize, YSize - 1,
VScrollBar^.ArStep);
end;
type
{demonstrates very simple Draw method and using TimerTick events}
PCircles = ^TCircles;
TCircles = object(TWinBackground)
Count : integer;
Speed : integer;
constructor Init(var Bounds: TRect);
procedure Draw; virtual;
procedure DrawCircle;
procedure HandleEvent(var Event : TEvent); virtual;
end;
constructor TCircles.Init(var Bounds: TRect);
begin
TWinBackground.Init(Bounds);
EventMask := evTimerTick;
VColor := black; {store drawing color}
end;
procedure TCircles.Draw;
var Glob : TRect;
begin
MCur.Hide; {hide cursor}
GetVPRelCoords(Glob); {get view's outline in viewport relative coords}
SetFillStyle(solidfill,VColor); {set background color}
Bar(Glob.A.x,Glob.A.y,Glob.B.x,Glob.B.y); {draw background}
DrawCircle;
MCur.Show;
end;
procedure TCircles.DrawCircle;
var
Radius : word;
Glob : TRect;
Color : integer;
begin
MCur.Hide; {hide cursor}
GetVPRelCoords(Glob); {get view's outline in viewport relative coords}
if (Count = 0) or (Count =8) then Color := 14
else Color := Count;
SetColor(Color); {set circle Color based on Count}
{compute radius based on view's size}
if Size.x < Size.y then Radius := Size.x
else Radius := Size.y;
Radius := Radius div 3;
{draw circle}
Circle(Glob.A.x+Size.x div 2, Glob.A.y+Size.y div 2, Radius);
MCur.Show; {show the mouse cursor}
end;
procedure TCircles.HandleEvent(var Event : TEvent);
begin
if Event.What = evTimerTick then begin
{ if you want to avoid overwriting menus and modal dialog boxes,
must exit if the Application (Desktop's Owner) is not the
modal view.}
if TopView <> PView(DeskTop^.Owner) then Exit;
Inc(Speed);
if Speed > 1023 then Speed := 0;
if (Speed mod 8 = 0) then begin
Inc(Count);
if Count > 15 then Count := 0; {limit to highest color}
if GetState(sfActive) then DrawCircle;
end;
end;
end;
{RegisterTypes}
const
RMyScroller: TStreamRec = (
ObjType: 3000;
VmtLink: Ofs(TypeOf(TMyScroller)^);
Load: @TMyScroller.Load;
Store: @TMyScroller.Store
);
RCircles: TStreamRec = (
ObjType: 3001;
VmtLink: Ofs(TypeOf(TCircles)^);
Load: @TCircles.Load;
Store: @TCircles.Store
);
procedure RegisterLocals;
begin
RegisterType(RMyScroller);
RegisterType(RCircles);
end;
{--------------------------------}
type
TDemoApp = object(TProgram)
DeskTopStyle : word; {style currently in use}
ThePanWindow : PPanWindow; {pointer to panning window if it exists}
constructor Init;
procedure GetEvent(var Event : TEvent); virtual;
procedure DoAboutBox;
procedure DosShell;
procedure HandleEvent(var Event: TEvent); virtual;
procedure InsertCircleWin;
procedure InsertScrollerWin(ATitle : string);
procedure InitHeapViewer;
procedure InitMenuBar; virtual;
procedure InitShiftView;
procedure InitMessageBar; {message that covers over the MenuBar}
procedure InitStatusLine; virtual;
procedure InitToolBar;
procedure IntroScreen;
procedure LoadBMP;
procedure NewWindow;
procedure SaveDeskTop;
procedure SelectDeskTopStyle;
procedure LoadDeskTop;
procedure ShowHelp;
procedure ShowMouseBox;
destructor Done; virtual;
destructor HaltDone;
end;
destructor TDemoApp.Done;
{called for normal program termination}
begin
TProgram.Done;
MCur.Done; {releases mouse cursor memory}
CloseGraph;
Graphic := false;
{DoneHistory;}
DoneSysError;
DoneEvents;
DoneVideo;
DoneMemory;
end;
destructor TDemoApp.HaltDone;
{used if program halts while trying to initilize graphic mode}
begin
{DoneHistory;}
DoneSysError;
DoneEvents;
DoneVideo;
DoneMemory;
end;
constructor TDemoApp.Init;
procedure DoStreamRegistration;
{register objects and views for stream I/O}
{vary contents to match your program}
begin
RegisterObjects;
RegisterViews;
RegisterDialogs;
RegisterMenus;
RegisterApp;
RegisterStdDlg;
RegisterWindows;
RegisterLocals;
RegisterBitMaps;
end;
var
GraphDriver,GraphMode,ErrorCode : integer;
begin
Graphic := false;
InitMemory;
InitVideo;
InitEvents;
InitSysError;
{InitHistory;}
{register screen driver}
if RegisterBGIdriver(@EGAVGADriverProc) < 0 then begin
HaltDone;
Writeln('Internal EGA/VGA driver not linked.');
Halt(1);
end;
{verify graphics mode}
DetectGraph(GraphDriver, GraphMode);
if not ((GraphDriver = VGA) or (GraphDriver = EGA)) then begin
HaltDone;
Writeln('Error - system does not support EGA or VGA graphics.');
Halt(1);
end;
(* {Optional -forces color display mode if in B&W mode. This can
cause a problem with B&W LCD laptops which can
drive an external VGA color monitor. They end up in
color mode and so Turbo Vision selects the color
palette instead of B&W palette.}
SetVideoMode(smCO80);*)
{enter graphics mode}
if GraphDriver = VGA then GraphMode := VGAHi
else GraphMode := EGAHi;
InitGraph(GraphDriver,GraphMode,'');
ErrorCode := GraphResult;
if ErrorCode <> grOK then begin
HaltDone;
Writeln('Graphics Error: ',GraphErrorMsg(ErrorCode));
Halt(1);
end
else begin
{install exit proc to Close graphics}
OldExitProc := ExitProc; { save previous exit proc }
ExitProc := @GExitProc; { insert our exit proc in chain }
Graphic := true;
{install graphic mode DOS critical error handler}
SysErrorFunc := GSystemError;
{improves look of dark gray and brown on VGA monitors,
no effect in EGA}
ImprovePaletteColors;
end;
MCur.Init; {mouse cursor object}
MCur.SetSpeed(12,12); {how fast cursor moves, "normal" is 8,8}
InitShiftView; {must do before TProgram.Init if calling
ShiftView.HandleEvent from TDemoApp.HandleEvent.
ShiftView is needed for Panning windows only.}
TProgram.Init;
{following items may be different for your program}
DoStreamRegistration;
InitMessageBar;
DoubleDelay := 6; {time between mouse button presses for double press}
{TV uses 8 - very slow}
{set default Viewport to just cover the DeskTop. The MainMenu,MessageBar
and StatusLine temporarily reset viewport when they draw themselves.}
with DeskTop^ do
SetViewPort(Origin.x, Origin.y,
Origin.x + Size.x, Origin.y + Size.y, ClipOn);
{set mouse grids to off}
MCur.SetGrid(1,1,0,0);
MouseSnapToMenuGrid := false;
MouseSnapToDialogGrid := false;
InitHeapViewer;
InitToolBar;
IntroScreen; {optional}
DisableCommands([cmTVlikeButtons]); { for demo program only! }
end;
procedure TDemoApp.DosShell;
{Must override method TApplication.DosShell for graphics.}
begin
{USE TurboVision 2.0 MEMORY Unit if compiling with TP 7.0,
use MEMORY ver 1.0 with TP.6.0}
RestoreCrtMode; {back to text mode}
DoneSysError;
DoneEvents;
DoneVideo;
{$IFDEF VER60}
SetMemTop(HeapPtr); {reduce reserved memory size}
{$ELSE}
DoneDosMem;
{$ENDIF}
Writeln('Type EXIT to return to '+ ProgName + '...');
SwapVectors;
Exec(GetEnv('COMSPEC'), '');
SwapVectors;
{$IFDEF VER60}
SetMemTop(HeapEnd); {reserve all of memory}
{$ELSE}
InitDosMem;
{$ENDIF}
InitVideo;
InitEvents;
InitSysError;
SetGraphMode(GetGraphMode);
ImprovePaletteColors;
{Other programs can change mouse settings. Restore here.}
MCur.RestoreSettings;
Redraw; {Use Redraw here, not Draw.}
if DosError <> 0 then DOSErrorMessageBox(DosError, 'Running DOS shell');
end;
procedure TDemoApp.GetEvent(var Event : TEvent);
const
HelpInUse : boolean = false;
LastPressDouble : boolean = false;
begin
TProgram.GetEvent(Event); {usual call}
{Timer Tick events for v1.5 and above
are now handled automatically in TProgram.GetEvent}
{Optional - Mouse button behavior}
if (Event.What and evMouse <> 0) and (Graphic = true) then begin
(* next line moved to TProgram.GetEvent
MCur.Move(Event.Where); {move cursor to mouse location}*)
if (Event.What = evMouseDown) then begin
{OPTIONAL - remap middle button of 3 button mouse}
if (Event.Buttons > mbRightButton) then Event.Buttons := mbLeftButton;
{eliminate sequential double press events}
if (Event.Double) then
if not LastPressDouble then LastPressDouble := true {remember this double press}
else begin
Event.Double := false; {reset the double flag}
LastPressDouble := false;
end
else LastPressDouble := false; {clear flag if non-double press}
end;
end;
{Hook in HELP screens here in GetEvent to cover
situation when another view is Modal}
if (Event.What = evCommand) and (Event.Command = cmHelp)
and not HelpInUse then begin
HelpInUse := true;
ShowHelp;
ClearEvent(Event);
HelpInUse := false;
end;
end;
procedure TDemoApp.ShowHelp;
var
HWin : PDialog;
S : string;
Control : integer;
HCtx : word;
PS : PGStaticText;
B : PButton;
R : TRect;
Event : TEvent;
P : PMenuView;
begin
HCtx := GetHelpCtx;
Str(HCtx,S);
case HCtx of
hcMouseGrid:
S := 'TVGraphic allows the mouse cursor to be snapped to any user specified grid for the screen in general.'+
' Grid Off (uses every pixel) and two other choices are provided here.';
hcColorSel:
S := ^C'Use Background color selector for all items listed after a "/".'+^M^M+
^C'Only Items showing "bkgnd" have a changable background.';
else
S := ^C'THIS IS NO HELP AT ALL'^M^M^M+
^C+ 'Help Context = ' + S;
end;
R.A.x := 0; R.B.x := R.A.x + 49*Charlen;
R.A.Y := 0; R.B.y := R.A.y + (11+3)*Boxheight;
HWin := New(PDialog,Init(R,'HELP'));
HWin^.Options := HWin^.Options or OfCentered; {autocenter}
Inc(R.A.x, 4*Charlen);
Dec(R.B.x, 4*Charlen);
Inc(R.A.y, 4*Boxheight);
R.B.y := R.A.y + 5*Boxheight;
PS := New(PGStaticText, Init(R,S,DefaultOpts));
HWin^.Insert(PS);
if TopView = @Self then
{if no other view is modal, insert dialog
as non-modal (persistant) view}
if ThePanWindow <> nil then ThePanWindow^.Insert(HWin)
else DeskTop^.Insert(HWin)
else begin {some other view is already modal, make dialog modal}
R.A.x := HWin^.Size.x - 11*Charlen;
R.A.y := HWin^.Size.y - 2*Boxheight;
B := New(PCancelButton, Init(R.A));
HWin^.Insert(B); {add Cancel button}
Control := DeskTop^.ExecView(HWin);
Dispose(HWin,Done);
{TVGraphics partial redraw scheme isn't aware of open
submenu(s) extending over the DeskTop. If you create a
overlapping modal view while these menus are open,
you must manually call the menu chain to redraw
themselves as shown here.}
P := MenuBar^.Target; {first submenu in the chain}
while P <> nil do begin {redraw all open submenus}
P^.DrawView;
P := P^.Target;
end;
end;
end;
procedure TDemoApp.DoAboutBox;
begin
InsertScrollerWin('ABOUT TVGRAPHIC');
end;
procedure TDemoApp.HandleEvent(var Event: TEvent);
procedure Colors;
var
D: PColorDialog;
begin
D := New(PColorDialog, Init('',
ColorGroup('Desktop', DesktopColorItems(nil),
ColorGroup('Menus', MenuColorItems(nil),
ColorGroup('Dialogs', DialogColorItems(dpTV1Dialog, nil),
ColorGroup('Windows', WindowColorItems(wpBlueWindow, nil),
{ColorGroup('Help', WindowColorItems(wpCyanWindow, nil),}
nil)))))){)};
D^.HelpCtx := hcColorSel;
if ExecuteDialog(D, Application^.GetPalette) <> cmCancel then
begin
ReDraw; { Redraw application with new palette }
end;
end;
procedure DosErr;
var
F: Text;
Cmd : integer;
begin
Cmd := MessageBox(^C'Testing DOS Critical Error'+
^M^M^C'Remove any disk in drive A:',nil,mfWarning+mfOKCancel);
if Cmd <> cmOK then exit;
Assign(F, 'a:\8anyfile.7Z3');
{$I-}
Reset(F);
Close(F);
Cmd := IOResult; {added 5/17/93}
{$I+}
end;
procedure ShowVersion;
var Cmd : integer;
begin
Cmd := MessageBox(^C'TVGraphic Demo1 ver '+Ver,
nil, mfInformation+mfOKButton);
end;
procedure ShowHourGlass;
begin
Mcur.SelectHourGlass;
Delay(500);
MCur.SelectStdCursor;
end;
procedure DeskTopOptionsInfo;
begin
MessageBox(^C'The heights and fonts of the Menubar and the '
+'StatusLine are adjustable in the code.',
nil, mfInformation+mfOKButton);
end;
procedure ToolsInfo;
begin
MessageBox(^C'TVGraphic now works with David Baldwin''s visual '+
'design tool, Dialog Design v4.0.',
nil, mfInformation+mfOKButton);
end;
procedure TEditInfo;
begin
MessageBox(^C'The Editors unit for TVGraphic is in progress.',
nil, mfInformation+mfOKButton);
end;
procedure ToolBarInfo;
begin
MessageBox(^C'Bitmapped buttons may be used in Dialogs or in'+
' a ToolBar.',
nil, mfInformation+mfOKButton);
end;
procedure MakeSound;
begin
Sound(1000);
Delay(10);
NoSound;
end;
var
R: TRect;
PDir,FInputBox : PView;
Cmd : integer;
begin
if (ShiftViewPtr <> Nil) then ShiftViewPtr^.HandleEvent(Event);
{ShiftViewPtr will be nil unless InitShiftView has been
called. A ShiftView is needed if using TPanWindow type. Call to
ShiftViewPtr^.HandleEvent must come before call to
TProgram.HandleEvent.}
TProgram.HandleEvent(Event); {usual call to ancestor method}
if Event.What = evCommand then
begin
case Event.Command of
cmNew: NewWindow;
cmShowMessageBar:
begin
MessageBar^.ShowText('~T~HIS IS THE MESSAGE BAR.');
Delay(1000);
MessageBar^.Hide;
end;
cmAbout: DoAboutBox;
cmOpen:
begin
FInputBox := New(PFileDialog, Init('*.*', 'OPEN A FILE', '~N~ame', fdOpenButton,0));
Cmd := DeskTop^.ExecView(FInputBox);
Dispose(FInputBox, Done);
end;
cmChangeDir:
begin
PDir := New(PChDirDialog, Init(cdNormal {+ cdHelpButton},0));
Cmd := DeskTop^.ExecView(PDir);
Dispose(PDir, Done);
end;
cmSetColors: Colors;
cmDOSshell : DOSShell;
cmDosCriticalError : DosErr;
cmOptionsSave : SaveDeskTop;
cmOptionsLoad : LoadDeskTop;
cmCircleWindow : InsertCircleWin;
cmScrollerWindow : InsertScrollerWin('WINDOW WITH SCROLLER');
cmMouseGrids : ShowMouseBox;
cmDeskTopStyle : SelectDeskTopStyle;
cmDeskTopOptions : DeskTopOptionsInfo;
cmVersion : ShowVersion;
cmTools : ToolsInfo;
cmTEdit : TEditInfo;
cmBMP : LoadBMP;
cmBitBut : ToolBarInfo;
cmHourGlass : ShowHourGlass;
cmTVlikeButtons : begin
TextButtonsMatchBitMapButtons := false;
DisableCommands([cmTVlikeButtons]);
EnableCommands([cmBMPlikeButtons]);
end;
cmBMPlikeButtons :begin
TextButtonsMatchBitMapButtons := true;
DisableCommands([cmBMPlikeButtons]);
EnableCommands([cmTVlikeButtons]);
end;
end;
end;
end;
procedure TDemoApp.InsertCircleWin;
var
P : PView;
W : PWindow;
R : TRect;
begin
R.Assign((WinNum+20)*Grid, (WinNum+20)*Grid,
(WinNum+40)*Grid, (WinNum+40)*Grid);
{use a TSubWindow here rather than TWindow since window may be
inserted into another window instead of the DeskTop}
W := New(PSubWindow, Init(R,'CIRCLES',wnNoNumber));
W^.GetMaxSubViewSize(R);
P := New(PCircles, Init(R));
W^.Insert(P);
if ThePanWindow <> nil then ThePanWindow^.Insert(W)
else DeskTop^.Insert(W);
end;
procedure TDemoApp.InsertScrollerWin(Atitle : string);
var
WinTitle : string;
TheWindow : PSubWindow;
PScrollH,PScrollV : PScrollBar;
PS : PView;
R : TRect;
begin
Inc(WinNum);
R.Assign((WinNum+4)*Charlen, (WinNum+4)*Boxheight,
(WinNum+64)*Charlen,(WinNum+24)*Boxheight);
WinTitle := ATitle;
TheWindow := New(PSubWindow, Init(R, WinTitle, WinNum{wnNoNumber}));
PScrollH := TheWindow^.StandardScrollBar(sbHorizontal + sbHandleKeyboard);
PScrollV := TheWindow^.StandardScrollBar(sbVertical + sbHandleKeyboard);
TheWindow^.GetMaxSubViewSize(R);
{GetMaxSubViewSize returns the rectangle that needs to be filled
with views - here fill it with the scroller}
PS := New(PMyScroller, Init(R,PScrollH,PScrollV));
TheWindow^.Insert(PS);
if ThePanWindow <> nil then ThePanWindow^.Insert(TheWindow)
else DeskTop^.Insert(TheWindow);
end;
procedure TDemoApp.InitHeapViewer;
var
P : PView;
R : TRect;
begin
R.Assign(Size.x - 14*Charlen, StatusLine^.Origin.y, Size.x, Size.y);
P := New(PHeapView, Init(R));
Insert(P);
end;
procedure TDemoApp.InitMessageBar; {message that covers over the MenuBar}
begin
MessageBar := New(PGMessageBar,Init);
Insert(MessageBar);
end;
procedure TDemoApp.InitShiftView;
{Used with full desktop panning window(s).
Zero or One ShiftView per application.
The shape of ShiftView is the top row of pixels on the screen.}
var
R : TRect;
begin
R.A.x := 0; R.B.x := GetMaxX;
R.A.y := 0; R.B.y := 0{1}; {shape = slit above menubar}
ShiftViewPtr := New(PShiftView,Init(R));
end;
procedure TDemoApp.InitMenuBar;
var
R: TRect;
begin
MenuBarHeight := {15}20; {user choice}
GetExtent(R);
MenuBar := New(PGMenuBar, Init(R, NewMenu(
NewSubMenu('~F~ile', hcNoContext, NewMenu(
NewItem('~N~ew', '', kbNoKey, cmNew, hcNew,
NewItem('~O~pen...', 'F3', kbF3, cmOpen, hcOpen,
NewLine(
NewItem('~C~hange dir...', '', kbNoKey, cmChangeDir, hcChangeDir,
NewItem('~D~OS shell', '', kbNoKey, cmDosShell, hcDosShell,
NewItem('E~x~it', 'Alt+X', kbAltX, cmQuit, hcExit,
nil))))))),
NewSubMenu('~D~eskTop', hcNoContext, NewMenu(
NewItem('~S~et Style...', '', kbNoKey, cmDeskTopStyle, hcNoContext,
NewItem('~O~ptions...', '', kbNoKey, cmDeskTopOptions, hcNoContext,
NewLine(
NewItem('S~a~ve desktop', '', kbNoKey, cmOptionsSave, hcNoContext,
NewItem('~L~oad desktop', '', kbNoKey, cmOptionsLoad, hcNoContext,
nil)))))),
NewSubMenu('~W~indows', hcNoContext, NewMenu(
NewItem('~C~ircleWindow', '', kbNoKey, cmCircleWindow , hcNoContext,
NewItem('~S~crollerWindow1', '', kbNoKey, cmScrollerWindow , hcNoContext,
NewItem('~S~crollerWindow2', '', kbNoKey, cmAbout, hcNoContext,
NewLine(
NewItem('~S~ize/Move','Ctrl+F5', kbCtrlF5, cmResize, hcResize,
NewItem('~Z~oom', 'F5', kbF5, cmZoom, hcZoom,
NewItem('~N~ext', 'F6', kbF6, cmNext, hcNext,
NewItem('~P~revious', 'Shift+F6', kbShiftF6, cmPrev, hcPrev,
NewItem('~C~lose', 'Alt+F3', kbAltF3, cmClose, hcClose,
nil)))))))))),
NewSubMenu('~M~ouse', hcNoContext, NewMenu(
NewItem('~S~et Cursor grids...', '', kbNoKey, cmMouseGrids, hcNoContext,
NewItem('~H~ourglass Cursor', '', kbNoKey, cmHourGlass, hcNoContext,
nil))),
NewSubMenu('O~p~tions', hcNoContext, NewMenu(
NewItem('~S~how MessageBar', '', kbNoKey, cmShowMessageBar, hcNoContext,
NewItem('~D~os Crit Error', '', kbNoKey, cmDosCriticalError, hcNoContext,
NewItem('Set ~C~olors...', '', kbNoKey, cmSetColors, hcNoContext,
NewLine(
NewItem('~T~V style text buttons', '', kbNoKey, cmTVlikeButtons, hcNoContext,
NewItem('~B~MP like text buttons', '', kbNoKey, cmBMPlikeButtons, hcNoContext,
nil))))))),
NewSubMenu('~I~nfo', hcNoContext, NewMenu(
NewItem('~A~bout...', '', kbNoKey, cmAbout, hcNoContext,
NewItem('~V~ersion #', '', kbNoKey, cmVersion, hcNoContext,
nil))),
NewSubMenu('The Future', hcNoContext, NewMenu(
NewSubMenu('~H~ere now', hcNoContext, NewMenu(
NewItem('~T~ools', '', kbNoKey, cmTools, hcNoContext,
NewItem('~B~itMaps', '', kbNoKey, cmBMP, hcNoContext,
nil))),
NewItem('~E~ditors Unit', '', kbNoKey, cmTEdit, hcNoContext,
nil))),
nil)))))))
)));
end;
procedure TDemoApp.InitStatusLine;
function HiddenStatusKeys(Next : PStatusItem) : PStatusItem;
begin
HiddenStatusKeys :=
NewStatusKey('', kbF10, cmMenu,
NewStatusKey('', kbAltF3, cmClose,
NewStatusKey('', kbF5, cmZoom,
NewStatusKey('', kbCtrlF5, cmResize,
NewStatusKey('', kbF6, cmNext,
Next)))));
end;
var
R: TRect;
begin
GetExtent(R);
R.B.x := R.B.x - 14*Charlen; {leave space for heap viewer}
R.A.Y := R.B.Y - 9 {Boxheight}; {this gives a 10 pixel tall StatusLine}
StatusLine := New(PGStatusLine, Init(R,
NewStatusDef(0, $FFFF,
NewStatusKey('~F1~ Help', kbF1, cmHelp,
NewStatusKey('~F6~ Next', kbF6, cmNext,
NewStatusKey('~Shift+F6~ Prev', kbShiftF6, cmPrev,
NewStatusKey('~Alt-X~ Exit', kbAltX, cmQuit,
HiddenStatusKeys(nil))))),
nil)));
StatusLine^.VFont := font8x8;
{use for 10 pixel tall StatusLine - default font is Font8x14}
end;
procedure TDemoApp.InitToolBar;
{NOTE: this is a toolbar that is inserted into the DeskTop,
just like a window. It can be any size. Windows can cover it.
As an alternative, you could make a toolbar which is inserted into
the application like a menu and reduces the size of the DeskTop.
See Bitmap documentation.}
const
BWidth = 28;
BHeight = 28;
var
PBar : PToolBar;
PBut : PIconButton;
R : TRect;
begin
R.Assign(0, 0, 5 +BWidth, 2+Boxheight +6*BHeight);
PBar := New(PToolBar, Init(R, ''));
{ Buttons have ofSelectable set by default. If so, the Selected
button will have a dotted line drawn around it. Setting bfGrabFocus
in the Opts field of the constructor will cause a button to Select
itself when clicked with mouse. So the dotted line will be on the last
clicked button.
If you don't want the dotted line , clear the ofSelectable flag
in the button's Options field after construction. bfGrabFocus is
not needed in this case but doesn't hurt.
Note that buttons will respond to HotKeys, if you have set them,
but Turbo Vision does not cause such a button to select itself.}
R.A.x := 3; R.A.y := 14; {HotKey = "N"}
PBut := New(PIconButton, Init(R, '~N~',cmNext,
tbDrawDisabled+bfGrabFocus+tbDrawFrame+tbAutoSize, @Bar8_BMP));
PBut^.Options := PBut^.Options and not ofSelectable;
PBar^.Insert(PBut);
Inc(R.A.y, BHeight);
PBut := New(PIconButton, Init(R, '',cmBitBut,
bfGrabFocus+tbDrawFrame+tbAutoSize, @Bar2_BMP));
PBut^.Options := PBut^.Options and not ofSelectable;
PBar^.Insert(PBut);
Inc(R.A.y, BHeight);
PBut := New(PIconButton, Init(R, '',cmBitBut,
bfGrabFocus+tbDrawFrame+tbAutoSize, @Bar3_BMP));
PBut^.Options := PBut^.Options and not ofSelectable;
PBar^.Insert(PBut);
Inc(R.A.y, BHeight);
PBut := New(PIconButton, Init(R, '',cmBitBut,
bfGrabFocus+tbDrawFrame+tbAutoSize, @Bar4_BMP));
PBut^.Options := PBut^.Options and not ofSelectable;
PBar^.Insert(PBut);
Inc(R.A.y, BHeight);
PBut := New(PIconButton, Init(R, '',cmBitBut,
bfGrabFocus+tbDrawFrame+tbAutoSize, @Bar7_BMP));
PBut^.Options := PBut^.Options and not ofSelectable;
PBar^.Insert(PBut);
Inc(R.A.y, BHeight);
PBut := New(PIconButton, Init(R, '',cmBitBut,
bfGrabFocus+tbDrawFrame+tbAutoSize, @Bar1_BMP));
PBut^.Options := PBut^.Options and not ofSelectable;
PBar^.Insert(PBut);
PBar^.SelectNext(false);
DeskTop^.Insert(PBar);
end;
procedure TDemoApp.IntroScreen;
var
R : TRect;
I,J : integer;
Msg : string;
XPt,YPt : integer;
begin
DeskTop^.GetExtent(R);
SetTextStyle(defaultfont,HorizDir,2);
SetColor(white);
for I := 1 to 22 do begin
if I > 10 then SetTextStyle(font8x14,HorizDir,1);
if I > 18 then SetTextStyle(font8x8,HorizDir,1);
OutTextXY(I*20,I*20{R.A.y}, 'TVGraphic');
end;
Delay(500);
R.B.x := 52*Charlen;
R.B.y := 14*Boxheight;
Msg := ^C'WELCOME TO TVGraphic Demo1'^M^M^C+
'TVGraphic is written in Borland Turbo Vision.'+
^M^M^C'Make your TV application look like this one with TVGraphic(tm).'
+^M^M^C+
'CopyRight 1993,1994 Richard P Andresen';
MessageBoxRect(R, Msg, nil, mfInformation+mfOKButton);
DeskTop^.Draw;
end;
procedure TDemoApp.LoadBMP;
var
R : TRect;
BitPtr : PBitMap;
Cmd : integer;
FInputBox : PFileDialog;
FName : PathStr;
InFile : file;
Result : word;
Buf : array[0..Sizeof(TBitMapInfoHeader)-1] of byte;
TotalBytes : LONGint; {!!!}
ErrStr : string;
begin
BitPtr := nil;
Inc(WinNum);
R.A.x := 100; R.A.y := 100;
FInputBox := New(PFileDialog, Init('*.BMP', 'LOAD AND DRAW A BITMAP', '~N~ame', fdOpenButton,0));
Cmd := DeskTop^.ExecView(FInputBox);
if (Cmd = cmFileOpen) or (Cmd = cmOK) then FInputBox^.GetFileName(FName)
else FName := '';
Dispose(FInputBox, Done);
if FName <> '' then begin
Assign(InFile, FName);
Reset(InFile,1); {reads 1 byte blocks}
{read just the InfoHeader}
BlockRead(InFile, Buf, Sizeof(TBitMapInfoHeader), Result);
{remember - the Infoheader is in Buf, not yet in BitPtr^.}
ErrStr := BMPFormatOKStr(PBitMap(@Buf), FName);
If ErrStr = '' then begin
BitPtr := AllocateBMPmem(PBitMap(@Buf)); {allocate mem,use special call}
if BitPtr <> nil then begin
TotalBytes := GetBitImageSize(PBitMap(@Buf));
Reset(InFile,1); {start again at beginning of file, read all}
BlockRead(InFile, BitPtr^, TotalBytes, Result);
WinToTVColor(BitPtr);
MCur.Hide;
PutBitMap(100,100, BitPtr, 0, NormalPut);
MCur.Show;
end;
end
else
Cmd := MessageBox(ErrStr, nil, mfError+mfOKButton);
System.Close(InFile);
{! WARNING ! - following line disposes of memory used by this bitmap -
fine here since just want to draw bitmap once on screen but disaster
if you assign BitPtr to a View or Button in your own code!}
if BitPtr <> nil then FreeMem(BitPtr, TotalBytes); {do here for demo}
end;
end;
procedure TDemoApp.SaveDeskTop;
const
FName = 'TVGDEMO.DSK';
var
SaveFile : TBufStream;
FStatus,Cmd : integer;
Pal : PString;
begin
SaveFile.Init(FName, stCreate, 1048); {create a save file}
Pal := PString(GetPalette); {get pointer to palette}
SaveFile.WriteStr(Pal); {save palette}
SaveFile.Put(DeskTop); {save DeskTop}
SaveFile.Flush;
FStatus := SaveFile.Status;
SaveFile.Done; {flushes buffer}
if FStatus <> stOK then
if FStatus = stPutError then
Cmd := MessageBox('Put of unregistered object.',nil, mfError + mfOkButton)
else if SaveFile.ErrorInfo <> 0 then
DOSErrorMessageBox(SaveFile.ErrorInfo, FName)
else
Cmd := MessageBox('Error saving file.',nil, mfError + mfOkButton);
end;
procedure TDemoApp.LoadDeskTop;
procedure CloseView(P: PView); far;
begin
Message(P, evCommand, cmClose, nil);
end;
procedure ReadFile(var S : TBufStream);
var
Pal : PString;
begin
if Desktop^.Valid(cmClose) then
begin
Pal := S.ReadStr;
if Pal <> nil then
begin
GetPalette^ := Pal^;
DisposeStr(Pal);
end;
Delete(DeskTop);
Dispose(DeskTop,Done);
DeskTop := PDeskTop(ValidView(PDeskTop(S.Get)));
{May overflow memory in TV, safe in TVGraphic}
{note pointer type conversion to PDeskTop}
Insert(DeskTop);
end;
end;
const
FName = 'TVGDEMO.DSK';
var
SaveFile : TBufStream;
FStatus,Cmd : integer;
begin
SaveFile.Init(FName, stOpenRead, 1048);
if (SaveFile.Status = stOK) then begin {found file}
ReadFile(SaveFile);
FStatus := SaveFile.Status;
SaveFile.Done; {flushes buffer}
if FStatus <> stOK then
if FStatus = stGetError then
Cmd := MessageBox('Get of unregistered object.',nil, mfError + mfOkButton)
else if SaveFile.ErrorInfo <> 0 then
DOSErrorMessageBox(SaveFile.ErrorInfo, FName)
else
Cmd := MessageBox('Error reading file.',nil, mfError + mfOkButton);
end;
end;
procedure TDemoApp.NewWindow;
var
Cmd : integer;
begin
Cmd := MessageBox(^C'Use the Windows Menu to open Windows',nil,
mfInformation+mfOKButton);
end;
procedure TDemoApp.ShowMouseBox;
type
Temptype = record
RW : word;
CW : word;
end;
var
Win : PDialog;
WinTitle : PGStaticText;
OKButton,CancelButton : PButton;
StyleStr : string;
Control,SaveStyle : integer;
R : TRect;
Org : TPoint;
Lab : PGLabel;
Radio : PRadioButtons;
Check : PCheckBoxes;
Temp : Temptype;
MGridSize : MGridRec;
begin
R.A.x := 0; R.B.x := R.A.x + 42 * Charlen;
R.A.y := 0; R.B.y := R.A.y + 19 * Boxheight;
Win := New(PDialog,Init(R,'MOUSE GRIDS'));
Win^.Options := Win^.Options or ofCentered;
{Win^.HelpCtx := hcMouseGrid;}
{add note}
StyleStr:= ^C'The mouse Cursor can be continuous or snapped to an invisible grid.'+
^M^M^C'BoxMenus and Dialogs use the desktop grid if their own grid is not enabled.';
R.Assign(Charlen{0},2*Boxheight, Win^.Size.x-Charlen, 7*Boxheight);
WinTitle := New(PGStaticText,Init(R,StyleStr,DefaultOpts));
Win^.Insert(WinTitle);
{create buttons}
Org.x := 3{2}*Charlen; Org.y := Win^.Size.y - 2*Boxheight;
OkButton := New(POKButton,Init(Org, true));
Win^.Insert(OKButton);
Org.x := Win^.Size.x - 13{10}{9} * Charlen;
Org.y := Win^.Size.y - 2*Boxheight;
CancelButton := New(PCancelButton,Init(Org));
Win^.Insert(CancelButton);
{create RadioButtons}
R.A.x := 4*Charlen;
R.B.x := Win^.Size.x - 4*Charlen;
R.A.y := R.B.y + 2*Boxheight;
R.B.y := R.A.y + 3*Boxheight;
Radio := New(PRadioButtons, Init(R,
NewSItem('Desktop Grid off',
NewSItem('10x10 grid for desktop',
NewSItem('8x14 Text grid for desktop',
nil)))));
Radio^.HelpCtx := hcMouseGrid;
Win^.Insert(Radio);
Dec(R.A.y, Boxheight);
{note use of txAdjustSize to avoid specifying exact size}
Lab := New(PGLabel, Init(R,'~D~esktop',Radio,txAdjustSize));
Win^.Insert(Lab);
Inc(R.A.y, Boxheight);
{create CheckBoxes}
R.A.y := R.B.y + 2*Boxheight;
R.B.y := R.A.y + 2*Boxheight;
Check := New(PCheckBoxes, Init(R,
NewSItem('8x14 Grid for Box Menus',
NewSItem('8x14 Grid for Dialog Boxes',
nil))));
Win^.Insert(Check);
Dec(R.A.y, Boxheight);
{note use of txAdjustSize to avoid specifying exact size}
Lab := New(PGLabel, Init(R,'Use ~S~pecialty grids',Check,txAdjustSize));
Win^.Insert(Lab);
Inc(R.A.y, Boxheight);
{set Temp variable}
{Desktop mouse grid: 0 = 1x1, 1=10x10, 2=8x14}
MCur.GetGrid(MGridSize); {added 11/11/93}
case MGridSize.X of
1 : Temp.RW := 0;
10 : Temp.RW := 1;
8 : Temp.RW := 2;
end;
Temp.CW := 0;
if MouseSnapToMenuGrid then Temp.CW := Temp.CW or $01;
if MouseSnapToDialogGrid then Temp.CW := Temp.CW or $02;
Radio^.Select;
Win^.SetData(Temp);
Control := DeskTop^.ExecView(Win); {MODAL, owner is DeskTop}
Win^.GetData(Temp);
if (Control <> cmCancel) then begin
{Setting the mouse grid with MCur.SetGrid .
The third and fourth parameters are an Xoffset and
YOffset of the grid from the screen's upper left corner.
Note that MCur.SetGrid(1,1,0,0) causes the mouse coords to
be used as they come from the mouse driver.
Unit MCursor also provides functions to limit the area
of the screen the mouse cursor can move in.}
case byte(Temp.RW) of
0 : MCur.SetGrid(1,1,0,0);
1 : MCur.SetGrid(10,10,0,0);
2 : MCur.SetGrid(Charlen,Boxheight,0,0);
end;
if (Temp.CW and $01 <> 0) then MouseSnapToMenuGrid := true
else MouseSnapToMenuGrid := false;
if (Temp.CW and $02 <> 0) then MouseSnapToDialogGrid := true
else MouseSnapToDialogGrid := false;
end;
Dispose(Win,Done);
end;
procedure TDemoApp.SelectDeskTopStyle;
{While you probably won't switch Desktop styles in a real application,
it does show two different ways you can set up a program.
You could also change the heights and fonts of the MenuBar
and the StatusLine. Or eliminate the StatusLine if you wish.}
{Example of changing entire Application palette and also
color pairs within the palette.}
procedure SetDeskTopStyle;
var
R : TRect;
PanStep,IntSize : TPoint;
TheWindow: PWindow;
PScrollH,PSCrollV : PScrollbar;
PS : PScroller;
P,PBak : PView;
WinTitle,TestStr : string;
Pal : PPalette;
begin
Delete(DeskTop);
Dispose(DeskTop, Done); {dispose old desktop and everything in it}
InitDeskTop;
Insert(DeskTop); {insert the new one}
ThePanWindow := nil; {tested for nil elsewhere in program}
Dispose(ShiftViewPtr, Done); {dispose to reset Shiftview}
InitShiftView;
if DeskTopStyle = 1 then begin {Panning window}
Inc(WinNum);
R.Assign(0, 0, 60*Charlen, 20*Boxheight);
WinNum := 1;
DeskTop^.GetExtent(R);
IntSize.x := GetMaxX+200;
IntSize.y := GetMaxY+100;
PanStep.x := ScrnShiftX;
PanStep.y := ScrnShiftY;
{The pan window should be a even multiple of the mouse grid size}
ThePanWindow := New(PPanWindow, Init(R,
'Larger Than Screen Panning Window', wnNoNumber, IntSize, PanStep));
with ThePanWindow^ do begin
Flags := 0; {prevent from closing}
VOffset.y := 50; {shift the window's Interior by 50 pixels so
it starts above the top of the window.}
R.Assign(Charlen,200,InteriorSize.x-Charlen,200+4*Boxheight);
P := New(PGStaticText, Init(R,AString+AString+AString,txAuto+font8x14));
P^.VOptions := P^.VOptions or txDrawBackground;
Insert(P);
end;
DeskTop^.Insert(ThePanWindow);
Pal := GetPalette;
Pal^[2] := Chr($30); {change menu background color to cyan}
end
else begin
Pal := GetPalette;
Pal^[2] := Chr($70); {change menu background color to light gray}
end;
MenuBar^.Draw; {since changed color}
StatusLine^.Draw;
end;
type
Temptype = record
W : word;
end;
var
Win : PDialog;
WinTitle : PGStaticText;
OKButton,CancelButton : PButton;
StyleStr : Str80;
Control : integer;
R : TRect;
Org : TPoint;
Radio : PRadioButtons;
Temp : Temptype;
begin
R.A.x := 0; R.B.x := R.A.x + 42 * Charlen;
R.A.y := 0; R.B.y := R.A.y + 10 * Boxheight;
Win := New(PDialog,Init(R,'SELECT STYLE'));
Win^.Options := Win^.Options or ofCentered;
{SizeWin^.HelpCtx := hcSizeWin;}
{add note}
StyleStr:= ^C'Changing Style clears the DeskTop.';
R.Assign(0,2*Boxheight, Win^.Size.x, 3*Boxheight);
WinTitle := New(PGStaticText,Init(R,StyleStr,DefaultOpts));
Win^.Insert(WinTitle);
{create buttons}
Org.x := 3{2}*Charlen; Org.y := Win^.Size.y - 2*Boxheight;
OkButton := New(POKButton,Init(Org, true));
Win^.Insert(OKButton);
Org.x := Win^.Size.x - 13{10}{9} * Charlen;
Org.y := Win^.Size.y - 2*Boxheight;
CancelButton := New(PCancelButton,Init(Org));
Win^.Insert(CancelButton);
{create RadioButtons}
R.A.x := 4*Charlen;
R.B.x := Win^.Size.x - 4*Charlen;
Inc(R.A.y, 2*Boxheight);
R.B.y := R.A.y + 2*Boxheight;
Radio := New(PRadioButtons, Init(R,
NewSItem('Multiple Non-Panning Windows',
NewSItem('Full Screen Panning Window',
nil))));
Win^.Insert(Radio);
{DeskTopStyle: 0 = non-panning, 1=panning}
Temp.W := DeskTopStyle;
Win^.SetData(Temp.W);
Control := DeskTop^.ExecView(Win); {MODAL, owner is DeskTop}
Win^.GetData(Temp.W);
if (Control <> cmCancel) and (Temp.W <> DeskTopStyle) then begin
DeskTopStyle := Temp.W;
SetDeskTopStyle;
end;
Dispose(Win,Done);
end;
var
DemoApp: TDemoApp;
begin
DemoApp.Init;
DemoApp.Run;
DemoApp.Done;
end.