Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/SHDK_2.ZIP/SHDATPK.PAS

Pascal/Delphi Source File | 1992-04-30 | 15.9 KB | 519 lines

{$I SHDEFINE.INC}

{$I SHUNITSW.INC}

{$D-,L-}
unit ShDatPk;
{
                                ShDatPk

                        A Date Manipulation Unit

                                   by

                              Bill Madison

                   W. G. Madison and Associates, Ltd.
                          13819 Shavano Downs
                            P.O. Box 780956
                       San Antonio, TX 78278-0956
                             [phone]
                             CIS 73240,342

                  Copyright 1991 Madison & Associates
                          All Rights Reserved

        This file may  be used and distributed  only in accord-
        ance with the provisions described on the title page of
                  the accompanying documentation file
                              SKYHAWK.DOC
}

interface

uses
  shUtilPk,
  Dos;

type
  GregType  = record
                Year  : LongInt;
                Month,
                Day   : byte;
                end;
  TimeType  = record
                H,
                M,
                S   : byte;
                end;

const
  DayStr  : array[0..6] of string[9] =
                        ('Sunday', 'Monday', 'Tuesday', 'Wednesday',
                         'Thursday', 'Friday', 'Saturday');

  MonthStr: array[1..12] of string[9] =
                        ('January',   'February', 'March',    'April',
                         'May',       'June',     'July',     'August',
                         'September', 'October',  'November', 'December');

function DoW(Greg : GregType) : byte;
             {computes the day of the week (Sunday = 0; Saturday = 6)
             from the Gregorian date.}

function Greg2ANSI(G : GregType) : string;
{Returns the date as an ANSI date string (YYYYMMDD)}

function Greg2JDate(Greg : GregType) : integer;
             {computes the Julian date from the Gregorian date.}

function Greg2JDN(Greg : GregType) : LongInt;
             {computes the Julian Day-Number from the Gregorian date.}

procedure JDate2Greg(JDate, Year : Integer;
                  var Greg : GregType);
             {computes the Gregorian date from the Julian date.}

function JDN2ANSI(JDN : LongInt) : string;
{Returns the JDN as an ANSI date string (YYYYMMDD)}

procedure JDN2Greg(JDN : LongInt;
                  var Greg : GregType);
             {computes the Gregorian date from the Julian Day-Number.}

function Greg2Str(G : GregType; Delim : string) : string;
{Returns a Gregorian date record as a string of the form MMdDDdYYYY,
 where the separator, "d", is Delim[1].}

function JDN2Str(JDN : LongInt; Delim : string) : string;
{Returns a Julian Day-Number as a MMdDDdYYYY string.}

function Now  : LongInt;
{Returns the system time as Seconds-Since-Midnight.}

procedure Now2Time(var T : TimeType);
{Returns the system time as a Time record.}

function NowStr(Delim : string; T24 : boolean) : string;
{Returns the system time as a string of the form:
          HHdMMdSSss    if Delim is non-empty and T24 (24 hour time) is
                        false. The delimiter used, "d", is Delim[1]. The
                        suffix, "ss", is "am" or "pm" as appropriate.
          HHdMMdSS      if Delim is non-empty and T24 (24 hour time) is
                        true. The delimiter used, "d", is Delim[1]. The
                        time will be expressed in 24-hour form.
          HHMMSSss      if Delim is empty and T24 (24 hour time) is
                        false. The suffix, "ss", is "am" or "pm" as
                        appropriate.
          HHMM          if Delim is empty and T24 (24 hour time) is
                        true. The time will be expressed in 24-hour form.
}

procedure SSM2Time(SSM : LongInt; var T : TimeType);
{Converts Seconds-Since-Midnight to a Time record.}

function SSM2TimeStr(SSM : LongInt; Delim : string; T24 : boolean) : string;
{Returns Seconds-Since-Midnight as a string of the form:
          HHdMMdSSss    if Delim is non-empty and T24 (24 hour time) is
                        false. The delimiter used, "d", is Delim[1]. The
                        suffix, "ss", is "am" or "pm" as appropriate.
          HHdMMdSS      if Delim is non-empty and T24 (24 hour time) is
                        true. The delimiter used, "d", is Delim[1]. The
                        time will be expressed in 24-hour form.
          HHMMSSss      if Delim is empty and T24 (24 hour time) is
                        false. The suffix, "ss", is "am" or "pm" as
                        appropriate.
          HHMM          if Delim is empty and T24 (24 hour time) is
                        true. The time will be expressed in 24-hour form.
}

