home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
World of Shareware - Software Farm 2
/
wosw_2.zip
/
wosw_2
/
PASCAL
/
PRINTR3.ZIP
/
PRINTR2.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1989-12-18
|
22KB
|
652 lines
{$S-,V-}
(****************************************************************************)
(* *)
(* Mesa Software *)
(* 3302 Fourth Ave, Suite 101 *)
(* San Diego, Ca. 92103 *)
(* *)
(* *)
(* Program : Unit Printr2 File Name : printr2.pas *)
(* *)
(* Release : Version 1.0 Date : Dec. 15, 1989 *)
(* *)
(* *)
(****************************************************************************)
Unit printr2;
Interface
{Requires TJocks5.
Use at your own risk. Mesa Software assumes no
liability for the use of this software}
uses CRT,dos,fastttt5,miscttt5,winttt5,strnttt5,keyttt5;
Const
esc = #27;
off = #0;
NLQ = (esc + '!' + #1);
NLQ_OFF = (esc + '!' + #0);
Supercrpt = (esc + 'S' + #0);
Subscrpt = (esc + 'S' + #1);
scrp_off = (esc + 'T');
Comprsd = (esc + #15);
uncomprsd = (esc + #18);
Emphaszd = (esc + 'E');
unemphszd = (esc + 'F');
Dbl_prtng = (esc + 'G');
un_dbl = (esc + 'H');
dbl_wid = (esc + 'W' + #1);
un_wid = (esc + 'W' + off);
{The two print commands below are the same as the two
above.}
expanded = esc + '!' + #48;
unexpand = esc + 'W' + off;
undr_lin = (esc + '-' + #1);
undr_lin_off = (esc + '-' + off);
backspc = (#8);
char_byte = '$';
{This is the char you see in the banner and
report headers. Try !,*,#, or %. Taylor
your chars for different reports}
thirteen = 13;
backspace = #8;
centered = #27 + 'a' + #1;
left_margin = #27 + 'a' + off;
line_feed = #10;
form_feed = #12;
carig_rtn = #13;
author = 'Tom Devanney';
Type
Datestr = string[8];
var
lst : Text;
page : string;
num : integer;
Function Printer_on : Boolean;
Procedure Beepr;
Procedure banner(co_nam,addrs,city,st,zip,phone,rpt_title : string);
Procedure Report_hdr(Rpt_Title,co_nam,addrs,city,st,zip,page : String);
Function IO_Not_OK(num : word) : Boolean;
Function GetSystemDate : Datestr;
Function NumToStr(number : LongInt) : string;
Procedure Check_color(var Textf,Back : byte);
{======================================================================}
Implementation
{======================================================================}
Procedure Check_color(var Textf,Back : byte);
{This is to change any color combo into white on black for monochrome
screens}
begin
if (baseOfScreen <> $B800) then
begin
Textf := 15;
Back := 0;
end;
end;
Function GetSystemDate : Datestr; {string[10]}
{This is to get a system date from the system and return as a string}
Var
regs : Registers;
st2,st3,st4 : String[10];
begin
Fillchar(regs,Sizeof(regs),0);
Regs.AH := $2A; {Interrupt for system date}
MsDos(regs);
With regs do
Begin
Str(CX, st2); {year}
Str(DH, st3); {Month}
Str(DL, st4); {Day}
end;
If length(st3) = 1 then st3 := '0' + st3;
If length(st4) = 1 then st4 := '0' + st4;
getsystemdate := st3 + '/' + st4 + '/' + copy(st2,3,2);
end;
Function NumToStr(number : LongInt) : string;
{-Convert a longinteger,word,integer,byte to a string}
var
numstr : string;
begin
Str(number,numstr);
NumToStr := numstr;
end;
Procedure Beepr;
{This is a fancy lawyer telephone beeper sound
The sound you hear is money}
Const
itration = 3;
var
countr : integer;
begin
for countr := 1 to itration do
begin
Sound(949); {925..999}
Delay(50);
sound(499); {450..600}
delay(50);
end;
Nosound;
end; { Beep }
Function Printer_on : Boolean;
{This is a printer screen that is easy to use}
var
line,col,end_lin,
end_col,box_knd : integer;
Regs : registers;
answr : char;
message : string;
textf,boxf,back : byte;
begin
answr := ' ';
clrscr;
col := 10;
line := 10;
end_col := 70;
end_lin := 20;
box_knd := 0; {0..4,5..9 choose another box type to suit your style}
Printer_on := False;
savescreen(1);
boxf := white;
back := lightgray;
check_color(boxf,back);
Fbox(col,line,end_col,end_lin,boxf,back,box_knd);
boxf := yellow;
back := red;
check_color(boxf,back);
Fbox(col + 1 ,line + 1,end_col - 1,end_lin - 1,boxf,back,box_knd);
back := black;
check_color(boxf,back);
Fbox(col + 2,line + 2,end_col - 2,end_lin - 2,boxf,back,box_knd);
textf := yellow;
check_color(textf,back);
Writebetween(col,end_col,line + (end_lin - line) div 2 - 1,textf,back,'CHECK THE PRINTER FOR PAPER');
message := 'THE PRINTER IS READY, HIT RETURN TO START';
Offcursor;
with regs do
begin
ah := 2;
dx := 0;
intr($17,regs);
printer_on := (ah = 144);
end;
Repeat
if (regs.ah <> 144) then
message := 'PRINTER OFF LINE, ESC TO ABORT OR RETURN TO CONTINUE';
beepr;
Writebetween(col,end_col,line + (end_lin - line) div 2 + 1,textf,back, message);
answr := getkey;
with regs do
begin
ah := 2;
dx := 0;
intr($17,regs);
printer_on := (ah = 144);
end;
until ((regs.ah = 144) or (answr = #27));
if (answr = #27) then
Printer_on := False;
restorescreen(1);
disposescreen(1);
end; {Function Printer_on_line}
Function IO_NOT_OK(num : word) : Boolean;
{This is an error manager that will enable you to escape most runtime
errors. In some cases you will add recovery code after this routine
to your program}
var
msg,Drive_a,
Drive_b : string;
begin
Drive_a := 'A:';
Drive_b := 'B:';
Flushkeybuffer;
msg := '';
IO_Not_ok := (num <> 0);
if (num <> 0) then
begin
case num of
002 : msg := 'File not found';
003 : msg := 'Path not found';
004 : msg := 'Too many open files, Check Files = in config.sys';
005 : msg := 'File access denied or Drive/Directory exists';
006 : msg := 'Invalid file handle';
012 : msg := 'Invalid file access code';
015 : msg := 'Invalid drive number';
016 : msg := 'Cannot remove current directory';
017 : msg := 'Cannot rename across drives';
100 : msg := 'Disk read error, is file open ?';
101 : msg := 'Disk write error, is disk full ?';
102 : msg := 'File not assigned, File name not assigned?';
103 : msg := 'File not open';
104 : msg := 'File not open for input';
105 : msg := 'File not open for output';
106 : msg := 'Invalid numeric format';
150 : msg := 'Disk is write-protected, Remove tab?';
151 : msg := 'Unknown unit';
152 : msg := 'Drive not ready, close drive door, Thank you';
153 : msg := 'Unknown command';
154 : msg := 'CRC error in data';
155 : msg := 'Bad drive request structure length';
156 : msg := 'Disk seek error';
{I use error 157 to sense an unformatted floppy.}
157 : msg := 'Unknown media type. We will format Floppy.';
158 : msg := 'Sector not found';
159 : msg := 'Printer out of paper, so put some in';
160 : msg := 'Device write fault. Usually printer is off';
161 : msg := 'Device read fault';
162 : msg := 'Hardware failure';
200 : msg := 'Division by zero';
201 : msg := 'Range check error';
202 : msg := 'Stack overflow';
203 : msg := 'Insufficient memory';
204 : msg := 'Invalid pointer operation';
205 : msg := 'Floating point overflow, number too big';
206 : msg := 'Floating point underflow';
207 : msg := 'Invalid floating point operation';
208 : msg := 'Overlay manager not installed';
209 : msg := 'Overlay file read error';
else
msg := 'Turbo runtime error '+ NumToStr(num);
end;
savescreen(5);
{These colors are for ega/vga, monochrome is not supported
Here is a hint for good window/message formatting.
Choose an odd number of lines for the window and
an odd number of messages to display
or an even number of lines for the window and
an even number of messages to display.
Display your message centered in the window or box and the
screen will look superb. Makes happy satisfied users}
Mkwin(10,8,70,17,yellow, lightgray,4);
Writebetween(11,69,13,black,lightgray,upper(msg));
Writebetween(11,69,14,black,lightgray,'HIT RETURN TO CONTINUE');
readln;
restorescreen(5);
disposescreen(5);
if ((num = 157) or (num = 3)) then
begin
clrscr;
SwapVectors;
Exec(GetEnv('COMSPEC'), '/C Format ' + Drive_a);
SwapVectors;
if DosError <> 0 then
begin
Writebetween(11,69,13,black,lightgray,upper('Could not execute COMMAND.COM'));
Readln;
end
else
begin
Writebetween(11,69,13,black,lightgray,upper('Disk ' + Drive_a + ' is Formatted'));
Readln;
end;
end;
end;
end;
(**************************************************************************)
(* *)
(* *)
(* Mesa Software *)
(* 3302 Fourth Ave, Suite 101 *)
(* San Diego, Ca. 92103 *)
(* *)
(* *)
(* Procedure : Banner File Name : Printr2.pas *)
(* *)
(* Release : Version 1.0 Date : Dec 15, 1989 *)
(* *)
(* *)
(* *)
(**************************************************************************)
Procedure banner(co_nam,addrs,city,st,zip,phone,rpt_title : string);
(* this is a procedure with the following call:
banner(co_nam,addrs,City,st,zip,rpt_title);
co_nam := 'MESA SOFTWARE';
addrs := '3302 FOURTH AVENUE, SUITE 101';
city := 'SAN DIEGO'; {If necessary,A routine will add the comma}
st := 'CALIFORNIA';
zip := '92103';
phone := '1(555)555-5555';
rpt_title := 'ACCOUNTS RECEIVABLE AGING REPORT';
dte := Date; this date routine is in Technojocks.miscttt unit.
We have Tested it using a Panasonic 1592. The routine is flexible enough to
take most any size strings within reason. Watch the report titles as they
are expanded, centered and added to. Check the code for comma addition.
*)
var
i,j,k,pag_lnth,
lin_lnth,lin_counter,char_count,
Top_headr,bottom_headr,title_lines : integer;
page : string;
Procedure Banner_Top;
var
countr,i : integer;
begin
for countr := 1 to top_headr do
begin
for i := 1 to lin_lnth do
write(lst,char_byte);
Writeln(lst);
char_count := 0;
inc(lin_counter);
end;
end;
Procedure Banner_Bottom;
var
countr,i : integer;
begin
for countr := 1 to bottom_headr do
begin
for i := 1 to lin_lnth - 1 do
write(lst,char_byte);
Writeln(lst,char_byte);
end;
for countr := 1 to 5 do
writeln(lst);
{After this routine, the form length, etc, should be set
for your report paging to follow}
end;
Procedure Banner_left;
begin
{You can use most any replicating code to write the
following. The sample below will give you an option for most
of banner routines. You probably know the argument. My code is
perfect, yours is not so perfect. So Help Yourself.
You must be careful with the TJocks.Fastttt5.Replicate Function.
There is a LIMIT of 80 characters. The function is primarily for
screen writes, so be careful in using it for printer lengths over
80 characters, it returns a value of 1.}
write(lst,#27 + 'a' + #0);
write(lst,replicate(10,char_byte));
write(lst,#27 + 'j' + #0);
end;
Procedure Banner_right;
begin
write(lst,#27 + 'a' + #2);
write(lst,#27 + 'Q' + #132);
writeln(lst,replicate(10,char_byte));
end;
Procedure Filler_Line;
begin
Banner_Left;
Banner_Right;
end;
Procedure Filler(num : integer);
var
countr : integer;
begin
for countr := 1 to num do
begin
Filler_Line;
end;
end;
Procedure Names;
begin
if copy(city,length(city),1) <> ',' then {We add a comma if necessary}
city := city + ', ' + st + ' ' + zip
else
city := city + ' ' + st + ' ' + zip;
end;
Procedure Report_Title(str1 : string);
begin
banner_left;
write(lst,#27 + 'a' + #1); {Auto Centering}
write(lst,#27 + '!' + #48); {Double width/double strike printing}
write(lst,str1);
write(lst,#27 + 'W' + #0);
write(lst,#27 + 'H');
write(lst,#27 + '!' + #0);
write(lst,#27 + 'j' + #0);
banner_right;
end;
Procedure Title(sub_title : string);
begin
Banner_left;
write(lst,#27 + 'a' + #1);
write(lst,upper(sub_title));
write(lst,#27 + 'j' + #0);
Banner_Right;
end;
begin
write(lst,#27,'@'); {Initializes the printer}
write(lst,#27+'C'+#62); {Sets the page length to 62 lines}
top_headr := 6; {This is the top lines to fill}
pag_lnth := 60; {This is the page length 50..66}
Bottom_headr := 6; {Same as top_headr}
lin_lnth := 132; {This was written using wide carriage. Try 80}
lin_counter := 1;
title_lines := 5; {We need this to calculate top and bottom filler space}
char_count := 0;
Names;
banner_top;
num := ((pag_lnth - 20) div 2 - 1);
Filler(num);
rpt_title := upper(rpt_title);
report_title(rpt_title);
num := 2;
Filler(num);
title(date);
num := 11;
Filler(num);
title(co_nam);
title(addrs);
title(city);
title(phone);
num := 12;
Filler(num);
Banner_bottom;
end;
(***************************************************************************)
(* *)
(* Mesa Software *)
(* 3302 Fourth Ave, Suite 101 *)
(* San Diego, Ca. 92103 *)
(* *)
(* *)
(* Procedure : Report-hdr; File Name : PRINTR2.PAS *)
(* *)
(* Release : Version 1.0 Date : Dec 15,1989 *)
(* *)
(* *)
(* *)
(***************************************************************************)
Procedure Report_hdr(Rpt_Title,co_nam,addrs,city,st,zip,page : String);
(* This is a procedure with the following call:
Report_Hdr(Rpt_Title,co_nam,addrs,City,st,zip,rpt_title,page);
co_nam := 'MESA SOFTWARE';
addrs := '3302 FOURTH AVENUE, SUITE 101';
city := 'SAN DIEGO';
st := 'CALIFORNIA';
zip := '92103';
phone := '1(555)555-5555';
dte := Date; this date routine is in Technojocks, sub your own
Rpt_Title := 'ACCOUNTS RECEIVABLE AGING REPORT';
The code here is different from Banner. Choose your own style.
*)
var
i,j,k,lnth,pag_num : integer;
pag : string;
Procedure Title(rpt_title : string);
var i : integer;
begin
for i := 1 to (lnth div 2) do write(lst,' ');
j := i;
write(lst,expanded);
write(lst,Emphaszd);
i := length(rpt_title);
if odd(i) then rpt_title := rpt_title + ' ';
for i:= 1 to length(rpt_title) div 2 do
Write(lst,#8);
write(lst,rpt_title);
write(lst,unexpand);
j := i + length(rpt_title) div 2;
j := j + (lnth div 2);
end;
Procedure Wrt_Address;
var
k : integer;
begin
addrs := '';
addrs := co_nam + ' ' + addrs + ' ' + city + ' ' + st + ' ' + zip;
if odd(length(addrs)) then addrs := addrs + ' ';
for k := 1 to lnth div 2 - (length(addrs) div 2) do
write(lst,#32);
write(lst,Emphaszd,addrs);
j := lnth div 2 + length(addrs) div 2;
end;
Procedure Wrt_Date;
var
i : integer;
begin
for i := 1 to lnth - (j + length(date) - 1) do
write(lst,#32);
Writeln(lst,date);
end;
Procedure Wrt_city;
var
i : integer;
begin
city := city + ' ' + st + ' ' + zip;
k := length(city);
for i := 1 to lnth div 2 - (k div 2) do
write(lst,#32);
write(lst,city);
j := lnth div 2 + (length(city) div 2);
end;
Procedure Wrt_page;
var
i : integer;
begin
inc(pag_num);
str(pag_num,pag);
page := page + pag;
for i := 1 to lnth - (j + length(page)) do
write(lst,#32);
writeln(lst,page);
j := 0;
end;
begin
page := 'Page No. ';
pag_num := 0;
lnth := 132;
write(lst,#27 + '@');
write(lst,#27 + 'P');
Title(rpt_title);
wrt_page;
Wrt_address;
Wrt_Date;
for i := 1 to lnth do
begin
write(lst,char_byte);
if (i = lnth div 2) then write(lst,'!');
end;
for i := 1 to 2 do writeln(lst);
write(lst,#27 + '<'); {Home the print head}
end;
begin
assign(lst,'LPT1');
rewrite(lst);
end.