home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / 1989 / 09 / tricks / tp4datum.bib < prev    next >
Encoding:
Text File  |  1989-06-12  |  3.9 KB  |  119 lines

  1. (* ------------------------------------------------------ *)
  2. (*                    TP4DATUM.BIB                        *)
  3. (*  - Syntax und Plausibilität der Datums-Eingabe prüfen  *)
  4. (*  - Datum als String und numerisch (fuer Sortierung)    *)
  5. (*  - Berechnung des Wochentags im Zeitraum 1700 bis 2099 *)
  6. (*  - Übernahme des Systemdatums bei Leereingabe          *)
  7. (* Im Hauptprogramm müssen deklariert sein:               *)
  8. (*   datum               : string [10];                   *)
  9. (*   tagname             : string [3];                    *)
  10. (*   datumnr             : longint;                       *)
  11. (*                                                        *)
  12. (*            (c) 1989  J.Reents & TOLBOX                 *)
  13. (* ------------------------------------------------------ *)
  14. PROCEDURE machtagname (tnr:LONGINT);
  15. BEGIN
  16.   CASE tnr OF
  17.     0 : tagname := 'SO.';
  18.     1 : tagname := 'MO.';
  19.     2 : tagname := 'DI.';
  20.     3 : tagname := 'MI.';
  21.     4 : tagname := 'DO.';
  22.     5 : tagname := 'FR.';
  23.     6 : tagname := 'SA.';
  24.   END;
  25. END;  (* machtagname *)
  26.  
  27. PROCEDURE compwota (t,m,j:LONGINT);
  28. (* berechnet den Wochentag bei Daten von 1700 bis 2099    *)
  29. VAR  wota, cent : LONGINT;
  30. BEGIN
  31.   wota := t + (j MOD 100) DIV 12 + (j MOD 100) MOD 12
  32.           + ((j MOD 100) MOD 12) DIV 4;
  33.   CASE m OF
  34.     4,7    : wota := wota-1;
  35.     5      : wota := wota+1;
  36.     8      : wota := wota+2;
  37.     2,3,11 : wota := wota+3;
  38.     6      : wota := wota+4;
  39.     9,12   : wota := wota+5;
  40.   END;
  41.   IF (j MOD 4 = 0) AND (m IN [1,2]) THEN wota := wota-1;
  42.                      (* Schaltjahr-Abzug im Jan. u. Febr. *)
  43.   cent := j DIV 100;
  44.   CASE cent OF
  45.     17 : wota := wota+4;
  46.     18 : wota := wota+2;
  47.     20 : wota := wota-1;
  48.   END;
  49.   IF wota >= 7 THEN wota := wota MOD 7;
  50.   machtagname (wota);
  51. END;  (* compwota *)
  52.  
  53. PROCEDURE compdatum (t, m, j : LONGINT);
  54. BEGIN
  55.   datumnr := t + 100 * m + 10000 * j;
  56.   datum := Copy(datum,1,2) + '.' + Copy(datum,4,2) +
  57.            '.' + Copy(datum,7,4);
  58.   compwota (t,m,j);
  59. END;  (* compdatum *)
  60.  
  61. FUNCTION datumok (t,m,j:LONGINT) : BOOLEAN;
  62. (* prueft Plausibilitaet des Datums  *)
  63. BEGIN
  64.   datumok := TRUE;
  65.   CASE m OF
  66.     1,3,5,7,8,10,12 : IF t > 31 THEN datumok := FALSE;
  67.     4,6,9,11        : IF t > 30 THEN datumok := FALSE;
  68.     2               : IF (t > 29) OR ((t = 29)
  69.                         AND (j MOD 4 <> 0))
  70.                         THEN datumok := FALSE;
  71.     ELSE            datumok := FALSE;
  72.   END;
  73.   IF (j < 1700) OR (j > 2099) THEN datumok := FALSE;
  74. END;  (* datumok *)
  75.  
  76. FUNCTION dosdatum : STRING;
  77.                (* holt Systemdatum, wenn Eingabe = Return *)
  78. VAR  j,m,t,wota : WORD;
  79.      tstr,mstr  : STRING [2];
  80.      jstr       : STRING [4];
  81. BEGIN
  82.   GetDate (j,m,t,wota);
  83.   Str(t,tstr); Str(m,mstr); Str(j,jstr);
  84.   dosdatum := tstr + '.' + mstr + '.' + jstr;
  85. END;  (* dosdatum *)
  86.  
  87.  
  88. FUNCTION inputok (VAR t,m,j:LONGINT) : BOOLEAN;
  89. (* prueft die Syntax der Eingabe *)
  90. VAR   fehler : INTEGER;
  91. BEGIN
  92.   inputok := FALSE;
  93.   IF datum = '' THEN datum := dosdatum
  94.                 ELSE IF (Length(datum) < 6)
  95.                      OR (Length(datum) > 10) THEN Exit;
  96.   IF datum[2] IN [#45..#47] THEN Insert ('0',datum,1);
  97.   IF datum[5] IN [#45..#47] THEN Insert ('0',datum,4);
  98.   IF Length(datum) = 8 THEN Insert ('19',datum,7)
  99.                       ELSE IF Length(datum) <> 10 THEN Exit;
  100.   Val (Copy(datum,1,2),t,fehler); IF fehler <> 0 THEN Exit;
  101.   Val (Copy(datum,4,2),m,fehler); IF fehler <> 0 THEN Exit;
  102.   Val (Copy(datum,7,4),j,fehler); IF fehler <> 0 THEN Exit;
  103.   inputok := TRUE;
  104. END;  (* inputok *)
  105.  
  106.  
  107. PROCEDURE datumlesen;
  108. VAR   x,y        : BYTE;
  109.       t,m,j      : LONGINT;
  110. BEGIN
  111.   x := WhereX; y := WhereY;
  112.   REPEAT
  113.     GotoXY (x,y); ReadLn (datum);
  114.   UNTIL inputok (t,m,j) AND datumok (t,m,j);
  115.   compdatum (t,m,j); GotoXY (x,y); Write (datum);
  116. END;  (* datumlesen *)
  117. (* ------------------------------------------------------ *)
  118. (*                Ende von TP4DATUM.BIB                   *)
  119.