function Time2SSM(T : TimeType) : LongInt;
{Returns a Time record as Seconds-Since-Midnight.}

function Time2TimeStr(T : TimeType; Delim : string; T24 : boolean) : string;
{Returns a Time record as a string of the form:
          HHdMMdSSss    if Delim is non-empty and T24 (24 hour time) is
                        false. The delimiter used, "d", is Delim[1]. The
                        suffix, "ss", is "am" or "pm" as appropriate.
          HHdMMdSS      if Delim is non-empty and T24 (24 hour time) is
                        true. The delimiter used, "d", is Delim[1]. The
                        time will be expressed in 24-hour form.
          HHMMSSss      if Delim is empty and T24 (24 hour time) is
                        false. The suffix, "ss", is "am" or "pm" as
                        appropriate.
          HHMM          if Delim is empty and T24 (24 hour time) is
                        true. The time will be expressed in 24-hour form.
}

function Today  : LongInt;
{Returns the system date as a Julian Day-Number}

function Today2ANSI : string;
{Returns the system date as an ANSI date string (YYYYMMDD)}

procedure Today2Greg(var G : GregType);
{Returns the system date as a Gregorian date record.}

function TodayStr(Delim : string) : string;
{Returns the system date as a string of the form MMdDDdYYYY, where the
 separator, "d", is Delim[1].}

implementation

const
  D0 =    1461;
  D1 =  146097;
  D2 = 1721119;

function Greg2JDN(Greg : GregType) : LongInt;
var
  Century,
  XYear    : LongInt;
begin {Greg2JDN}
  with Greg do begin
    If Month <= 2 then begin
      Year := pred(Year);
      Month := Month + 12;
      end;
    Month := Month - 3;
    Century := Year div 100;
    XYear := Year mod 100;
    Century := (Century * D1) shr 2;
    XYear := (XYear * D0) shr 2;
    Greg2JDN := ((((Month * 153) + 2) div 5) + Day) + D2
                                      + XYear + Century;
    end; {with Greg}
  end; {Greg2JDN}


{**************************************************************}

procedure JDN2Greg(JDN : LongInt;
                  var Greg : GregType);
var
  Temp,
  XYear   : LongInt;
  YYear,
  YMonth,
  YDay    : Integer;
begin {JDN2Greg}
  with Greg do begin
    Temp := (((JDN - D2) shl 2) - 1);
    XYear := (Temp mod D1) or 3;
    JDN := Temp div D1;
    YYear := (XYear div D0);
    Temp := ((((XYear mod D0) + 4) shr 2) * 5) - 3;
    YMonth := Temp div 153;
    If YMonth >= 10 then begin
      YYear := YYear + 1;
      YMonth := YMonth - 12;
      end;
    YMonth := YMonth + 3;
    YDay := Temp mod 153;
    YDay := (YDay + 5) div 5;
    Year := YYear + (JDN * 100);
    Month := YMonth;
    Day := YDay;
    end; {with Greg}
  end; {JDN2Greg}


{**************************************************************}

function Greg2JDate(Greg : GregType) : integer;
var
  G     : GregType;
begin {Greg2JDate}
  with G do begin
    Year := Greg.Year;
    Month := 1;
    Day := 1;
    end; {with G}
  Greg2JDate := Greg2JDN(Greg) - Greg2JDN(G) + 1;
  end; {Greg2JDate}


{**************************************************************}

procedure JDate2Greg(JDate, Year : Integer;
                  var Greg : GregType);
var
  G     : GregType;
begin
  with G do begin
    Year := Greg.Year;
    Month := 1;
    Day := 1;
    end; {with G}
  JDN2Greg((Greg2JDN(G) + JDate - 1), Greg);
  end; {JDate2Greg}


{**************************************************************}

