home *** CD-ROM | disk | FTP | other *** search
- (* ------------------------------------------------------ *)
- (* TP4DATUM.BIB *)
- (* - Syntax und Plausibilität der Datums-Eingabe prüfen *)
- (* - Datum als String und numerisch (fuer Sortierung) *)
- (* - Berechnung des Wochentags im Zeitraum 1700 bis 2099 *)
- (* - Übernahme des Systemdatums bei Leereingabe *)
- (* Im Hauptprogramm müssen deklariert sein: *)
- (* datum : string [10]; *)
- (* tagname : string [3]; *)
- (* datumnr : longint; *)
- (* *)
- (* (c) 1989 J.Reents & TOLBOX *)
- (* ------------------------------------------------------ *)
- PROCEDURE machtagname (tnr:LONGINT);
- BEGIN
- CASE tnr OF
- 0 : tagname := 'SO.';
- 1 : tagname := 'MO.';
- 2 : tagname := 'DI.';
- 3 : tagname := 'MI.';
- 4 : tagname := 'DO.';
- 5 : tagname := 'FR.';
- 6 : tagname := 'SA.';
- END;
- END; (* machtagname *)
-
- PROCEDURE compwota (t,m,j:LONGINT);
- (* berechnet den Wochentag bei Daten von 1700 bis 2099 *)
- VAR wota, cent : LONGINT;
- BEGIN
- wota := t + (j MOD 100) DIV 12 + (j MOD 100) MOD 12
- + ((j MOD 100) MOD 12) DIV 4;
- CASE m OF
- 4,7 : wota := wota-1;
- 5 : wota := wota+1;
- 8 : wota := wota+2;
- 2,3,11 : wota := wota+3;
- 6 : wota := wota+4;
- 9,12 : wota := wota+5;
- END;
- IF (j MOD 4 = 0) AND (m IN [1,2]) THEN wota := wota-1;
- (* Schaltjahr-Abzug im Jan. u. Febr. *)
- cent := j DIV 100;
- CASE cent OF
- 17 : wota := wota+4;
- 18 : wota := wota+2;
- 20 : wota := wota-1;
- END;
- IF wota >= 7 THEN wota := wota MOD 7;
- machtagname (wota);
- END; (* compwota *)
-
- PROCEDURE compdatum (t, m, j : LONGINT);
- BEGIN
- datumnr := t + 100 * m + 10000 * j;
- datum := Copy(datum,1,2) + '.' + Copy(datum,4,2) +
- '.' + Copy(datum,7,4);
- compwota (t,m,j);
- END; (* compdatum *)
-
- FUNCTION datumok (t,m,j:LONGINT) : BOOLEAN;
- (* prueft Plausibilitaet des Datums *)
- BEGIN
- datumok := TRUE;
- CASE m OF
- 1,3,5,7,8,10,12 : IF t > 31 THEN datumok := FALSE;
- 4,6,9,11 : IF t > 30 THEN datumok := FALSE;
- 2 : IF (t > 29) OR ((t = 29)
- AND (j MOD 4 <> 0))
- THEN datumok := FALSE;
- ELSE datumok := FALSE;
- END;
- IF (j < 1700) OR (j > 2099) THEN datumok := FALSE;
- END; (* datumok *)
-
- FUNCTION dosdatum : STRING;
- (* holt Systemdatum, wenn Eingabe = Return *)
- VAR j,m,t,wota : WORD;
- tstr,mstr : STRING [2];
- jstr : STRING [4];
- BEGIN
- GetDate (j,m,t,wota);
- Str(t,tstr); Str(m,mstr); Str(j,jstr);
- dosdatum := tstr + '.' + mstr + '.' + jstr;
- END; (* dosdatum *)
-
-
- FUNCTION inputok (VAR t,m,j:LONGINT) : BOOLEAN;
- (* prueft die Syntax der Eingabe *)
- VAR fehler : INTEGER;
- BEGIN
- inputok := FALSE;
- IF datum = '' THEN datum := dosdatum
- ELSE IF (Length(datum) < 6)
- OR (Length(datum) > 10) THEN Exit;
- IF datum[2] IN [#45..#47] THEN Insert ('0',datum,1);
- IF datum[5] IN [#45..#47] THEN Insert ('0',datum,4);
- IF Length(datum) = 8 THEN Insert ('19',datum,7)
- ELSE IF Length(datum) <> 10 THEN Exit;
- Val (Copy(datum,1,2),t,fehler); IF fehler <> 0 THEN Exit;
- Val (Copy(datum,4,2),m,fehler); IF fehler <> 0 THEN Exit;
- Val (Copy(datum,7,4),j,fehler); IF fehler <> 0 THEN Exit;
- inputok := TRUE;
- END; (* inputok *)
-
-
- PROCEDURE datumlesen;
- VAR x,y : BYTE;
- t,m,j : LONGINT;
- BEGIN
- x := WhereX; y := WhereY;
- REPEAT
- GotoXY (x,y); ReadLn (datum);
- UNTIL inputok (t,m,j) AND datumok (t,m,j);
- compdatum (t,m,j); GotoXY (x,y); Write (datum);
- END; (* datumlesen *)
- (* ------------------------------------------------------ *)
- (* Ende von TP4DATUM.BIB *)
-