Appointment Pad for DOS, poor example TP6 source

kefis...@iglou.com (Ken Fischer)

Delphi Developer

Wed, 18 Jun 1902 08:00:00 GMT

Appointment Pad for DOS, poor example TP6 source

Filename MYAP.PAS
Sorry for posting such a mess, I wrote it ten years ago,
and thought it might make a good summer project to clean
it up, see how many global variables can be removed, etc. :-)

Ken Fischer

{ This program is for DOS only, written in TP6.0,
_REQUIRES_ a directory on the C: drive called "APAD".

Once the APAD directory is created, and added to
the PATH in Autoexec.BAT the executable of this
program can be copied to a directory that is in
the path, and a small calendar and appointment
system results. Run the program to create a
calendar pad for any month, and to enter short
notes or appointtments. After 1999, type 20nn.

It writes .com files that can be viewed by just
typing the name given that month, so use a very
consistent naming system, and erase the previous
year's file for that month, or name as june99, etc.

Once a file for a month is created, the program
reads the .com file to get the existing information
to include in the modified file. This could cause
loss of information in case of power failure or
other interruption of file creation, if the user
wants to add a backup file routine, great.

To just _VIEW_ a month's appointments, just type
the name of the month, and it will be displayed
by the .com file.

The best list of names for months can be seen in
the souurce code.
Kenneth E. Fischer }

PROGRAM WRITE_APPOINTMENT_SHEET;

uses Dos,Crt;

TYPE SCR_PAGE = ARRAY[1..23] OF ARRAY[1..80] OF CHAR;

VAR PAGE1 : SCR_PAGE;

Var month,m,yr,days: Real;
Var D: Array[1..31] of String[3];
var CA: array[1..42] of string[3];
VAR e,j,O,P,Q,R,S,U,Cx,CXX,I,II,B,Z,molen,FM: INTEGER;
VAR CF,W,t,t1,t2,t3,t4,t5,t6,t7,Q1,Q2,Q3,Q4,Q5,Q6: REAL;

VAR CR,H1B,H5B,H3B,H22,H1A,H4A,H30,H31,H32,H01,
INCDI,DECCX,INCSI,HB4,H09,HCD,H21,H20,H24 :CHAR;

B1,B2,B3,B4,N1,N2,N3,N4,saveX,saveY,
X,Y,OS,SB,W1,W2,
DI,SI,ES,year :INTEGER;

MOVAH,MOVAL,MOVAX,MOVBH,MOVBL,MOVBX,MOVCH,MOVCL,MOVCX,
MOVDH,MOVDL,MOVDX,MOVESAX,MOVDIAL,MOVALSI,Ch :STRING[24];

C,CC,CCC,CCH :CHAR;

TMPFIL,FILVAR,MODFIL :TEXT;

FNAME,FILENAME,MODNAME,MONTHNAME :STRING[14];

VAR
CF1,CF2,CF3,CF4,CF5,CF6,CF7,CF8,NOP,
ESC,C5,PE,HN0,IC,SC,
HN1,HN2 :CHAR;
LOOP,US,SP,TERM,N0,NN0,SN,
B5,B6,NN1,NN2,
A,PB,PM,DOOVER :INTEGER;
FIL,TEMPVAR :TEXT;
MSG,FILNAM,FILENAM,TEMPFILE,TEMPFIL :STRING[24];

Procedure LOC;
begin
GotoXY(X,Y);
end;

Procedure GET_MOD_NAME_TO_WRITE; (* This version uses .COM file as template *)
LABEL OVER,ALL;
VAR L2 : INTEGER;
begin
DOOVER:= 0; FILENAME:= ''; FILENAM:= ''; Textcolor(6);
GotoXY(26,5); Writeln('Aviance Appointment Pad'); textcolor(7);
GotoXY(26,7); Writeln(' by Joe Fischer '); writeln;
Writeln(' When finished, CONTROL-Q Writes file, and Quits Program');
GotoXY(1,12); textcolor(white);
WRITE('Enter MONTH of Appointment File TO WRITE OR MODIFY : ');
GotoXY(53,12);
OVER:
READLN(FILENAME);
if Filename = '' then GOTO OVER;
ASSIGN(FIL,FILENAME);
{$I-}
RESET(FIL);
{$I+}
IF IORESULT <> 0 THEN begin
DOOVER:= 1; WRITELN;
end;
WRITELN(FILENAME);
FOR L2:= 1 TO LENGTH(FILENAME) DO
begin
CH:= COPY(FILENAME,L2,1);
IF CH = '.' THEN GOTO ALL;
FILENAM:= FILENAM + CH;
end;
ALL:
TEMPFIL:= FILENAM;
FILENAM:= '\APAD\' + FILENAM + '.COM';
WRITELN(FILENAM);
ASSIGN(FILVAR,FILENAM);
{$I-}
RESET(FILVAR);
{$I+}
IF IORESULT = 0 THEN begin
WRITELN(Filenam,' FILE ALREADY EXISTS!!!');
WRITELN('DO YOU WANT TO MODIFY, Y/N');
C:= ' '; C:= READkey;
If C = 'y' then C:= 'Y';
IF C = 'Y' THEN begin DOOVER:= 1;
CLOSE(FILVAR);
end ELSE DOOVER:= 2;
end ELSE (* FILE DOES NOT EXIST *)
begin
WRITELN('FILE WILL BE NAMED ',FILENAM);
DELAY(2000);
end;
end;