function DoW(Greg : GregType) : byte;
             {computes the day of the week (Sunday = 0; Saturday = 6)
             from the Gregorian date.}
begin
  DoW := (Greg2JDN(Greg) + 1) mod 7;
  end; {DayOfWeek}

{**************************************************************}

procedure Today2Greg(var G : GregType);
{Returns the system date as a Gregorian date record.}
  var
    R : registers;
  begin
    with R do begin
      AH := $2A;
      MsDos( R );
      with G do begin
        Year  := CX;
        Month := DH;
        Day   := DL;
        end; {with G}
      end; {with R}
    end; {Today2Greg}

function Today  : LongInt;
{Returns the system date as a Julian Day-Number}
  var
    G : GregType;
  begin
    Today2Greg(G);
    Today := Greg2JDN(G);
    end; {Today}

function Greg2Str(G : GregType; Delim : string) : string;
{Returns a Gregorian date record as a string of the form MMdDDdYYYY,
 where the separator, "d", is Delim[1].}
  var
    S1: string[4];
    S2: string;
    D : char;
  begin
    if Length(Delim) = 0 then
      D := #0
    else
      D := Delim[1];
    with G do begin
      str(Month:2, S2); {Month}
      str(Day:2, S1); {Day}
      S2 := S2 + D + S1;
      str(Year:4, S1); {Year}
      S2 := S2 + D + S1;
      end; {with R}
    Greg2Str := RepAllF(DelAllF(S2, #0), ' ', '0');
    end; {Greg2Str}

function Greg2ANSI(G : GregType) : string;
{Returns the date as an ANSI date string (YYYYMMDD)}
  var
    S1: string[4];
    S2: string;
  begin
    with G do begin
      str(Year:4, S2);  {Year}
      str(Month:2, S1); {Month}
      S2 := S2 + S1;
      str(Day:2, S1);   {Day}
      S2 := S2 + S1;
      end; {with G}
    Greg2ANSI := RepAllF(S2, ' ', '0');
    end; {Greg2ANSI}

function JDN2ANSI(JDN : LongInt) : string;
{Returns the JDN as an ANSI date string (YYYYMMDD)}
  var
    G : GregType;
  begin
    JDN2Greg(JDN, G);
    JDN2ANSI := Greg2ANSI(G);
    end; {JDN2ANSI}

function Today2ANSI : string;
{Returns the system date as an ANSI date string (YYYYMMDD)}
  begin
    Today2ANSI := JDN2ANSI(Today);
    end; {Today2ANSI}

function JDN2Str(JDN : LongInt; Delim : string) : string;
{Returns a Julian Day-Number as a MMdDDdYYYY string.}
  var
    G : GregType;
  begin
    JDN2Greg(JDN, G);
    JDN2Str := Greg2Str(G, Delim);
    end; {JDN2Str}

function TodayStr(Delim : string) : string;
{Returns the system date as a string of the form MMdDDdYYYY, where the
 separator, "d", is Delim[1].}
  var
    G : GregType;
  begin
    Today2Greg(G);
    TodayStr := Greg2Str(G, Delim);
    end; {TodayStr}

function Time2SSM(T : TimeType) : LongInt;
{Returns a Time record as Seconds-Since-Midnight.}
  var
    L1,
    L2,
    L3 : LongInt;
  begin
    with T do begin
      L1 := H;
      L2 := M;
      L3 := S;
      Time2SSM := (3600 * L1) + (60 * L2) + L3;
      end; {with T}
    end; {Time2SSM}

function Now  : LongInt;
{Returns the system time as Seconds-Since-Midnight.}
  var
    R : registers;
    T : TimeType;
  begin
    with R do begin
      AH := $2C;
      MsDos( R );
      with T do begin
        H := CH;
        M := CL;
        S := DH;
        end; {with T}
      end; {with R}
      Now := Time2SSM(T);
    end; {Now}

procedure SSM2Time(SSM : LongInt; var T : TimeType);
{Converts Seconds-Since-Midnight to a Time record.}
  var
    Q : LongInt;
    R : byte;
  begin
    with T do begin
      Q := SSM div 60;
      S := SSM mod 60;  {Get SECONDS}
      H := Q div 60;    {Get HOURS}
      M := Q mod 60;    {Get MINUTES}
      end; {with T}
    end; {SSM2Time}

procedure Now2Time(var T : TimeType);
{Returns the system time as a Time record.}
  begin
    SSM2Time(Now, T);
    end; {Now2Time}

function Time2TimeStr(T : TimeType; Delim : string; T24 : boolean) : string;
{Returns a Time record as a string of the form:
          HHdMMdSSss    if Delim is non-empty and T24 (24 hour time) is
                        false. The delimiter used, "d", is Delim[1]. The
                        suffix, "ss", is "am" or "pm" as appropriate.
          HHdMMdSS      if Delim is non-empty and T24 (24 hour time) is
                        true. The delimiter used, "d", is Delim[1]. The
                        time will be expressed in 24-hour form.
          HHMMSSss      if Delim is empty and T24 (24 hour time) is
                        false. The suffix, "ss", is "am" or "pm" as
                        appropriate.
          HHMM          if Delim is empty and T24 (24 hour time) is
                        true. The time will be expressed in 24-hour form.
}
 var
    S1: string[2];
    S2: string;
    AP: string[2];
    D : char;
  begin
    if Length(Delim) = 0 then
      D := #0
    else
      D := Delim[1];
    with T do begin
      if not T24 then
        case H of
          0     : begin
                    H := 12;
                    AP := 'am';
                    end;
          1..11 : begin
                    AP := 'am';
                    end;
          12    : begin
                    AP := 'pm';
                    end;
          13..23: begin
                    H := H - 12;
                    AP := 'pm';
                    end;
          end {case}
      else
        AP := '';
      str(H:2, S2);
      str(M:2, S1);
      S2 := S2 + D + S1;
      if (not T24) or (D <> #0) then begin
        str(S:2, S1);
        S2 := S2 + D + S1;
        end;
      end; {with R}
    Time2TimeStr := RepAllF(DelAllF(S2, #0), ' ', '0') + AP;
    end; {Time2TimeStr}

function NowStr(Delim : string; T24 : boolean) : string;
{Returns the system time as a string of the form:
          HHdMMdSSss    if Delim is non-empty and T24 (24 hour time) is
                        false. The delimiter used, "d", is Delim[1]. The
                        suffix, "ss", is "am" or "pm" as appropriate.
          HHdMMdSS      if Delim is non-empty and T24 (24 hour time) is
                        true. The delimiter used, "d", is Delim[1]. The
                        time will be expressed in 24-hour form.
          HHMMSSss      if Delim is empty and T24 (24 hour time) is
                        false. The suffix, "ss", is "am" or "pm" as
                        appropriate.
          HHMM          if Delim is empty and T24 (24 hour time) is
                        true. The time will be expressed in 24-hour form.
}
  var
    R : Registers;
    T : TimeType;
  begin
    with R do begin
      AH := $2C;
      MsDos( R );
      with T do begin
        H := CH;
        M := CL;
        S := DH;
        NowStr := Time2TimeStr(T, Delim, T24);
        end; {with T}
      end; {with R}
    end;{NowStr}

function SSM2TimeStr(SSM : LongInt; Delim : string; T24 : boolean) : string;
{Returns Seconds-Since-Midnight as a string of the form:
          HHdMMdSSss    if Delim is non-empty and T24 (24 hour time) is
                        false. The delimiter used, "d", is Delim[1]. The
                        suffix, "ss", is "am" or "pm" as appropriate.
          HHdMMdSS      if Delim is non-empty and T24 (24 hour time) is
                        true. The delimiter used, "d", is Delim[1]. The
                        time will be expressed in 24-hour form.
          HHMMSSss      if Delim is empty and T24 (24 hour time) is
                        false. The suffix, "ss", is "am" or "pm" as
                        appropriate.
          HHMM          if Delim is empty and T24 (24 hour time) is
                        true. The time will be expressed in 24-hour form.
}
  var
    T : TimeType;
  begin
    SSM2Time(SSM, T);
    SSM2TimeStr := Time2TimeStr(T, Delim, T24);
    end; {SSM2TimeStr}
  end.