Category : Pascal Source Code
Archive   : TPEDIT.ZIP
Filename : EDITOR.PAS
Interface
Uses
CRT;
Type
InpDate = String[8];
InpString = String[80];
InpInteger = String[10];
InpReal = String[28];
Str80 = String[80];
Var
FieldNo : LongInt;
LastField : LongInt;
Procedure Color(Foreground,Background : Byte);
Procedure Beep;
Procedure EditDate(Var DS : InpDate;
X,Y,FG,BG : Byte);
Procedure EditString(Var S : InpString;
L,X,Y,FG,BG : Byte;
Picture : Str80);
Procedure EditInt(Var I : LongInt;
L,X,Y,FG,BG : Byte);
Procedure EditReal(Var I : Real;
L,X,Y,DecPl,FG,BG : Byte);
Procedure EditChoice(Var C : Char;
X,Y : Byte;
Choice1,Choice2 : Char;
FG,BG : Byte);
Implementation
Procedure Color(Foreground,Background : Byte);
Begin
TextColor(Foreground);
TextBackground(Background);
End;
Procedure InverseColor(Foreground,Background : Byte);
Begin
If Foreground < 8 then Foreground := Foreground + 8;
If Background > 8 then Background := Background - 8;
TextColor(Background);
TextBackground(Foreground);
End;
Procedure Beep;
Begin
Sound(400); Delay(100);
Sound(200); Delay(100);
NoSound;
End;
Procedure EditDate(Var DS : InpDate;
X,Y,FG,BG : Byte);
Var
Mo,Da,Yr : String[2];
Done : Boolean;
Ch : Char;
Postn : Byte;
Begin
gotoXY(X,Y);
InverseColor(FG,BG);
If DS = '' then
Begin
DS := ' / / ';
Write(DS);
End else Write(DS);
gotoXY(X,Y); Postn := X;
Done := False;
Repeat
Ch := ReadKey;
Case Ch of
'0'..'9' : Begin
Write(Ch);
DS[(Postn+1)-X] := Ch;
Postn := Postn + 1;
If (Postn = X+2) or (Postn = X+5) then Postn := Postn + 1;
gotoXY(Postn,Y);
If Postn >= X + 8 then
Begin
Done := True;
Inc(FieldNo);
End;
End;
#13 : Begin
Done := True;
Inc(FieldNo);
End;
#0 : Begin
Ch := ReadKey;
Case Ch of
#71 : Begin { Home }
Postn := X;
gotoXY(Postn,Y);
End;
#72 : Begin { Up Arrow }
Done := True;
Dec(FieldNo);
If FieldNo < 1 then FieldNo := 1;
End;
#80 : Begin { Down Arrow }
Done := True;
Inc(FieldNo);
If FieldNo > LastField then
FieldNo := LastField;
End;
#73 : Begin { PgUp }
Done := True;
FieldNo := 1;
End;
#81 : Begin { PgUp }
Done := True;
FieldNo := LastField;
End;
#75 : Begin { Left arrow }
Postn := Postn - 1;
If (Postn = X+2) or (Postn = X+5) then
Postn := Postn - 1;
gotoXY(Postn,Y);
If Postn < X then Postn := X;
End;
#77 : Begin { Right arrow }
Postn := Postn + 1;
If (Postn = X+2) or (Postn = X+5) then
Postn := Postn + 1;
gotoXY(Postn,Y);
If Postn >= X + 6 then Postn := X + 6;
End;
End; { Case }
End; { Ch = #0 }
End; { Case }
Until Done;
Color(FG,BG);
gotoXY(X,Y); Write(DS);
End;
Procedure EditString(Var S : InpString;
L,X,Y,FG,BG : Byte;
Picture : Str80);
Var
InsFlag,
Done : Boolean;
Postn : Byte;
Ch : Char;
Begin
Done := False;
InsFlag := False;
gotoXY(X,Y);
InverseColor(FG,BG);
While Length(S) < L do S := S + ' ';
gotoXY(X,Y);
Write(S);
gotoXY(X,Y);
Postn := X;
Repeat
Ch := ReadKey;
Case Ch of
#32..#126 : Begin
If InsFlag then
Begin
If Picture[Postn+1-X] = 'U' then Ch := Upcase(Ch);
Write(Ch);
Insert(Ch,S,(Postn+1)-X);
S[0] := Chr(L);
gotoXY(X,Y); Write(S);
End else
Begin
If Picture[Postn+1-X] = 'U' then Ch := Upcase(Ch);
Write(Ch);
S[(Postn+1)-X] := Ch;
End;
Inc(Postn);
If (Picture[Postn-X] = '#') and not (Ch in['0'..'9']) then
Begin
Dec(Postn);
Delete(S,Postn+1-X,1);
S := S + ' ';
gotoXY(X,Y); Write(S);
Beep;
End;
If Picture[Postn+1-X] = '*' then Inc(Postn);
gotoXY(Postn,Y);
If Postn >= X + L then
Begin
Done := True;
Inc(FieldNo);
End;
End;
#13 : Begin
Done := True;
Inc(FieldNo);
End;
#8 : Begin { Destructive Backspace }
If Pos('-',Picture) = 0 then
Begin
Dec(Postn);
If Postn < X then Postn := X;
Delete(S,(Postn+1)-X,1);
S := S + ' ';
gotoXY(X,Y); Write(S);
gotoXY(Postn,Y);
End;
End;
#0 : Begin
Ch := ReadKey;
Case Ch of
#71 : Begin { Home }
Postn := X;
gotoXY(Postn,Y);
End;
#72 : Begin { Up Arrow }
Done := True;
Dec(FieldNo);
If FieldNo < 1 then FieldNo := 1;
End;
#80 : Begin { Down Arrow }
Done := True;
Inc(FieldNo);
If FieldNo > LastField then
FieldNo := LastField;
End;
#73 : Begin { PgUp }
Done := True;
FieldNo := 1;
End;
#81 : Begin { PgUp }
Done := True;
FieldNo := LastField;
End;
#75 : Begin { Left arrow }
Dec(Postn);
If Picture[Postn+1-X] = '*' then Dec(Postn);
gotoXY(Postn,Y);
If Postn < X then Postn := X;
End;
#77 : Begin { Right arrow }
Inc(Postn);
If Picture[Postn+1-X] = '*' then Inc(Postn);
gotoXY(Postn,Y);
If Postn >= X + L-2 then Postn := X + L-2;
End;
#82 : Begin { Toggle Insert }
If Pos('*',Picture) = 0 then
If not InsFlag then InsFlag := True
else InsFlag := False;
End;
#83 : Begin { Del }
If Pos('*',Picture) = 0 then
Begin
Delete(S,(Postn+1)-X,1);
S := S + ' ';
gotoXY(X,Y); Write(S);
gotoXY(Postn,Y);
End;
End;
End; { Case }
End; { Ch = #0 }
End; { Case }
Until Done;
Color(FG,BG);
gotoXY(X,Y); Write(S);
While S[Length(S)] = ' ' do Delete(S,Length(S),1)
End;
Function IntToStr(I : LongInt; Len : Byte) : InpInteger;
Var
IntString : InpInteger;
Begin
Str(I:Len,IntString);
IntToStr := IntString;
End;
Function StrToInt(IStr : InpInteger) : LongInt;
Var
Code : Integer;
StringInt : LongInt;
Begin
While IStr[1] = ' ' do Delete(IStr,1,1);
Val(IStr,StringInt,Code);
StrToInt := StringInt;
End;
Procedure EditInt(Var I : LongInt;
L,X,Y,FG,BG : Byte);
Var
Done : Boolean;
Postn : Byte;
Ch : Char;
IInt : InpInteger;
Begin
Done := False;
gotoXY(X,Y);
InverseColor(FG,BG);
IInt := IntToStr(I,L);
Write(IInt);
gotoXY(X,Y);
Postn := X + L;
gotoXY(Postn-1,Y);
Repeat
Ch := ReadKey;
Case Ch of
'-','0'..'9' : Begin
IInt := IInt + Ch;
While (IInt[1] = ' ') or (IInt[1] = '0')
do Delete(IInt,1,1);
If Length(IInt) = L then
Begin
Done := True;
Inc(FieldNo);
End;
While Length(IInt) < L do IInt := ' ' + IInt;
gotoXY(X,Y); Write(IInt);
gotoXY(Postn-1,Y);
End;
#13 : Begin
Done := True;
Inc(FieldNo);
End;
#8 : Begin
Delete(IInt,Length(IInt),1);
While Length(IInt) < L do IInt := ' ' + IInt;
gotoXY(X,Y); Write(IInt);
gotoXY(Postn-1,Y);
End;
#0 : Begin
Ch := ReadKey;
Case Ch of
#83 : Begin
Delete(IInt,Length(IInt),1);
While Length(IInt) < L do IInt := ' ' + IInt;
gotoXY(X,Y); Write(IInt);
gotoXY(Postn-1,Y);
End;
#72 : Begin { Up Arrow }
Done := True;
Dec(FieldNo);
If FieldNo < 1 then FieldNo := 1;
End;
#80 : Begin { Down Arrow }
Done := True;
Inc(FieldNo);
If FieldNo > LastField then
FieldNo := LastField;
End;
#73 : Begin { PgUp }
Done := True;
FieldNo := 1;
End;
#81 : Begin { PgUp }
Done := True;
FieldNo := LastField;
End;
End; { Case }
End;
End; { Case }
Until Done;
Color(FG,BG);
gotoXY(X,Y); Write(IInt);
I := StrToInt(IInt);
End;
Function RealToStr(I : Real; L,DecPl : Byte) : InpReal;
Var
StringReal : InpReal;
Begin
Str(I:L:DecPl,StringReal);
RealToStr := StringReal;
End;
Function StrToReal(RealStr : InpReal) : Real;
Var
Code : Integer;
RealString : Real;
Begin
While RealStr[1] = ' ' do Delete(RealStr,1,1);
Val(RealStr,RealString,Code);
StrToReal := RealString;
End;
Procedure EditReal(Var I : Real;
L,X,Y,DecPl,FG,BG : Byte);
Var
DecFlag,
Done : Boolean;
Postn,Loc : Byte;
Ch : Char;
IntPart : InpInteger;
DecPart : InpReal;
IReal : InpReal;
Begin
Done := False;
DecFlag := False;
IReal := RealToStr(I,L,DecPl);
IntPart := Copy(IReal,1,L-(DecPl+1));
DecPart := Copy(IReal,L-DecPl+1,DecPl);
InverseColor(FG,BG);
gotoXY(X,Y); Write(IReal);
Postn := (X+L) - (DecPl+2);
gotoXY(Postn,Y);
Repeat
Ch := ReadKey;
Case Ch of
#46 : Begin
If DecFlag then
Begin
DecFlag := False;
Postn := (X+L) - (DecPl+2);
gotoXY(Postn,Y);
End;
If not DecFlag then
Begin
DecFlag := True;
Loc := 1;
Postn := (X+L) - (DecPl);
gotoXY(Postn,Y);
End;
End;
'-','0'..'9' : Begin
If not DecFlag then
Begin
IntPart := IntPart + Ch;
While (IntPart[1] = ' ') or (IntPart[1] = '0')
do Delete(IntPart,1,1);
If Length(IntPart) = L - (DecPl+1) then
Begin
DecFlag := True;
Loc := 1;
Postn := (X+L) - (DecPl);
gotoXY(Postn,Y);
End;
While Length(IntPart) < L - (DecPl+1)
do IntPart := ' ' + IntPart;
gotoXY(X,Y); Write(IntPart);
gotoXY(Postn,Y);
End else
Begin
DecPart[Loc] := Ch;
gotoXY(Postn,Y); Write(Copy(DecPart,1,DecPl));
gotoXY(Postn,Y);
Inc(Loc);
If DecPart[DecPl] > '0' then
Begin
Done := True;
Inc(FieldNo);
End;
End;
End;
#13 : Begin
Done := True;
Inc(FieldNo);
End;
#8 : Begin
If not DecFlag then
Begin
Delete(IntPart,Length(IntPart),1);
While Length(IntPart) < L-DecPl-1
do IntPart := ' ' + IntPart;
gotoXY(X,Y); Write(IntPart);
gotoXY(Postn,Y);
End else
Begin
Delete(DecPart,1,1);
DecPart := DecPart + '0';
gotoXY(X+L-DecPl,Y);
Write(DecPart);
gotoXY(Postn,Y);
End;
End;
#0 : Begin
Ch := ReadKey;
Case Ch of
#83 : Begin
If not DecFlag then
Begin
Delete(IntPart,Length(IntPart),1);
While Length(IntPart) < L-DecPl-1
do IntPart := ' ' + IntPart;
gotoXY(X,Y); Write(IntPart);
gotoXY(Postn,Y);
End else
Begin
Delete(DecPart,1,1);
DecPart := DecPart + '0';
gotoXY(X+L-DecPl,Y);
Write(DecPart);
gotoXY(Postn,Y);
End;
End;
#72 : Begin { Up Arrow }
Done := True;
Dec(FieldNo);
If FieldNo < 1 then FieldNo := 1;
End;
#80 : Begin { Down Arrow }
Done := True;
Inc(FieldNo);
If FieldNo > LastField then
FieldNo := LastField;
End;
#73 : Begin { PgUp }
Done := True;
FieldNo := 1;
End;
#81 : Begin { PgUp }
Done := True;
FieldNo := LastField;
End;
End; { Case }
End;
End; { Case }
Until Done;
Color(FG,BG);
IReal := IntPart + '.' + DecPart;
gotoXY(X,Y); Write(IReal);
I := StrToReal(IReal);
End;
Procedure EditChoice(Var C : Char;
X,Y : Byte;
Choice1,Choice2 : Char;
FG,BG : Byte);
Var
Done : Boolean;
Ch : Char;
Begin
Done := False;
gotoXY(X,Y);
InverseColor(FG,BG);
Repeat
Ch := Upcase(Readkey);
If Ch in[Choice1,Choice2] then
Begin
Done := True;
Inc(FieldNo);
End else
Begin
Case Ch of
#0 : Begin
Ch := ReadKey;
Case Ch of
#72 : Begin { Up Arrow }
Done := True;
Dec(FieldNo);
If FieldNo < 1 then FieldNo := 1;
End;
#80 : Begin { Down Arrow }
Done := True;
Inc(FieldNo);
If FieldNo > LastField then
FieldNo := LastField;
End;
#73 : Begin { PgUp }
Done := True;
FieldNo := 1;
End;
#81 : Begin { PgUp }
Done := True;
FieldNo := LastField;
End;
End; { Case }
End; { Ch = #0 }
End; { Case }
End;
If not Done then Beep;
Until Done;
C := Ch;
Color(FG,BG);
gotoXY(X,Y); Write(C);
End;
End.
Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!
This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.
But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/