home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Power-Programmierung
/
CD1.mdf
/
pascal
/
library
/
dos
/
vi_si_on
/
fargo.pas
< prev
next >
Wrap
Pascal/Delphi Source File
|
1991-04-06
|
16KB
|
541 lines
Program Wells_Fargo;
Uses Dos,CRT,ExecSwap,FastTTT5,WinTTT5,MenuTTT5,PullTTT5,ReadTTT5;
Type WFRecord=Record
Description :String[40];
Path :String[35];
ProgramName :String[12];
Password :String[20];
UseEMS :Boolean;
End;
Const PassChar = #15;
CursorRight = #205;
CursorLeft = #203;
CursorDown = #208;
CursorUp = #200;
EnterKey = #13;
EscKey = #27;
EndKey = #207;
HomeKey = #199;
DelKey = #211;
Backspace = #8;
InsKey = #210;
Zap = #160; {Alt D to delete the field}
MinInt = -32768;
MaxLongInt:longint = 2147483647;
MinLongInt:longint = -2147483647;
MaxWord = 65535;
MinWord = 0;
Var wffile:file of WFRecord;
num:integer;
r,ar:WFRecord;
Main_Choice,Choice,Error:integer;
X,Y,ScanTop,ScanBot:byte;
M1,MM:Menu_record;
Ch:char;
Done:Boolean;
Cursor_X,
Cursor_Y:byte;
temp:String;
Procedure Clang;
begin
sound(1500);
delay(50);
nosound;
end;
Procedure Read_Line(X,Y,L,F,B,Format:byte; Text:String);
{
X is X coord of first character in field
Y is Y coord of field
L is the maximum length of the input field
F is the foreground color
B is the background color
Fornat Codes: 1 Any String
2 Force Upper String
3 Yes/No
4 Alphabetics only
5 Integer
6 LongInteger
7 Real
8 Word
(* Maybe
9 Date (MM/DD/YY)
10 Date (DD/MM/YY)
*)
11 Echo a Password
Text is a string updated with the string equivalent of user input
}
var
TempText : string;
CursorPos : byte;
InsertMode,
Password,
Alldone : boolean;
FirstCharPress: boolean;
Ch : char;
Procedure Check_Parameters;
begin
TempText := Text;
If length(TempText) > L then
Delete(Temptext,L+1,length(TempText)-L);
If not X in [1..80] then
X := 1;
If X + L - 1 > 80 then X := 81 - L;
If not Y in [1..25] then
Y := 1;
If RTTT.BegCursor then
CursorPos := 1
else
begin
If length(TempText) < L then
CursorPos := length(TempText) + 1
else
CursorPos := length(TempText);
end;
InsertMode := RTTT.Insert;
Alldone := False;
If Format = 11 then
begin
Password := true;
Format := 1;
end
else
Password := false;
end; {sub Proc Check_Parameters}
Function FillWhiteSpace(Str:string):string;
var I : integer;
begin
If Password then
Str := replicate(length(Str),PassChar);
while length(Str) < L do
Str := Str + RTTT.WhiteSpace;
FillWhiteSpace := Str;
end; {sub Func FillWhiteSpace}
Procedure MoveTheCursor;
begin
GotoXY(X+CursorPos-1,Y);
end; {sub Proc MoveTheCursor}
Procedure Write_String;
begin
Fastwrite(X,Y,attr(F,B),FillWhiteSpace(TempText));
MoveTheCursor;
end;
Procedure Erase_Field;
begin
TempText := '';
CursorPos := 1;
Write_String;
end;
Procedure Char_Backspace;
begin
If CursorPos > 1 then
begin
CursorPos := Pred(CursorPos);
Delete(TempText,CursorPos,1);
Write_String;
end;
end; {sub Proc Char_Backspace}
Procedure Char_Del;
begin
If CursorPos <= length(TempText) then
begin
Delete(TempText,CursorPos,1);
Write_String;
end;
end; {sub Proc Char_Del}
Procedure Add_Char(Ch:char);
begin
If InsertMode then
begin
If length(TempText) < L then
begin
Insert(Ch,TempText,CursorPos);
If CursorPos < L then
CursorPos := Succ(CursorPos);
end;
end
else {not insertmode}
begin
Delete(TempText,CursorPos,1);
Insert(Ch,TempText,CursorPos);
If CursorPos < L then
CursorPos := Succ(CursorPos);
end; {if insert}
Write_String;
end; {sub proc Add_Char}
begin {main Procedure Read_Line}
Check_Parameters;
R_Null := false;
(* FindCursor(Cursor_X,Cursor_Y,ScanTop,ScanBot); *)
If RTTT.Insert then
HalfCursor
else
OnCursor;
Write_String;
FirstCharPress := true;
Repeat
Ch := ReadKey; (* Getkey; *)
If Format in [2,3] then
Ch := upcase(Ch);
If Ch in RTTT.End_Chars then
begin
AllDone := True;
If Ch <> #027 then Text := TempText;
end
else
Case Ch of
#131, {mouseright}
CursorRight : begin
If (CursorPos < L)
and (CursorPos <= length(TempText)) then
begin
CursorPos := Succ(CursorPos);
MoveTheCursor;
end;
end;
#130, {mouseleft}
CursorLeft : begin
If CursorPos > 1 then
begin
CursorPos := Pred(CursorPos);
MoveTheCursor;
end;
end;
HomeKey : begin
CursorPos := 1;
MoveTheCursor;
end;
EndKey : begin
If CursorPos < L then
If length(TempText) < L then
CursorPos := length(TempText) + 1
else
CursorPos := L;
MoveTheCursor;
end;
InsKey : If Format <> 3 then {don't allow insert on Y/N!}
begin
InsertMode := not InsertMode;
If InsertMode then
HalfCursor
else
OnCursor;
end;
DelKey : Char_Del;
BackSpace : Char_Backspace;
Zap : Erase_Field;
#132,
EscKey : If RTTT.AllowEsc then
Alldone := true;
#133,
EnterKey : begin
Alldone := true;
Text := TempText;
temp:=TempText;
end;
#33 .. #42, {! to *}
#44,#47, {, /}
#58 .. #64, {: to @}
#91 .. #96, {[ to '}
#123 .. #126 : If (Format in [1,2]) then {{ to ~}
begin
If FirstCharPress and RTTT.EraseDefault then
Erase_Field;
Add_Char(Ch);
end
else
Clang;
#43, #45 : If (Format in [1,2]) { + - }
or ( (CursorPos=1) and (Format in [5,6,7])) then
begin
If FirstCharPress and RTTT.EraseDefault then
Erase_Field;
Add_Char(Ch);
end
else
Clang;
#46 : If (Format in [1,2]) {.}
or ( (Pos('.',TempText)=0) and (Format = 7)) then
begin
If FirstCharPress and RTTT.EraseDefault then
Erase_Field;
Add_Char(Ch);
end
else
Clang;
#48..#57 : If (Format in [1..2,5..8]) then {0 to 9}
begin
If FirstCharPress and RTTT.EraseDefault then
Erase_Field;
Add_Char(Ch);
end
else
Clang;
#32, {space}
#65..#77, {A to M}
#79..#88, {O to X}
#90, {Z}
#97..#122 : If (Format in [1,2,4]) then {a to z}
begin
If FirstCharPress and RTTT.EraseDefault then
Erase_Field;
Add_Char(Ch);
end
else
Clang;
#78,#89 : If (Format in [1..4]) then {N Y}
begin
Add_Char(Ch);
If Format = 3 then
begin
Alldone := true;
Text := TempText;
end;
end
else
Clang;
#128,#129 :; {absorb stray mouse movement to avoid Clang'n}
else Clang;
end; {case}
FirstCharPress := false;
Until Alldone;
R_Char := Ch;
If RTTT.RightJustify
and (Format > 4) then
begin
Fastwrite(X,Y,attr(F,B),replicate(L,RTTT.Whitespace));
Fastwrite(X+L-Length(TempText),Y,attr(F,B),Text);
end
else
Fastwrite(X,Y,attr(F,B),FillWhiteSpace(Text));
GotoXY(Cursor_X,Cursor_Y);
SizeCursor(ScanTop,ScanBot);
end;
function exist (n:string):boolean;
var f:file;
i:integer;
begin
assign (f,n);
reset (f);
i:=ioresult;
exist:=i=0;
close (f);
i:=ioresult
end;
function numentry:integer;
begin
numentry:=filesize(WFfile)
end;
procedure seekwffile (n:integer);
begin
seek (WFfile,n-1)
end;
procedure openwffile;
var n:integer;
begin
n:=ioresult;
assign (WFfile,'FARGO.DAT');
reset (WFfile);
if ioresult<>0 then begin
close (WFfile);
n:=ioresult;
rewrite (WFfile)
end
end;
Procedure Grand_Opening;
Begin
FillScreen(1,1,80,25,white,blue,chr(176));
GrowFBox(25,10,55,17,yellow,blue,4);
WriteCenter(12,15,1,'Wells Fargo Quick Menus');
WriteCenter(13,15,1,'Written By: Josh Ham');
WriteCenter(14,15,1,'Requested By: Larry Ham');
WriteCenter(16,11,1,'Quick Menus (c)1991');
Delay(3000);
End;
Procedure Entry_Box;
Begin
FillScreen(1,1,80,25,white,blue,char(176));
TextAttr:=1;
GrowFBox(15,5,65,20,blue,blue,4);
TextAttr:=8;
For x:=17 to 66 Do Begin Gotoxy(x,21); Write(char(219)); End;
For y:=6 to 21 Do Begin Gotoxy(66,y); Write(char(219)+Char(219)); End;
End;
Procedure EC;
Begin
Textbackground(7);
Textcolor(0);
End;
Procedure EF;
Begin
Textbackground(1);
Textcolor(11);
End;
Procedure Add_An_Entry;
var ch:Char;
a,b,c,d:string;
Begin
Entry_Box;
Textbackground(1);
TextColor(14);
Gotoxy(22,6);
Write('Wells Fargo Quick Menus - Add an Entry');
TextColor(9);
For x:=15 to 65 Do Begin gotoxy(x,7); Write(char(196)); End;
TextColor(11);
OpenWfFile;
num:=numentry;
Gotoxy(17,9); Write('Enter Filename To Execute'); ec;
Gotoxy(17,10); Write('············'); ef;
Gotoxy(17,12); Write('Enter Full Path To The Above File'); ec;
Gotoxy(17,13); Write('····································'); ef;
Gotoxy(17,15); Write('Enter a Description Of This Entry'); ec;
gotoxy(17,16); Write('·········································'); ef;
gotoxy(17,18); Write('Enter a Password To Load This (Enter=None)'); ec;
gotoxy(17,19); Write('·····················');
clang;
r.programname:='';
Gotoxy(17,10);ReadLine(17,10,12,0,7,r.programname);
r.programname:=temp;
r.path:='';
gotoxy(17,13);ReadLine(17,13,35,0,7,r.path);
r.path:=temp;
r.description:='';
gotoxy(17,16);ReadLine(17,16,40,0,7,r.description);
r.description:=temp;
r.password:='';
gotoxy(17,19);ReadLine(17,19,20,0,7,r.password);
r.password:=temp;
GrowFBox(25,1,53,3,lightblue,blue,4);
Clang; ef;
textcolor(15);
Gotoxy(27,2); Write('Save This To Disk? [Y/N]');
Repeat
Ch:=ReadKey;
Until (ch='Y') or (ch='y') or (ch='N') or (ch='n');
If (ch='Y') or (ch='y') Then Begin
if not exist ('FARGO.DAT') then rewrite (WFfile);
seekwffile(num+1);
write (WFfile,r);
End;
ef;
FillScreen(1,1,80,25,white,blue,chr(176));
Close(Wffile);
End;
Procedure Edit_Entry;
var howmany:integer;
Begin
FillScreen(1,1,80,25,white,blue,chr(176));
GrowFBox(25,1,53,3,lightblue,blue,4);
Clang; ef;
textcolor(15);
OpenWffile;
howmany:=numentry;
Gotoxy(27,2); Write('Edit Which Entry? [1-',howmany,']:');
gotoxy(51,2); ReadLn(howmany);
seekwffile(howmany+1);
read(wffile,r);
FillScreen(30,5,75,15,blue,blue,chr(219)); ef;
GotoXy(42,6); Write('Wells Fargo Quick Menu Editor'); ec;
Gotoxy(32,8); Write('············');
Gotoxy(32,10); Write('····································');
gotoxy(32,12); Write('·········································');
gotoxy(32,14); Write('·····················');
gotoxy(32,8); Write(r.programname);
gotoxy(32,10);Write(r.path);
gotoxy(32,12);Write(r.description);
gotoxy(32,14);If r.password='' then Write ('N/A') Else write(r.password);
readln;
Close(WfFile);
End;
Procedure Utilitys;
Begin
Menu_Set(M1);
With M1 do
begin
Heading1 := '- Wells Fargo Quick Menu Utilitys -';
Heading2 := 'Quick Menus (c)1991';
Topic[1] := ' Add a new entry';
Topic[2] := ' Edit an existing entry';
Topic[3] := ' Delete an existing entry ';
Topic[4] := ' Quit Utility Section';
TotalPicks := 4;
PicksPerLine := 1;
Addprefix := 0;
TopleftXY[1] := 0;
TopleftXY[2] := 8;
Boxtype := 5;
If ColorScreen then
begin
Colors[1] := white;
Colors[2] := blue;
Colors[3] := lightgray;
Colors[4] := red;
Colors[5] := lightgray;
end
else
begin
Colors[1] := white;
Colors[2] := black;
Colors[3] := black;
Colors[4] := lightgray;
Colors[5] := white;
end;
AllowEsc := false;
Margins := 5;
end; {with M1 do}
end; {Define_Menu1}
Procedure Utility_Menu;
Var Quit:Boolean;
Begin
Quit:=False;
Findcursor(X,Y,ScanTop,ScanBot);
Main_Choice := 1;
Done:=False;
FillScreen(1,1,80,25,white,blue,chr(176));
repeat
Utilitys;
DisplayMenu(M1,false,Main_Choice,Error);
Case Main_Choice of
1:Add_An_Entry;
2:Edit_Entry;
3:Begin End;{Delete_An_Entry;}
4:Quit:=True;
end;
until Quit;
FillScreen(1,1,80,24,white,blue,chr(176));
main_choice:=1;
End;
Begin
Grand_Opening;
Utility_Menu;
End.