home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
C!T ROM 2
/
ctrom_ii_b.zip
/
ctrom_ii_b
/
PROGRAM
/
PASCAL
/
TPDB32
/
TPDBSCRN.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1991-10-28
|
4KB
|
174 lines
unit TPDBScrn;
(***********************************)
(* TPDB *)
(***********************************)
(* Object -Oriented *)
(* Turbo Pascal 6.0 Units *)
(* for Accessing dBASE III *)
(* files. *)
(* Copyright 1991 *)
(* Brian Corll *)
(* All Rights Reserved *)
(* dBASE is a registered *)
(* trademark of Ashton-Tate, Inc. *)
(* Version 3.20 October, 1991 *)
(***********************************)
(* Portions Copyright 1984,1991 *)
(* Borland International Corp. *)
(***********************************)
{$L Flash}
{$L Attr}
interface
const
{Color constants - defined to take advantage of Turbo Pascal's
constant folding capabilities. See documentation.}
Black = $00;
DarkGray = $08;
Blue = $01;
LightBlue = $09;
Green = $02;
LightGreen = $0A;
Cyan = $03;
LighBCyan = $0B;
Red = $04;
LightRed = $0C;
Magenta = $05;
LightMagenta = $0D;
Brown = $06;
Yellow = $0E;
LightGray = $07;
White = $0F;
Blink = $80;
BlackBG = $00;
BlueBG = $10;
GreenBG = $20;
CyanBG = $30;
RedBG = $40;
MagentaBG = $50;
BrownBG = $60;
LightGrayBG = $70;
type
ScreenType = array [0..3999] of byte;
ScrPtr = ^ScreenType;
DisplayType = (Monochrome, CGA, EGA, MCGA, VGA);
var
VideoBase: word;
VideoWait: boolean;
function SaveScreen: ScrPtr;
procedure RestoreScreen(var SavedScreen: ScrPtr);
procedure Flash(Row, Col, Attr: byte; Str: string);
procedure CursorOn;
procedure CursorOff;
procedure BlockCursor;
procedure ChAttr(Number: word; Row, Col, Attr: word);
procedure ChAllAttr(Row, Col, Rows, Cols, Attr: word);
procedure FlashC(Row, Attr: byte; Str: string);
implementation
var
Screen: ScreenType absolute $B800: 0000;
MonoScreen: ScreenType absolute $B000: 0000;
Mono: boolean;
{$F+}
procedure Flash(Row, Col, Attr: byte; Str: string);
external;
function CurrVidDisplay: DisplayType;
external;
function CurrentVideoMode: byte;
external;
procedure CursorOn;
external;
procedure CursorOff;
external;
procedure BlockCursor;
external;
procedure ChAttr(Number: word; Row, Col, Attr: word);
external;
{$F-}
procedure ChAllAttr(Row, Col, Rows, Cols, Attr: word);
var
TRow: byte;
begin
for TRow := Row to Rows do
ChAttr(Cols, TRow, Col, Attr);
end;
procedure FlashC(Row, Attr: byte; Str: string);
begin
Flash(Row, 40 - Length(Str) div 2, Attr, Str);
end;
function SaveScreen: ScrPtr;
var
TempPtr: ScrPtr;
begin
New(TempPtr);
if Mono then
Move(MonoScreen, TempPtr^, 4000)
else
Move(Screen, TempPtr^, 4000);
SaveScreen := TempPtr;
end;
procedure RestoreScreen(var SavedScreen: ScrPtr);
begin
if Mono then
Move(SavedScreen^, MonoScreen, 4000)
else
Move(SavedScreen^, Screen, 4000);
Dispose(SavedScreen);
end;
begin
if CurrentVideoMode = 7 then begin
VideoBase := $B000;
Mono := True;
end else begin
VideoBase := $B800;
Mono := False;
end;
VideoWait := (CurrVidDisplay = CGA);
end.