home *** CD-ROM | disk | FTP | other *** search
/ Media Share 9 / MEDIASHARE_09.ISO / progmisc / tttsrc51.zip / MISCTTT5.PAS < prev    next >
Pascal/Delphi Source File  |  1993-05-14  |  21KB  |  792 lines
  1. {--------------------------------------------------------------------------}
  2. {                         TechnoJock's Turbo Toolkit                       }
  3. {                                                                          }
  4. {                              Version   5.10                              }
  5. {                                                                          }
  6. {                                                                          }
  7. {               Copyright 1986-1993 TechnoJock Software, Inc.              }
  8. {                           All Rights Reserved                            }
  9. {                          Restricted by License                           }
  10. {--------------------------------------------------------------------------}
  11.  
  12.                      {--------------------------------}                                       
  13.                      {       Unit:  MiscTTT5          }
  14.                      {--------------------------------}
  15.  
  16. {Change history:  }
  17.  
  18.  
  19. {$S-,R-,V-}       
  20. {$IFNDEF DEBUG}
  21. {$D-}
  22. {$ENDIF}
  23.  
  24. Unit MiscTTT5;
  25. {Change History : April 1, 1989    Modified Printer Status and added global
  26.                                    LPTport 
  27.                            5.01a   Removed references to VER50 and added
  28.                                    DEBUG compiler directive                                
  29.                   3/24/91  5.02a   Check for single digits in dates
  30.                   7/23/91  5.02b   Corrected Date formatting
  31.                   11/4/91  5.02c   Corrected File_Size & Time
  32.                  01/04/93  5.10    DPMI compatible version
  33.                  05/14/93  5.10a   Closed source file when CopyFile failed
  34. }
  35. Interface
  36.  
  37. Uses CRT, DOS, FastTTT5, Strnttt5;
  38.  
  39. TYPE
  40.    Dates = word;   {change to longint for greater date ranges}
  41.  
  42. CONST
  43.    MMDDYY   = 1;   {Date formats}
  44.    MMDDYYYY = 2;
  45.    MMYY     = 3;
  46.    MMYYYY   = 4;
  47.    DDMMYY   = 5;
  48.    DDMMYYYY = 6;
  49.  
  50. VAR
  51.    LPTport,     {0=lpt1, 1=lpt2, 2=lpt3}
  52.    ClockX,
  53.    ClockY,
  54.    ClockF,
  55.    ClockB : byte;
  56.  
  57. Function  Exist(Filename:string):boolean;
  58. Function  CopyFile(SourceFile, TargetFile:string): byte;
  59. Function  File_Size(Filename:string): longint;
  60. {$IFNDEF VER40}
  61. Function  File_Drive(Full:string): string;
  62. Function  File_Directory(Full:string): string;
  63. Function  File_Name(Full:string): string;
  64. Function  File_Ext(Full:string): String;
  65. {$ENDIF}
  66. Function  Time: string;
  67. Procedure Clock;
  68. Function  Date: String;
  69. Procedure PrintScreen;
  70. Procedure Beep;
  71. function  Printer_Status:byte;
  72. Function  Alternate_Printer_Status:byte;
  73. Function  Printer_ready:boolean;
  74. Procedure FlushKeyBuffer;
  75. Procedure Reset_Printer;
  76. Function  DMY_to_String(D,M,Y:word;format:byte): string;
  77. Function  Date_To_Julian(InDate:string;format:byte): dates;
  78. Function  Julian_to_Date(J:dates;format:byte):string;
  79. Function  Today_in_Julian: dates;
  80. Function  Date_Within_Range(Min,Max,Test:dates):boolean;
  81. Function  Valid_Date(Indate:string;format:byte): boolean;
  82. Function  Future_Date(InDate:string;format:byte;Days:word): string;
  83. Function  Unformatted_date(InDate:string): string;
  84.  
  85. Implementation
  86.  
  87. Const
  88.     LastYearNextCentuary = 78;
  89.  
  90. Function Exist(Filename:string):boolean;
  91. {returns true if file exists}
  92. var Inf: SearchRec;
  93. begin
  94.     FindFirst(Filename,AnyFile,Inf);
  95.     Exist := (DOSError = 0);
  96. end;  {Func Exist}
  97.  
  98. Function CopyFile(SourceFile, TargetFile:string): byte;
  99. {return codes:  0 successful
  100.                 1 source and target the same
  101.                 2 cannot open source
  102.                 3 unable to create target
  103.                 4 error during copy
  104. }
  105. var
  106.   Source,
  107.   Target : file;
  108.   BRead,
  109.   Bwrite : word;
  110.   FileBuf  : array[1..2048] of char;
  111. begin
  112.     If SourceFile = TargetFile then
  113.     begin
  114.         CopyFile := 1;
  115.         exit;
  116.     end;
  117.     Assign(Source,SourceFile);
  118.     {$I-}
  119.     Reset(Source,1);
  120.     {$I+}
  121.     If IOResult <> 0 then
  122.     begin
  123.         CopyFile := 2;
  124.         exit;
  125.     end;
  126.     Assign(Target,TargetFile);
  127.     {$I-}
  128.     Rewrite(Target,1);
  129.     {$I+}
  130.     If IOResult <> 0 then
  131.     begin
  132.         CopyFile := 3;
  133.         close(source); {5.10a}
  134.         exit;
  135.     end;
  136.     Repeat
  137.          BlockRead(Source,FileBuf,SizeOf(FileBuf),BRead);
  138.          BlockWrite(Target,FileBuf,Bread,Bwrite);
  139.     Until (Bread = 0) or (Bread <> BWrite);
  140.     Close(Source);
  141.     Close(Target);
  142.     If Bread <> Bwrite then
  143.        CopyFile := 4
  144.     else
  145.        CopyFile := 0;
  146. end; {of func CopyFile}
  147.  
  148.  Function File_Size(Filename:string): longint;
  149.  {returns  -1   if file not found}
  150.  var
  151.     F : file of byte;
  152.  begin
  153.      if not Exist(Filename) then    {5.02c}
  154.         File_Size := -1
  155.      else
  156.      begin
  157.         Assign(F,Filename);
  158.         {$I-}
  159.         Reset(F);
  160.         {$I+}
  161.         If IOResult <> 0 then {ignore};
  162.         {$I-}
  163.         File_Size := FileSize(F);
  164.         {$I+}
  165.         If IOResult <> 0 then 
  166.            File_Size := -1;
  167.         Close(F);
  168.      end;
  169.  end; {of func File_Size}
  170.  
  171. {$IFNDEF VER40}
  172.  Function File_Split(Part:byte;Full:string): string;
  173.  {used internally}
  174.  var
  175.     D : DirStr;
  176.     N : NameStr;
  177.     E : ExtStr;
  178.  begin
  179.      FSplit(Full,D,N,E);
  180.      Case Part of
  181.      1 : File_Split := D;
  182.      2 : File_Split := N;
  183.      3 : File_Split := E;
  184.      end;
  185.  end; {of func File_Split}
  186.  
  187.  Function File_Drive(Full:string): string;
  188.  {}
  189.  var
  190.    Temp : string;
  191.    P : byte;
  192.  begin
  193.      Temp := File_Split(1,Full);
  194.      P := Pos(':',Temp);
  195.      If P <> 2 then
  196.         File_Drive := ''
  197.      else
  198.         File_Drive := upcase(Temp[1]);
  199.  end; {of func File_Drive}
  200.  
  201.  Function File_Directory(Full:string): string;
  202.  {}
  203.  var
  204.    Temp : string;
  205.    P : byte;
  206.  begin
  207.      Temp := File_Split(1,Full);
  208.      P := Pos(':',Temp);
  209.      If P = 2 then
  210.         Delete(Temp,1,2);                 {remove drive}
  211.      If (Temp[length(Temp)]  ='\') and (temp <> '\') then
  212.         Delete(temp,length(Temp),1);      {remove last backslash}
  213.      File_Directory := Temp;
  214.  end; {of func File_Directory}
  215.  
  216.  Function File_Name(Full:string): string;
  217.  {}
  218.  begin
  219.      File_Name := File_Split(2,Full);
  220.  end; {of func File_Name}
  221.  
  222.  Function File_Ext(Full:string): String;
  223.  {}
  224.  var
  225.    Temp : string;
  226.  begin
  227.      Temp := File_Split(3,Full);
  228.      If (Temp = '') or (Temp = '.') then
  229.         File_Ext := temp
  230.      else
  231.         File_Ext := copy(Temp,2,3);
  232.  end; {of func File_Ext}
  233. {$ENDIF}
  234.  
  235. function time: string;
  236. var
  237.   hour,min,sec:     string[2];
  238.   H,M,S,T : word;
  239. begin
  240.     GetTime(H,M,S,T);
  241.     Str(H,Hour);
  242.     Str(M,Min);
  243.     Str(S,Sec);
  244.     if S < 10 then            {pad a leading zero if sec is < 10 }
  245.       sec := '0'+sec;
  246.     if M < 10 then            {pad a leading zero if min is < 10 }
  247.         min := '0'+min;
  248.     if H > 12 then           { assign an a.m. or p.m. string }
  249.     begin
  250.        str(H - 12,hour);
  251.        IF length(hour) = 1 then 
  252.           Hour := ' '+hour;
  253.        time := hour+':'+min+':'+sec+' p.m.'
  254.     end
  255.     else if H = 0 then   {5.02c}
  256.        time := '24:'+min+':'+sec+' a.m.'
  257.     else
  258.        time := hour+':'+min+':'+sec+' a.m.';
  259.     if H = 12 then
  260.        time := hour+':'+min+':'+sec+' p.m.';
  261. end;
  262.  
  263. {$F+}
  264. Procedure Clock;
  265. {}
  266. begin
  267.     Fastwrite(ClockX,ClockY,attr(ClockF,ClockB),Time);
  268. end; {of proc Clock}
  269. {$F-}
  270.  
  271. function Date: String;
  272. type
  273.   WeekDays = array[0..6]  of string[9];
  274.   Months   = array[1..12] of string[9];
  275. const
  276.     DayNames   : WeekDays  = ('Sunday','Monday','Tuesday','Wednesday',
  277.                               'Thursday','Friday','Saturday');
  278.     MonthNames : Months    = ('January','February','March','April','May',
  279.                               'June','July','August','September',
  280.                               'October','November','December');
  281. var
  282.  Y,
  283.  M,
  284.  D,
  285.  DayOfWeek : word;
  286.  Year   : string;
  287.  Day    : string;
  288. begin
  289.     GetDate(Y,M,D,DayofWeek);
  290.     Str(Y,Year);
  291.     Str(D,Day);
  292.     Date := DayNames[DayOfWeek]+' '+MonthNames[M]+' '+Day+', '+Year;
  293. end;
  294.  
  295. Procedure PrintScreen;
  296. var Regpack : registers;
  297. begin
  298.     intr($05,regpack);
  299. end;
  300.  
  301. procedure Beep;
  302. begin
  303.     sound(800);Delay(150);
  304.     sound(600);Delay(100);
  305.     Nosound;
  306. end;
  307.  
  308. Function Printer_Status:byte;
  309. {Credits: Robert W. Lewis, VA thanks! Special masking employed for non-
  310.           standard printers, e.g. daisy wheels!!! }
  311. var Recpack : registers;
  312. begin
  313.     with recpack do
  314.     begin
  315.         Ah := 2;
  316.         Dx := LPTport;
  317.         intr($17,recpack);
  318.         If (Ah and $B8) = $90 then
  319.            Printer_Status := 0           {all's well}
  320.         else
  321.            If (Ah and $20) = $20 then
  322.               Printer_Status := 1        {no Paper}
  323.         else
  324.            If (Ah and $10) = $00 then
  325.               Printer_Status := 2        {off line}
  326.         else
  327.            If (Ah and $80) = $00 then
  328.               Printer_Status := 3        {busy}
  329.         else
  330.            If (Ah and $08) = $08 then
  331.               Printer_Status := 4;       {undetermined error}
  332.     end;
  333. end;
  334.  
  335. Function Alternate_Printer_Status:byte;
  336. var Recpack : registers;
  337. begin
  338.     with recpack do
  339.     begin
  340.         Ah := 2;
  341.         Dx := LPTport;
  342.         intr($17,recpack);
  343.         If (Ah and $20) = $20 then
  344.               Alternate_Printer_Status := 1        {no Paper}
  345.         else
  346.            If (Ah and $10) = $00 then
  347.               Alternate_Printer_Status := 2        {off line}
  348.         else
  349.            If (Ah and $80) = $00 then
  350.               Alternate_Printer_Status := 3        {busy}
  351.         else
  352.            If (Ah and $08) = $08 then
  353.               Alternate_Printer_Status := 4        {undetermined error}
  354.         else
  355.             Alternate_Printer_Status := 0           {all's well}
  356.     end;
  357. end;
  358.  
  359.  
  360. function printer_ready :boolean;
  361. begin
  362.     Printer_ready := (Printer_Status = 0);
  363. end;
  364.  
  365. Procedure FlushKeyBuffer;
  366. var Recpack : registers;
  367. begin
  368.     with recpack do
  369.     begin
  370.         Ax := ($0c shl 8) or 6;
  371.         Dx := $00ff;
  372.     end;
  373.     Intr($21,recpack);
  374. end;
  375.  
  376. procedure Reset_Printer; {1.1}
  377. var
  378.   address: ^integer;
  379.   portno,delay : integer;
  380. begin
  381. {$IFDEF DPMI}
  382.    address := ptr(seg0040,$0008);
  383. {$ELSE}
  384.    address := ptr($0040,$0008);
  385. {$ENDIF}
  386.    portno := address^ + 2;
  387.    port[portno] := 232;
  388.    for delay := 1 to 2000 do {nothing};
  389.    port[portno] := 236;
  390. end; {ResetPrinter}
  391.  
  392. {++++++++++++++++++++++++++++++++++}
  393. {                                  }
  394. {    D A T E    R O U T I N E S    }
  395. {                                  }
  396. {++++++++++++++++++++++++++++++++++}
  397.  
  398. (*
  399.  Note that the Julian date logic applied in these routines is that day 1 is
  400.  January 1, 1900. All subsequent dates are represented by the number of
  401.  days elapsed since day 1. The INTERFACE section includes a declaration of
  402.  type DATES - this is set equal to type word, but it could be changed to
  403.  type longint to provide a much greater date range. 
  404.  
  405.  Throughout these procedures and functions a date "format" must be passed. The
  406.  format codes are:
  407.  
  408.                   1  MM/DD/YY
  409.                   2  MM/DD/YYYY
  410.                   3  MM/YY
  411.                   4  MM/YYYY
  412.                   5  DD/MM/YY {International format}
  413.                   6  DD/MM/YYYY   {   "    }
  414.  
  415.  When passing dates in string form the "separators" are not significant. For
  416.  example, the following strings are all treated alike:
  417.  
  418.                      120188
  419.                      12/01/88
  420.                      12-01-88
  421.                      12-01/88
  422.                      12----01----88
  423.  Only the numerical digits are significant, the alphas are ignored.
  424.  
  425. *)
  426.   function JustNumbers(DStr:string): boolean;       {5.02b}
  427.   {}
  428.   var P:byte;
  429.   begin
  430.      P := 0;
  431.      repeat
  432.        inc(P);
  433.      until (not (DStr[P] in ['0'..'9'])) or (P > length(DStr));
  434.      JustNumbers := (P > length(DStr));
  435.   end; {JustNumbers}
  436.  
  437.   function PadDateStr(DStr:string;Format:byte):string;
  438.   {}
  439.   const
  440.     Sep:string[1] = '\';
  441.   var
  442.     Part1,Part2,Part3: string[8];
  443.     P: byte;
  444.  
  445.             procedure PadOut(var S:string; width:byte);
  446.             begin
  447.                S := padright(S,width,'0');
  448.             end;
  449.  
  450.   begin
  451.      P := 0;
  452.      repeat
  453.        inc(P);
  454.      until (not (DStr[P] in ['0'..'9'])) or (P > length(DStr));
  455.      Part1 := copy (DStr,1,pred(P));
  456.      delete(DStr,1,P);
  457.      P:= 0;
  458.      repeat
  459.         inc(P);
  460.      until (not (DStr[P] in ['0'..'9'])) or (P > length(DStr));
  461.      Part2 := copy(DStr,1,pred(P));
  462.      Part3 := copy(DStr,succ(P),4);
  463.      case Format of
  464.       MMDDYY,DDMMYY:begin
  465.           PadOut(Part1,2);
  466.           PadOut(Part2,2);
  467.           PadOut(Part3,2);
  468.           DStr := Part1+Sep+Part2+Sep+Part3;
  469.       end;
  470.       MMDDYYYY,DDMMYYYY:begin
  471.           PadOut(Part1,2);
  472.           PadOut(Part2,2);
  473.           PadOut(Part3,4);
  474.           DStr := Part1+Sep+Part2+Sep+Part3;
  475.       end;
  476.       MMYY:begin
  477.           PadOut(Part1,2);
  478.           PadOut(Part2,2);
  479.           DStr := Part1+Sep+Part2;
  480.       end;
  481.       MMYYYY:begin
  482.           PadOut(Part1,2);
  483.           PadOut(Part2,4);
  484.           DStr := Part1+Sep+Part2;
  485.       end;
  486.      end; {case}
  487.      PadDateStr := DStr;
  488.   end; {PadDateStr}
  489.  
  490.   Function Nth_Number(InStr:string;Nth:byte) : char;
  491.   {Returns the nth number in an alphanumeric string}
  492.   var
  493.      Counter : byte;
  494.      B, Len : byte;
  495.   begin
  496.       Counter := 0;
  497.       B := 0;
  498.       Len := Length(InStr);
  499.       Repeat
  500.            Inc(B);
  501.            If InStr[B] in ['0'..'9'] then
  502.               Inc(Counter);
  503.       Until (Counter = Nth) or (B >= Len);
  504.       If (Counter >= Len) and ( (InStr[Len] in ['0'..'9']) = false) then
  505.          Nth_Number := #0
  506.       else
  507.          Nth_Number := InStr[B];
  508.   end; {of func Nth_Number}
  509.  
  510.  Function Day(DStr:string;Format:byte): word;
  511.  {INTERNAL}
  512.  var
  513.     DayStr: string;
  514.  begin
  515.      if not JustNumbers(DStr) then                       {5.02b}
  516.         DStr := PadDateStr(DStr,Format);
  517.      Case Format of
  518.      MMDDYY,
  519.      MMDDYYYY :  DayStr := Nth_Number(DStr,3)+Nth_Number(DStr,4);
  520.      DDMMYY,
  521.      DDMMYYYY :  DayStr := Nth_Number(DStr,1)+Nth_Number(DStr,2);
  522.      else     DayStr := '01';
  523.      end;
  524.      Day := Str_To_Int(DayStr);
  525.  end; {of func Day}
  526.  
  527.  Function Month(DStr:string;Format:byte): word;
  528.  {INTERNAL}
  529.  var
  530.     MonStr: string;
  531.  begin
  532.      if not JustNumbers(DStr) then                      {5.02b}
  533.         DStr := PadDateStr(DStr,Format);
  534.      Case Format of
  535.      MMDDYY,
  536.      MMDDYYYY,
  537.      MMYY,
  538.      MMYYYY    :  MonStr := Nth_Number(DStr,1)+Nth_Number(DStr,2);
  539.      DDMMYY,
  540.      DDMMYYYY  :  MonStr := Nth_Number(DStr,3)+Nth_Number(DStr,4);
  541.      end;
  542.      Month := Str_To_Int(MonStr);
  543.  end; {of func Month}
  544.  
  545.  Function Year(DStr:string;Format:byte): word;
  546.  {INTERNAL}
  547.  var
  548.     YrStr   : string;
  549.     TmpYr   : word;
  550.  begin
  551.      if not JustNumbers(DStr) then                     {5.02b}
  552.         DStr := PadDateStr(DStr,Format);
  553.      Case Format of
  554.      MMDDYY,
  555.      DDMMYY   :  YrStr := Nth_Number(DStr,5)+Nth_Number(DStr,6);
  556.      MMDDYYYY,
  557.      DDMMYYYY :  YrStr := Nth_Number(DStr,5)+Nth_Number(DStr,6)+
  558.                      Nth_Number(DStr,7)+Nth_Number(DStr,8);
  559.      MMYY     :  YrStr := Nth_Number(DStr,3)+Nth_Number(DStr,4);
  560.      MMYYYY   :  YrStr := Nth_Number(DStr,3)+Nth_Number(DStr,4)+
  561.                      Nth_Number(DStr,5)+Nth_Number(DStr,6);
  562.      end;
  563.      TmpYr := Str_To_Int(YrStr);
  564.      If TmpYr < LastYearNextCentuary then
  565.         TmpYr := 2000 + TmpYr
  566.      else
  567.         If Tmpyr < 1000 then
  568.            TmpYr := 1900 + TmpYr;
  569.      Year := TmpYr;
  570.  end; {of func Year}
  571.  
  572.  Function DMY_to_String(D,M,Y:word;format:byte): string;
  573.  {INTERNAL}
  574.  const
  575.      PadChar = '/';
  576.  var
  577.     DD,MM,YY : string[4];
  578.  begin
  579.      DD := Int_to_Str(D);
  580.      If D < 10 then
  581.         DD := '0'+DD;
  582.      MM := Int_to_Str(M);
  583.      If M < 10 then
  584.         MM := '0'+MM;
  585.      If Format in [MMDDYY,MMYY,DDMMYY] then
  586.      begin
  587.          If Y > 99 then
  588.             If Y > 2000 then
  589.                Y := Y - 2000
  590.             else
  591.                If Y > 1900 then
  592.                   Y := Y - 1900
  593.                else
  594.                   Y := Y Mod 100;
  595.      end
  596.      else
  597.      begin
  598.          If Y < 1900 then
  599.             If Y < LastYearNextCentuary then
  600.                Y := Y + 2000
  601.             else
  602.                Y := Y + 1900;
  603.      end;
  604.      YY := Int_to_Str(Y);
  605.      If Y < 10 then
  606.         YY := '0'+YY;
  607.      Case Format of
  608.      MMDDYY,
  609.      MMDDYYYY: DMY_to_String := MM+PadChar+DD+Padchar+YY;
  610.      MMYY,
  611.      MMYYYY  : DMY_to_String := MM+Padchar+YY;
  612.      DDMMYY,
  613.      DDMMYYYY: DMY_to_String := DD+PadChar+MM+Padchar+YY;
  614.      end; {case}
  615.  end; {of func DMY_to_String}
  616.  
  617.  Function Date_To_Julian(InDate:string;format:byte): dates;
  618.  {Does not check the date is valid. Passed a date string and
  619.   returns a julian date}
  620.  var
  621.     D,M,Y :  word;
  622.     Temp : dates;
  623.  begin
  624.      D := Day(Indate,format);
  625.      M := Month(Indate,format);
  626.      Y := Year(Indate,format);
  627.      If  (Y=1900)
  628.      and (M <= 2) then
  629.      begin
  630.          If M = 1 then
  631.             Temp := pred(D)
  632.          else
  633.             Temp := D+30;
  634.      end
  635.      else
  636.      begin
  637.          If M > 2 then
  638.             M := M - 3
  639.          else
  640.          begin
  641.              M := M + 9;
  642.              dec(Y);
  643.          end;
  644.          Y := Y - 1900;
  645.          Temp := (1461*longint(Y) div 4) +
  646.                  (153*M+2) div 5 +
  647.                  D + 58;
  648.      end;
  649.      Date_to_Julian := Temp;
  650.  end; {of func Date_To_Julian}
  651.  
  652.  Function Julian_to_Date(J:dates;format:byte):string;
  653.  {}
  654.  var
  655.     D,M,Y : word;
  656.     Remainder,Factored : longint;
  657.  begin
  658.      If J = 0 then
  659.      begin
  660.          Case Format of
  661.          DDMMYY,MMDDYY :   Julian_to_date := '  /  /  ';
  662.          DDMMYYYY,MMDDYYYY:Julian_to_date := '  /  /    ';
  663.          MMYYYY:           Julian_to_Date := '  /    ';
  664.          else              Julian_to_date := '  /  ';
  665.          end;
  666.          exit;
  667.      end;
  668.      If J <= 58 then
  669.      begin
  670.          Y := 1900;
  671.          If J <= 30 then
  672.          begin
  673.              M := 1;
  674.              D := succ(J);
  675.          end
  676.          else
  677.          begin
  678.              M := 2;
  679.              D := J - 30;
  680.          end;
  681.      end
  682.      else
  683.      begin
  684.          Factored := 4*LongInt(J) - 233;
  685.          Y := Factored div 1461;
  686.          Remainder := (Factored mod 1461 div 4 * 5) + 2;
  687.          M := Remainder div 153;
  688.          D := succ((Remainder mod 153) div 5);
  689.          Y := Y + 1900;
  690.          If M < 10 then
  691.             M := M + 3
  692.          else
  693.          begin
  694.              M := M - 9;
  695.              Inc(Y);
  696.          end;
  697.      end;
  698.      Julian_to_date := DMY_to_String(D,M,Y,format);
  699.  end; {of proc Julian_to_Date}
  700.  
  701.  Function Date_Within_Range(Min,Max,Test:dates):boolean;
  702.  {}
  703.  begin
  704.      Date_Within_Range := ((Test >= Min) and (Test <= Max));
  705.  end; {of func Date_Within_Range}
  706.  
  707.  Function Valid_Date(Indate:string;format:byte): boolean;
  708.  {}
  709.  var
  710.    D,M,Y : word;
  711.    OK : Boolean;
  712.  begin
  713.      OK := true;  {positive thinking!}
  714.      If format in [MMYY,MMYYYY] then
  715.         D := 1
  716.      else
  717.         D := Day(Indate,format);
  718.      M := Month(Indate,format);
  719.      Y := Year(Indate,format);
  720.      If (D < 1)
  721.      or (D > 31)
  722.      or (M < 1)
  723.      or (M > 12)
  724.      or ((Y > 99) and (Y < 1900))
  725.      or (Y > 2078)
  726.      then 
  727.         OK := False
  728.      else
  729.         Case M of
  730.         4,6,9,11:         OK :=   (D <= 30);
  731.         2:                OK :=   (D <= 28)
  732.                                or (
  733.                                         (D = 29) 
  734.                                     and (Y <> 1900) 
  735.                                     and (Y <> 0)
  736.                                     and (Y mod 4 = 0)
  737.                                   )
  738.         end; {case}
  739.      Valid_Date := OK;
  740.  end; {of func Valid_Date}
  741.  
  742.  Function Today_in_Julian: dates;
  743.  {}
  744.  var
  745.  Y,
  746.  M,
  747.  D,
  748.  DayOfWeek : word;
  749.  Year   : string;
  750.  Day    : string;
  751.  begin
  752.      GetDate(Y,M,D,DayofWeek);
  753.      Today_in_Julian := Date_to_Julian(DMY_to_String(D,M,Y,1),1);
  754.  end; {of func Today_in_Julian}
  755.  
  756.  Function Future_Date(InDate:string;format:byte;Days:word): string;
  757.  {}
  758.  var J : dates;
  759.  begin
  760.      Future_date := Julian_to_date(Date_to_Julian(InDate,Format)+Days,Format);
  761.  end; {of func Future_Date}
  762.  
  763.  Function Unformatted_date(InDate:string): string;
  764.  {strips all non numeric characters}
  765.  var I : Integer;
  766.  
  767.            Function digit(C:char): boolean;
  768.            {}
  769.            begin
  770.                Digit := C in ['0'..'9'];
  771.            end; {of func digit}
  772.  
  773.  begin
  774.      I := 1;
  775.      Repeat
  776.           If (digit(Indate[I]) = false) and (length(Indate) > 0) then
  777.              Delete(Indate,I,1)
  778.           else
  779.              I := succ(I);
  780.      Until (I > length(Indate)) or (Indate = '');
  781.      Unformatted_Date := Indate;
  782.  end; {of func Unformatted_date}
  783.  
  784.  
  785. begin
  786.     ClockX := 67;
  787.     ClockY := 1;
  788.     ClockF := white;
  789.     ClockB := black;
  790.     LPTport := 0;  {LPT1}
  791. end.
  792.