home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
World of Shareware - Software Farm 2
/
wosw_2.zip
/
wosw_2
/
CPROG
/
LABELSRC.ZIP
/
LABELSRC.PAS
Wrap
Pascal/Delphi Source File
|
1989-03-20
|
15KB
|
413 lines
program LabelEditor;
{by Guy Gallo, using input2.pas by Henry Lifton and a piece of }
{Philip Burns' pibmenus }
{$C-} {Turns off the control character checking -- makes output faster }
type
Ascii = set of ' '..'~'; { Range of printable characters }
AnyStr = string[35]; { String to hold entries - length=longest Entry }
const
All: Ascii = [' '..'~'];
Bks = #08; { Backspace Key }
TB = #09; {Tab}
Cr = #13; {Carriage return }
Ff = 1; { These constants represent the number of the first and last }
Lf = 6; { fields in the Entry and will change with each program }
var
code,i,num_more,Field: integer; { Field counter }
Key: array[1..2] of char; { keystroke entered at the keyboard }
ch: string[3]; { Allows for function and special keys}
Ks: char; { The character to print }
Ret,
Fini,
Done: boolean; { True or False indicators }
Col,Row, { Column and Row }
CurPos, { Current cursor position }
PromptCol, { Column for start of prompt }
Len: array[Ff..Lf] of integer; { Max. length of input field }
Prompt,Ans: array[Ff..Lf] of AnyStr; { Array for Prompts & Answers }
Allow: array[Ff..Lf] of Ascii; { Defines Allowable char. set }
{ Minor procedures - called often from main procedure }
(*----------------------------------------------------------------------*)
(* Draw_Menu_Frame --- Draw a Frame by Philip Burns *)
(*----------------------------------------------------------------------*)
Procedure Draw_Menu_Frame( UpperLeftX, UpperLeftY,
LowerRightX, LowerRightY : Integer;
Frame_Color, Title_Color : Integer;
Menu_Title: AnyStr );
(* *)
(* Procedure: Draw_Menu_Frame *)
(* *)
(* Purpose: Draws a titled frame using PC graphics characters *)
(* *)
(* Calling Sequence: *)
(* *)
(* Draw_Menu_Frame( UpperLeftX, UpperLeftY, *)
(* LowerRightX, LowerRightY, *)
(* Frame_Color, Title_Color : Integer; *)
(* Menu_Title: AnyStr ); *)
(* *)
(* UpperLeftX, UpperLeftY --- Upper left coordinates *)
(* LowerRightX, LowerRightY --- Lower right coordinates *)
(* Frame_Color --- Color for frame *)
(* Title_Color --- Color for title text *)
(* Menu_Title --- Menu Title *)
(* *)
(* Calls: GoToXY *)
(* Window *)
(* ClrScr *)
(* *)
(* Remarks: *)
(* *)
(* The area inside the frame is cleared after the frame is *)
(* drawn. If a box without a title is desired, enter a null *)
(* string for a title. *)
Var
I : Integer;
L : Integer;
LT : Integer;
Begin (* Draw_Menu_Frame *)
(* Move to top left-hand corner of menu *)
GoToXY( UpperLeftX, UpperLeftY );
L := LowerRightX - UpperLeftX;
LT := LENGTH( Menu_Title );
(* Adjust title length if necessary *)
If LT > ( L - 5 ) Then Menu_Title[0] := CHR( L - 5 );
(* Color for frame *)
TextColor( Frame_Color );
(* Write upper left hand corner and title *)
If LT > 0 Then
Begin
Write('╒[ ');
TextColor( Title_Color );
Write( Menu_Title );
TextColor( Frame_Color );
Write(' ]');
End
Else
Write('╒════');
(* Draw remainder of top of frame *)
For I := ( UpperLeftX + LT + 5 ) To ( LowerRightX - 1 ) Do Write('═');
Write('╕');
(* Draw sides of frame *)
For I := UpperLeftY+1 To LowerRightY-1 Do
Begin
GoToXY( UpperLeftX , I ); Write( '│' );
GoToXY( LowerRightX , I ); Write( '│' );
End;
(* Draw bottom of frame *)
GoToXY( UpperLeftX, LowerRightY );
Write( '╘' );
For I := UpperLeftX+1 To LowerRightX-1 Do Write( '═' );
Write( '╛' );
(* Establish scrolling window area *)
Window( UpperLeftX+1, UpperLeftY+1, LowerRightX-1, LowerRightY-1 );
(* Clear out the window area *)
Clrscr;
(* Ensure proper color for text *)
TextColor( Title_Color );
End (* Draw_Menu_Frame *);
procedure Bell; {For when something goes wrong}
begin
Sound(440);
Delay(250);
NoSound;
end; {Bell}
procedure Print_Prn(outchar:char);
begin
write(lst,outchar);
end;
procedure Checkfield; { See if field should wrap around }
begin
if Field<Ff then Field:=Lf;
if Field>Lf then Field:=Ff;
end; { Checkfield }
procedure Brackets; { Print Entry limiters }
begin
GotoXY(Col[Field]-1,Row[Field]);
Write('[');
GotoXY(Col[Field]+Len[Field],Row[Field]);
Write(']');
end; { Brackets }
procedure NoBrackets; {Remove Entry limiters }
begin
GotoXY(Col[Field]-1,Row[Field]);
Write(' ');
GotoXY(Col[Field]+Len[Field],Row[Field]);
Write(' ')
end; { NoBrackets }
{ This is the main routine and calls all those above }
procedure GetInput;
begin {GetInput}
Ret:=false;
repeat {until Ret}
Brackets;
begin {Read the keyboard}
GotoXY(CurPos[Field],Row[Field]);
Read(kbd,Key[1]);
if (Key[1]=chr(27)) or (Key[1]=chr(0)) then
begin {Read second keystroke}
Read(kbd,Key[2]);
case Key[2] of
#59:begin
window(1,1,80,24);
clrscr;
halt; {Function Key 1 pressed - all Done}
end;
#72: begin {Move back (up) one field}
NoBrackets;
Field:=Field-1;
end; {Move back}
#80: begin {Move ahead (down) one field}
NoBrackets;
Field:=Field+1;
end; {Move ahead}
#75: begin {Cursor Left (backwards) one stroke}
CurPos[Field]:=CurPos[Field]-1;
if CurPos[Field] <Col[Field] then
begin {Back one field}
CurPos[Field]:=Col[Field]+Length(Ans[Field]);
Bell;NoBrackets;
Field:=Field-1;
end; {Back one field}
end; {Cursor left}
#77: begin {Cursor right (ahead) one stroke}
CurPos[Field]:=CurPos[Field]+1;
if CurPos[Field] >Col[Field]+Len[Field] then
begin {Ahead one field}
CurPos[Field]:=Col[Field]+Length(Ans[Field]);
Bell;NoBrackets;
Field:=Field+1;
end; {Ahead one field}
end; {Cursor right}
#60: begin {F2 pressed - this Entry o.k.}
Ret:=true;
end; {F2 Key }
#61: print_prn(#10); {LineFeed}
end; {Case - second keystroke}
Checkfield; {check for first or last field overlow}
end; {Read second keystroke}
Ks:=Key[1]; {Nothing very special so interpret Key[1] }
case Ks of {check keystroke for other meanings}
Tb: begin
CurPos[Field] := CurPos[Field] + 5;
insert(' ',Ans[Field],CurPos[Field]);
end;
Cr: begin {carriage return}
NoBrackets;
Field:=Field+1;
Checkfield;
end; {carriage return}
Bks: begin {Should we backspace}
if CurPos[Field]<=Col[Field] then Bell else
begin {backspace}
delete(Ans[Field],CurPos[Field]-Col[Field],1);
CurPos[Field]:=CurPos[Field]-1;
GotoXY(CurPos[Field],Row[Field]);
Write(' ');
GotoXY(CurPos[Field],Row[Field]);
end; {backspace}
end; {should we backspace}
end; {Case Statement - Check keystroke}
{Nothing there? -- must be a letter or number}
{ Now check if it is allowable }
if Ks in Allow[Field] then
begin {check length of answer}
if Length(Ans[Field]) <= Len[Field] then
if CurPos[Field]-Col[Field]+1>Len[Field] then Bell else
begin {Write keystroke}
HighVideo; {Bright screen }
Write(Ks);
LowVideo; { Dim Screen }
delete(Ans[Field],CurPos[Field]-Col[Field]+1,1);
insert(Ks,Ans[Field],CurPos[Field]-Col[Field]+1);
CurPos[Field]:=CurPos[Field]+1;
end; {Write keystroke}
end; {check length of answer}
end; { Reading Keyboard }
until Ret;
NoBrackets;
end; {GetInput}
{ This is the end of the main routine - following is for program use}
procedure Titles;
type
T = string[80];
var
Aa: integer;
Title: T;
begin
TextColor(0); TextBackGround(7);
Title:='F1 = Quit F2 = Print F3 = Line Feed';Aa:=0;
Aa:= (80-Length(title)) div 2;
GotoXY(Aa,21);Write(Title);
Title:='Up & Down Arrows change fields';Aa:=0;
Aa:= (80-Length(title)) div 2;
GotoXY(Aa,23);Write(Title);
end; {Titles}
{.PA}
{Use this procedure to load the array holding the parameters for the entry}
{ PromptCol = Column prompt is to start
Row = Row of prompt and entry
Len = Length of input field
Prompt = Text of prompt
Col = Column where input is to start (computed automatically)
CurPos = Current cursor position (internal to the routine)
Ans = The entry is returned to your program in this variable
Allow = The set of acceptable characters as defined earlier
}
procedure LoadArray;
begin
for Field:=Ff to Lf do
begin {do loop}
case Field OF
1:begin
PromptCol[Field]:=2;Row[Field]:=1;Len[Field]:=35;
Prompt[Field]:='Line 1: ';
Col[Field]:=PromptCol[Field]+Length(Prompt[Field])+2;
CurPos[Field]:=Col[Field];
Ans[Field]:='';
Allow[Field]:=all;
end;
2:begin
PromptCol[Field]:=2;Row[Field]:=2;Len[Field]:=35;
Prompt[Field]:='Line 2: ';
Col[Field]:=PromptCol[Field]+Length(Prompt[Field])+2;
CurPos[Field]:=Col[Field];
Ans[Field]:='';
Allow[Field]:=all;
end;
3:begin
PromptCol[Field]:=2;Row[Field]:=3;Len[Field]:=35;
Prompt[Field]:='Line 3: ';
Col[Field]:=PromptCol[Field]+Length(Prompt[Field])+2;
CurPos[Field]:=Col[Field];
Ans[Field]:='';
Allow[Field]:=all;
end;
4:begin
PromptCol[Field]:=2;Row[Field]:=4;Len[Field]:=35;
Prompt[Field]:='Line 4: ';
Col[Field]:=PromptCol[Field]+Length(Prompt[Field])+2;
CurPos[Field]:=Col[Field];
Ans[Field]:='';
Allow[Field]:=all;
end;
5:begin
PromptCol[Field]:=2;Row[Field]:=5;Len[Field]:=35;
Prompt[Field]:='Line 5: ';
Col[Field]:=PromptCol[Field]+Length(Prompt[Field])+2;
CurPos[Field]:=Col[Field];
Ans[Field]:='';
Allow[Field]:=all;
end;
6:begin
PromptCol[Field]:=2;Row[Field]:=6;Len[Field]:=35;
Prompt[Field]:='Line 6: ';
Col[Field]:=PromptCol[Field]+Length(Prompt[Field])+2;
CurPos[Field]:=Col[Field];
Ans[Field]:='';
Allow[Field]:=all;
end;
end; {doloop}
end; {case}
end; {LoadArray}
procedure Prompts;
begin
for Field:=Ff to Lf do
begin
LowVideo;
GotoXY(PromptCol[Field],Row[Field]);
Write(Prompt[Field]) { prompt is from an array }
end;
end;{Prompts}
procedure print_out;
begin
for Field:=Ff to Lf do
begin
Writeln(lst,Ans[Field]);
end;
Field:=Ff;
writeln;
writeln;
end; {print_out}
{This is the start of the Program}
begin
Titles;
Draw_Menu_Frame(15,10,65,18,7,15,'Label Editor G. Gallo');
Done:=false;Fini:=false;
while not Fini do
repeat
LoadArray;
Prompts;
Field:=Ff;
GetInput;
gotoxy(2,7);
HighVideo;
write('Number of labels to print [<enter> for 1]: ');
read(ch);
if length(ch) = 0 then num_more := 1
else
Val(ch,num_more,code);
while num_more > 0 do
begin
print_out;
num_more := num_more - 1;
end;
done := true;
ClrScr;
for Field:=Ff TO Lf do {Initialize fields}
begin
CurPos[Field]:=Col[Field];
end; {Initialize fields}
until Done;
end. {Fini}