Procedure KEEP_INBOUNDS;
begin
IF Y > 23 THEN Y:= 23;
IF Y < 1 THEN Y:= 1;
IF X < 1 THEN X:= 1;
IF X > 79 THEN X:= 79;
end;

Procedure Write_Double_Spaced;
LABEL ALL;
var L3,Lp,Index :Integer;
LongPage_Filename:String[32];
LongFilvar :Text;
begin
SaveX:= WhereX; SaveY:= WhereY;
LongPage_Filename:= '';
FOR L3:= 1 TO LENGTH(FILENAM) DO
begin
CH:= COPY(FILENAM,L3,1);
IF CH = '.' THEN GOTO ALL;
LongPage_Filename:= LongPage_Filename + CH;
end;
ALL:

Filnam:= '';
Filnam:= 'C:' + LongPage_Filename + '.TXT';
Assign(LongFilvar,Filnam);
Rewrite(LongFilvar);
Index:= 0;
For Y:= 1 to 23 do
begin
FOR X:= 1 TO 80 DO
begin
SC:= PAGE1[Y,X];
WRITE(LongFilvar,SC);
end; (* To lengthen the printout, just add another #12,#10 *)
Write(LongFilvar,chr(13),chr(10),chr(13),chr(10));
Index:= Index + 80;
end;
Close(LongFilvar);
X:= SaveX; Y:= SaveY;
Keep_Inbounds; LOC;
end;

Procedure E_K;
begin
CC:= READkey;
CASE CC OF
#59 : begin Write_Double_Spaced; end;
#71 : begin X:= 1; end;
#80 : begin Y:= Y + 1; end;
#72 : begin Y:= Y - 1; end;
#75 : begin X:= X - 1; end;
#77 : begin X:= X + 1; end;
end; (* CASE *)
KEEP_INBOUNDS; LOC;
end;

Procedure NEW_MOD;
begin
WRITELN(filvar,' APPOINTMENTS FOR ',MONTHname,' ',YEAR);
end;

Procedure ENTER_DATA;
LABEL MOV,BYE;
begin
X:= 8; Y:= 4;
MOV:
KEEP_INBOUNDS; LOC; GOTOXY(X,Y);
C:= Readkey;
IF C = #0 THEN begin E_K; GOTO MOV; end;
IF C = #13 THEN begin
LOC; X:= 1; Y:= Y + 1; LOC; GOTO MOV;
end;
IF C = #17 THEN GOTO BYE;
IF C = #26 THEN begin LOC; WRITE(CHR(3)); PAGE1[Y,X]:= CHR(3);
X:= X + 1; LOC; GOTO MOV; end;
IF C = #7 THEN begin LOC; WRITE(CHR(3)); PAGE1[Y,X]:= CHR(3);
X:= X + 1; LOC; GOTO MOV; end;
IF C = #8 THEN begin LOC; WRITE(CHR(32)); PAGE1[Y,X]:= CHR(32);
X:= X - 1; LOC; GOTO MOV; end;
IF C = #9 THEN begin LOC; WRITE(CHR(32)); PAGE1[Y,X]:= CHR(32);
X:= X + 1; LOC; GOTO MOV; end;
IF C = #10 THEN begin LOC; WRITE(CHR(2)); PAGE1[Y,X]:= CHR(2);
X:= X + 1; LOC; GOTO MOV; end;
IF C <> #27 THEN begin
LOC; WRITE(C); PAGE1[Y,X]:= C; X:= X + 1; LOC;
end;
GOTO MOV;
BYE:
end;

Procedure WRITE_FILE;
VAR KN :INTEGER;
begin
ASSIGN(FILVAR,FILENAM);
REWRITE(FILVAR);
CF1:= CHR($B4); CF2:= CHR($09); CF3:= CHR($BA); CF4:= CHR($10);
CF5:= CHR($01); CF6:= CHR($CD); CF7:= CHR($21); CF8:= CHR($20);
X:= 7; Y:= 2; N1:= 5; N2:= 9; H32:= CHR($32); H4A:= CHR($4A);
WRITE(FILVAR,CF1,CF2,CF3,CF4,CF5,CF6,CF7,CF6,CF8);
NOP:= CHR($90);
WRITE(FILVAR,NOP,NOP,NOP,NOP,NOP,NOP,NOP);
FOR Y:= 1 TO 23 DO
begin
FOR X:= 1 TO 80 DO
begin
SC:= PAGE1[Y,X];
WRITE(FILVAR,SC);
end;
end;
end;

Procedure LOAD_TEMP_MOD_FILE;
LABEL SKIP;
begin
TEMPFILE:= '\APAD\' + TEMPFIL + '.COM';
ASSIGN(TEMPVAR,TEMPFILE);
{$I-}
RESET(TEMPVAR);
{$I+}
IF IORESULT <> 0 THEN begin
GOTOXY(1,3); WRITELN('FILE DOES NOT EXIST');
DOOVER:= 2; GOTOXY(1,1);
GOTO SKIP;
end;
CLOSE(TEMPVAR);
ASSIGN(TEMPVAR,TEMPFILE);
RESET(TEMPVAR);
FOR OS:= 0 TO 15 DO
READ(TEMPVAR,SC);
FOR Y:= 1 TO 23 DO
begin
FOR X:= 1 TO 80 DO
begin
READ(TEMPVAR,SC); IF SC = '$' THEN GOTO SKIP;
LOC; WRITE(SC);
PAGE1[Y,X]:= SC;
end;
end;
WRITELN;
CLOSE(TEMPVAR);
SKIP:
end;

Procedure N; (* Patterned after Article in Sky & Telescope *)
begin (* July, 1985 from the Basic Program Converted from Fortran- *)
I:= I + 1;
end; (* Basic to Turbo Pascal 4.0 Conversion by Joe Fischer *)

Procedure Assig_Dates; { BUILD ARRAY OF 2-BYTE STRINGS }
begin
I:= 1;
D[I]:= '1 '; n; D[I]:= '2 '; n; D[I]:= '3 '; N; D[I]:= '4 '; N;
D[I]:= '5 '; n; D[I]:= '6 '; n; D[I]:= '7 '; N; D[I]:= '8 '; N;
D[I]:= '9 '; n; D[I]:= '10'; n; D[I]:= '11'; N; D[I]:= '12'; N;
D[I]:= '13'; n; D[I]:= '14'; n; D[I]:= '15'; N; D[I]:= '16'; N;
D[I]:= '17'; n; D[I]:= '18'; n; D[I]:= '19'; N; D[I]:= '20'; N;
D[I]:= '21'; n; D[I]:= '22'; n; D[I]:= '23'; N; D[I]:= '24'; N;
D[I]:= '25'; n; D[I]:= '26'; n; D[I]:= '27'; N; D[I]:= '28'; N;
D[I]:= '29'; n; D[I]:= '30'; n; D[I]:= '31';
end;

Procedure Find_Num_Of_Days_In_Month;
begin
if month = 1 then begin days := 31E+00; monthname:= 'January'; end;
if month = 2 then begin days := 28E+00; monthname:= 'February'; end;
if month = 3 then begin days := 31E+00; monthname:= 'March'; end;
if month = 4 then begin days := 30E+00; monthname:= 'April'; end;
if month = 5 then begin days := 31E+00; monthname:= 'May'; end;
if month = 6 then begin days := 30E+00; monthname:= 'June'; end;
if month = 7 then begin days := 31E+00; monthname:= 'July'; end;
if month = 8 then begin days := 31E+00; monthname:= 'August'; end;
if month = 9 then begin days := 30E+00; monthname:= 'September'; end;
if month = 10 then begin days := 31E+00; monthname:= 'October'; end;
if month = 11 then begin days := 30E+00; monthname:= 'November'; end;
if month = 12 then begin days := 31E+00; monthname:= 'December'; end;
end;

Procedure MONTH_TO_NO;
begin
IF COPY(FILENAME,1,3) = 'JAN' THEN MONTH:= 1;
IF COPY(FILENAME,1,3) = 'FEB' THEN MONTH:= 2;
IF COPY(FILENAME,1,3) = 'MAR' THEN MONTH:= 3;
IF COPY(FILENAME,1,3) = 'APR' THEN MONTH:= 4;
IF COPY(FILENAME,1,3) = 'MAY' THEN MONTH:= 5;
IF COPY(FILENAME,1,3) = 'JUN' THEN MONTH:= 6;
IF COPY(FILENAME,1,3) = 'JUL' THEN MONTH:= 7;
IF COPY(FILENAME,1,3) = 'AUG' THEN MONTH:= 8;
IF COPY(FILENAME,1,3) = 'SEP' THEN MONTH:= 9;
IF COPY(FILENAME,1,3) = 'OCT' THEN MONTH:= 10;
IF COPY(FILENAME,1,3) = 'NOV' THEN MONTH:= 11;
IF COPY(FILENAME,1,3) = 'DEC' THEN MONTH:= 12;
IF COPY(FILENAME,1,3) = 'jan' THEN MONTH:= 1;
IF COPY(FILENAME,1,3) = 'feb' THEN MONTH:= 2;
IF COPY(FILENAME,1,3) = 'mar' THEN MONTH:= 3;
IF COPY(FILENAME,1,3) = 'apr' THEN MONTH:= 4;
IF COPY(FILENAME,1,3) = 'may' THEN MONTH:= 5;
IF COPY(FILENAME,1,3) = 'jun' THEN MONTH:= 6;
IF COPY(FILENAME,1,3) = 'jul' THEN MONTH:= 7;
IF COPY(FILENAME,1,3) = 'aug' THEN MONTH:= 8;
IF COPY(FILENAME,1,3) = 'sep' THEN MONTH:= 9;
IF COPY(FILENAME,1,3) = 'oct' THEN MONTH:= 10;
IF COPY(FILENAME,1,3) = 'nov' THEN MONTH:= 11;
IF COPY(FILENAME,1,3) = 'dec' THEN MONTH:= 12;
IF COPY(FILENAME,1,3) = 'Jan' THEN MONTH:= 1;
IF COPY(FILENAME,1,3) = 'Feb' THEN MONTH:= 2;
IF COPY(FILENAME,1,3) = 'Mar' THEN MONTH:= 3;
IF COPY(FILENAME,1,3) = 'Apr' THEN MONTH:= 4;
IF COPY(FILENAME,1,3) = 'May' THEN MONTH:= 5;
IF COPY(FILENAME,1,3) = 'Jun' THEN MONTH:= 6;
IF COPY(FILENAME,1,3) = 'Jul' THEN MONTH:= 7;
IF COPY(FILENAME,1,3) = 'Aug' THEN MONTH:= 8;
IF COPY(FILENAME,1,3) = 'Sep' THEN MONTH:= 9;
IF COPY(FILENAME,1,3) = 'Oct' THEN MONTH:= 10;
IF COPY(FILENAME,1,3) = 'Nov' THEN MONTH:= 11;
IF COPY(FILENAME,1,3) = 'Dec' THEN MONTH:= 12;
end;

Procedure CAL;
LABEL BADC,LEAC,BYEC;
VAR S1,S2,S3,S4,S5 :STRING[80];
begin
gotoxy(1,1); (* write('Enter number of Month : '); *) MONTH_TO_NO;
(* readln(month); *) Find_Num_Of_Days_In_Month; gotoxy(1,1);
BADC:
WRITE(' ');
GOTOXY(1,1);
WRITE('ENTER YEAR : '); READLN(YEAR); WRITELN;
IF YEAR = 0 THEN begin
WRITELN('Please Enter four digits for Year');
GOTO BADC;
end;
if YEAR < 100 then YEAR:= YEAR + 1900;
YR:= YEAR; M:= MONTH; (* change yyyy to 2000 after 1999 *)
t1:= trunc((m+9)/12);
t2:= trunc(7*(yr+t1))/4;
t3:= trunc(275*m/9);
t5:= 367E+00 * YR;
t7:= (t5 - t2) + t3 + 1.721031E+06;
T:= t7;
MOLEN:=0; IF M <= 2 THEN MOLEN:= - 1;
t:= t - trunc(3 * (trunc((YR+MOLEN)/100)+1)/4);
MOLEN:= TRUNC(days); IF M <> 2 THEN GOTO LEAC;
W:= trunc(YR -100 * trunc(YR/100)); CxX:= trunc(YR - 4 * trunc(YR/ 4));
Z:= trunc(YR - 400 * trunc(YR/ 400));
IF CxX <> 0 THEN GOTO LEAC;
IF W = 0 THEN IF Z <> 0 THEN GOTO LEAC;
MOLEN:= 29;
LEAC:
Q1:= T/7E+00;
Q2:= INT(Q1);
Q3:= (Q2 * 7);
Q4:= (T - Q3); IF Q4-INT(Q4)<0.5E+00 THEN Q4:= Q4+ 1;
Q5:= ROUND(Q4); {these two if-then's added to compensate for rounding}
CX:= TRUNC(Q5); IF CX = 7 THEN CX:= 0; GOTOXY(1,1);
S1:= 'SUNDAY MONDAY TUESDAY WEDNESDAY THURSDAY FRIDAY SATURDAY ';
write(filvar,S1); FM:= 96 + 74;
WRITE(filvar,' ');
For I:= 1 to 42 do
begin
CA[I]:= ' ';
end;
Assig_Dates;
For I:= 1 to MOLEN do
begin
CA[I+CX]:= D[I];
end;
For II:= 1 to 5 do
begin
J:= II*7;
Write(filvar,CA[J-6],' ',CA[J-5],' ',CA[J-4],' ',
CA[J-3],' ',CA[J-2],' ',CA[J-1],' ',CA[J],' ');
IF II < 6 THEN begin
WRITE(filvar,' ');
WRITE(filvar,' ');
WRITE(filvar,' ');
end;
end;
Write(filvar,CA[42-6],' ',CA[42-5],' ',CA[42-4]);
WRITE(filvar,' APPOINTMENTS FOR ',MONTHname,' ',YEAR,' ');
{ Write(FilVar,' ');
Write(FilVar,' ');
}
BYEC:
end;

Procedure NEW_FILE;
VAR KN,l9 :INTEGER;
begin
ASSIGN(FILVAR,FILENAM);
REWRITE(FILVAR);
CF1:= CHR($B4); CF2:= CHR($09); CF3:= CHR($BA); CF4:= CHR($10);
CF5:= CHR($01); CF6:= CHR($CD); CF7:= CHR($21); CF8:= CHR($20);
X:= 7; Y:= 2; N1:= 5; N2:= 9; H32:= CHR($32); H4A:= CHR($4A);
WRITE(FILVAR,CF1,CF2,CF3,CF4,CF5,CF6,CF7,CF6,CF8);
NOP:= CHR($90);
WRITE(FILVAR,NOP,NOP,NOP,NOP,NOP,NOP,NOP);
CAL;
WRITE(FILVAR,H24,H1A);
CLOSE(FILVAR);
end;

LABEL MIDL;

begin (**************** M A I N ********************)
FOR Y:= 1 TO 23 DO
begin
FOR X:= 1 TO 80 DO
begin
PAGE1[Y,X]:= CHR(32);
end;
end;
CLRSCR; TextMode(BW80); FILENAME:= ''; MONTH:= 0;
GOTOXY(1,1); H1A:= CHR($1A); H01:= CHR($01);
HB4:= CHR($B4); H09:= CHR($09); HCD:= CHR($CD); H21:= CHR($21);
H20:= CHR($20); MOVAH:= CHR($B4); MOVDX:= CHR($BA);
H22:= CHR($22); H24:= CHR($24); H1B:= CHR($1B); H5B:= CHR($5B);
H32:= CHR($32); H4A:= CHR($4A); DOOVER:= 0;
MIDL:
GET_MOD_NAME_TO_WRITE;
IF DOOVER = 2 THEN begin ClrScr; GOTO MIDL; end;
IF DOOVER = 1 THEN LOAD_TEMP_MOD_FILE;
IF DOOVER = 2 THEN begin NEW_FILE; clrscr; LOAD_TEMP_MOD_FILE; end;
ENTER_DATA;
WRITE_FILE;

WRITE(FILVAR,H24,H1A);
CLOSE(FILVAR);
CLRSCR;
end.

Other Threads

1. Appointments Table Checking For Conflicting Appointments

2. Random numbers /Time DOS-Interrupt using TP6 on NT4

3. TP6.0 and the (Master) DOS-Environment

4. *Need* Terminal-program for DOS (TP6 or TP7)

5. Tp6: OOPS - DOS shell

6. Tp6: OOPS - DOS shell

7. Q: Running TP6 for DOS win Win95

8. Comms Source for TP6

9. Poor, poor, pitifull me...

10. Source code of examples in a book.