🚀 go-pugleaf

RetroBBS NetNews Server

Inspired by RockSolid Light RIP Retro Guy

Article View: alt.lang.asm
Article #369

Re: HOW 2: Count days between two dates

#369
From: Mike Copeland
Date: Fri, 14 May 1999 00:00
302 lines
12519 bytes
> How can I count the days between two dates in D-M-YYYY format?

   Use the information you have here to convert the date to an ordinal 
form - Julian is probably best.  Then subtract using the ordinal values.  
Here's a TP/BP Unit which has the logic you might need:

Unit TCDate;                                 { Date Routines  970718 }
  { Author: Trevor J Carlsen  Released into the public domain }
  { Enhanced by: Michael R. Copeland }
interface
uses dos;
type  Date     = word;
Type HexByteType = String[2];
     HexWordType = String[4];

const WeekDays : array[0..6] of string[9] = ('Sunday','Monday','Tuesday',
                                             'Wednesday','Thursday',
                                             'Friday','Saturday');
      months   : array[1..12] of string[9] = 
('January','February','March','April','May','June','July','August',
 'September','October','November','December');

function DayOfTheWeek(pd : date): byte;
 { Returns the day of the week for any date  Sunday = 0 .. Sat = 6    }
 { pd = a packed date as returned by the function PackedDate          }
 { eg...  writeln('Today is ',WeekDays[DayOfTheWeek(Today))];         }

function PackedDate(yr,mth,d: word): date;
 { Packs a date into a word which represents the number of days since }
 { Dec 31,1899   01-01-1900 = 1                                       }

procedure UnPackDate(VAR yr,mth,d: word; pd : date);
 { Unpacks a word returned by the function PackedDate into its        }
 { respective parts of year, month and day                            }

function DateStr(pd: date; format: byte): string;
 { Unpacks a word returned by the function PackedDate into its        }
 { respective parts of year, month and day and then returns a string  }
 { formatted according to the specifications required.                }
 { If the format is > 9 then the day of the week is prefixed to the   }
 { returned string.                                                   }
 { Formats supported are:                                             }
 {     0:  dd/mm/yy                                                   }
 {     1:  mm/dd/yy                                                   }
 {     2:  dd/mm/yyyy                                                 }
 {     3:  mm/dd/yyyy                                                 }
 {     4:  [d]d xxx yyyy   (xxx is alpha month of 3 chars)            }
 {     5:  xxx [d]d, yyyy                                             }
 {     6:  [d]d FullAlphaMth yyyy                                     }
 {     7:  FullAlphaMth [d]d, yyyy                                    }
 {     8:  [d]d-xxx-yy                                                }
 {     9:  xxx [d]d, 'yy                                              }

function ValidDate(yr,mth,d : word; VAR errorcode : byte): boolean;
 { Validates the date and time data to ensure no out of range errors  }
 { can occur and returns an error code to the calling procedure. A    }
 { errorcode of zero is returned if no invalid parameter is detected. }
 { Errorcodes are as follows:                                         }

 {   Year out of range (< 1900 or > 2078) bit 0 of errorcode is set.  }
 {   Month < 1 or > 12                    bit 1 of errorcode is set.  }
 {   Day < 1 or > 31                      bit 2 of errorcode is set.  }
 {   Day out of range for month           bit 2 of errorcode is set.  }

procedure ParseDateString(var dstr; var y,m,d : word; format : byte);
 { Parses a date string in several formats into its component parts   }
 { It is the programmer's responsibility to ensure that the string    }
 { being parsed is a valid date string in the format expected.        }
 { If the year string is of 2 characters then the year returned will  }
 { have 1900 added if > 50 and 2000 added if under 51.                }
 { Formats supported are:                                             }
 {     0:  dd/mm/yy[yy]                                               }
 {     1:  mm/dd/yy[yy]                                               }

function NumbOfDaysInMth(y,m : word): byte;
 { returns the number of days in any month                            }

function Today : date;
 { returns the number of days since 31-12-1899                        }

function OrdDate (Y,M,D : Word):LongInt; { returns Ordinal Date yyddd }
function DateOrd (S : string): string;     { returns Date as 'yymmdd' }
function CentYear (Y : Byte): Word; { returns Year, adjusted for 2000 }
function Date2Hex (PD : Date): string;  { returns ordinal date as Hex }
function Hex2Date (HD : string): Word;  { returns Hex date as ordinal }
function Hex2YMDS (HD : string): string; { returns Hex date as YYMMDD }

implementation
const TDays : array[Boolean,0..12] of word =
         ((0,31,59,90,120,151,181,212,243,273,304,334,365),
         (0,31,60,91,121,152,182,213,244,274,305,335,366));

function OrdDate (Y,M,D : Word): LongInt;     { Ordinal Date as yyddd }
var LYR  : boolean;
    Temp : LongInt;
begin
  LYR := (Y mod 4 = 0) and (Y <> 1900);
  if Y > 50 then Dec (Y,1900)
  else           Dec (Y,2000);
  Temp := LongInt(Y) * 1000;
  Inc (Temp,TDays[LYR][M-1]);     { compute # days through last month }
  Inc (Temp,D);                                   { # days this month }
  OrdDate := Temp
end;  { OrdDate }

function DateOrd (S : string) : string;    { returns Date as 'yymmdd' }
var LYR   : boolean;
    Y,M,D : Word;
    Temp  : LongInt;
    N     : integer;
    SW,ST : string[6];
begin
  Val (Copy(S,1,2),Y,N); Val (Copy(S,3,3),Temp,N);
  if Y > 74 then Inc(Y,1900)
  else           Inc(Y,2000);
  LYR := (Y mod 4 = 0) and (Y <> 1900); N := 0;
  while (TDays[LYR][N] < Temp) do
    Inc (N);
  M := N;                                                   { month }
  D := Temp-TDays[LYR][M-1];      { subtract # days thru this month }
  Str((Y mod 100):2,SW); Str(M:2,ST);
  if ST[1] = ' ' then ST[1] := '0'; SW := SW+ST;
  Str(D:2,ST);
  if ST[1] = ' ' then ST[1] := '0'; SW := SW+ST;
  DateOrd := SW
end;  { DateOrd }

function DayOfTheWeek(pd : date): byte;
begin
  DayOfTheWeek := pd mod 7
end;

function PackedDate(yr,mth,d : word): date;
                                   { valid for all years 1900 to 2078 }
var temp  : word;
    lyr   : boolean;
begin
  lyr   := (yr mod 4 = 0) and (yr <> 1900);
  Yr    := Yr mod 100; { dec(yr,1900); }
  temp  := yr * word(365) + (yr div 4) - ord(lyr);
  inc(temp,TDays[lyr][mth-1]); inc(temp,d);
  PackedDate := temp
end;  { PackedDate }

procedure UnPackDate(var yr,mth,d: word; pd : date);
                                  { valid for all years 1900 to 2078 }
var julian : word;
    lyr    : boolean;
begin
  d := pd; yr := (longint(d)*4) div 1461;
  julian := d-(yr*365+(yr div 4));
  if Yr > 74 then Inc(Yr,1900)
  else            Inc(Yr,2000);
  lyr    := (yr mod 4 = 0) and (yr <> 1900);
  inc(julian,ord(lyr)); mth := 0;
  while julian > TDays[lyr][mth] do
    inc(mth);
  d := julian-TDays[lyr][mth-1]
end; { UnPackDate }

function DateStr(pd: date; format: byte): string;
var y,m,d    : word;
    YrStr    : string[5];
    MthStr   : string[11];
    DayStr   : string[8];
    TempStr  : string[5];
begin
  UnpackDate(y,m,d,pd); str(y,YrStr); str(m,MthStr); str(d,DayStr);
  TempStr := '';
  if format > 9 then 
    TempStr := copy(WeekDays[DayOfTheWeek(pd)],1,3) + ', ';
  if (format mod 10) < 4 then
    begin
      if m < 10 then MthStr := '0'+MthStr;
      if d < 10 then DayStr := '0'+DayStr
    end;
  case format mod 10 of  { force format to a valid value }
    0: DateStr := TempStr+DayStr+'/'+MthStr+'/'+copy(YrStr,3,2);
    1: DateStr := TempStr+MthStr+'/'+DayStr+'/'+copy(YrStr,3,2);
    2: DateStr := TempStr+DayStr+'/'+MthStr+'/'+YrStr;
    3: DateStr := TempStr+MthStr+'/'+DayStr+'/'+YrStr;
    4: DateStr := TempStr+DayStr+' '+copy(months[m],1,3)+' '+YrStr;
    5: DateStr := TempStr+copy(months[m],1,3)+' '+DayStr+' '+YrStr;
    6: DateStr := TempStr+DayStr+' '+months[m]+' '+YrStr;
    7: DateStr := TempStr+months[m]+' '+DayStr+' '+YrStr;
    8: DateStr := TempStr+DayStr+'-'+copy(months[m],1,3)+
                          '-'+copy(YrStr,3,2);
    9: DateStr := TempStr+copy(months[m],1,3)+
                          ' '+DayStr+','''+copy(YrStr,3,2);
  end;  { case }
end;  { DateStr }

function ValidDate(yr,mth,d : word; var errorcode : byte): boolean;
begin
  errorcode := 0;
  if (yr < 1900) or (yr > 2078) then errorcode := (errorcode or 1);
  if (d < 1) or (d > 31) then errorcode := (errorcode or 2);
  if (mth < 1) or (mth > 12) then errorcode := (errorcode or 4);
  case mth of
    4,6,9,11: if d > 30 then errorcode := (errorcode or 2);
           2: if d > (28+ord((yr mod 4) = 0)) then 
                errorcode := (errorcode or 2);
  end; {case }
  ValidDate := (errorcode = 0);
  if errorcode <> 0 then write(#7)
end;

procedure ParseDateString(var dstr; var y,m,d : word; format : byte);
var left,middle       : word;
    errcode           : integer;
    st                : string absolute dstr;
begin
  val(copy(st,1,2),left,errcode); val(copy(st,4,2),middle,errcode);
  val(copy(st,7,4),y,errcode);
  if y < 1900 then
    if y < 51 then inc(y,2000)
    else           inc(y,1900);
  case format of
    0: begin
         d := left; m := middle
       end;
    1: begin
         d := middle; m := left
       end;
  end; { case }
end; { ParseDateString }

function NumbOfDaysInMth(y,m : word): byte;
  { valid for the years 1900 - 2078                                   }
begin
  case m of
    1,3,5,7,8,10,12: NumbOfDaysInMth := 31;
    4,6,9,11       : NumbOfDaysInMth := 30;
    2              : NumbOfDaysInMth := 28+ord((y mod 4) = 0)-
                                        ord(y = 1900);
  end;
end;

function Today : date;
var y,m,d,dw : word;
begin
  GetDate(y,m,d,dw); Today := PackedDate(y,m,d)
end;

function CentYear (Y : Byte): Word; { returns Year, adjusted for 2000 }
begin
  if Y > 50 then CentYear := 1900+Y
  else           CentYear := 2000+Y
end;  { CentYear }

Procedure ByteToHex(x : Byte; Var s : HexByteType);
Const HexChars : Array[0..15] of Char = ('0','1','2','3','4',
                        '5','6','7','8','9','A','B','C','D','E','F');
Begin
  s := HexChars[x AND 240 SHR 4];
  s := s + HexChars[x AND 15]
End;

Procedure HexToByte(Var x : Byte; s : HexByteType);
Const DecNums : Array['0'..'F'] of Byte = (0,1,2,3,4,5,6,7,8,
                                9,0,0,0,0,0,0,0,10,11,12,13,14,15);
Var c : Char;
Begin
  c := s[1]; x := DecNums[c] SHL 4;
  c := s[2]; x := x OR DecNums[c]
End;

Procedure WordToHex(x : Word; Var s : HexWordType);
Var s2 : HexByteType;
Begin
  ByteToHex(Hi(x), s2); s := s2; ByteToHex(Lo(x), s2); s := s+s2
End;

Procedure HexToWord(Var x : Word; s : HexWordType);
Var y  : Byte;
    s2 : HexByteType;
Begin
  s2[1] := s[1]; s2[2] := s[2]; HexToByte(y, s2); x := y SHL 8;
  s2[1] := s[3]; s2[2] := s[4]; HexToByte(y, s2); x := x OR y
End;

function Date2Hex (PD : Date): string;  { returns ordinal date as Hex }
var S : HexWordType;
begin
  WordtoHex(PD,S); Date2Hex := S
end;  { Date2Hex }

function Hex2Date (HD : string): Word;  { returns Hex date as ordinal }
var W : Word;
begin
  HextoWord(W,HD); Hex2Date := W
end;  { Hex2Date }

function Hex2YMDS (HD : string): string; { returns Hex date as YYMMDD }
var W : Word;
    X : string;
begin
  HextoWord(W,HD); X := DateStr(W,0);
  Hex2YMDS := Copy(X,7,2)+Copy(X,4,2)+Copy(X,1,2)
end;  { Hex2YMDS }

end.  { TCDate unit }
Technical Details
Message-ID: <MPG.11a60a6b7d42ce8498968d@news>
Path: arc1-ca.pugleaf.net!unknown!not-for-mail
References: <7hh0gu$3qn$1@zonnetje.NL.net>

Show Full Headers
Complete Article Headers
X-Google-Language: ENGLISH,ASCII-7-bit
X-Google-Thread: 108ebd,c8153b5b519ca029
X-Google-Attributes: gid108ebd,public
X-Google-Thread: 111659,c8153b5b519ca029
X-Google-Attributes: gid111659,public
X-Google-Thread: f7d8d,c8153b5b519ca029
X-Google-Attributes: gidf7d8d,public
X-Google-Thread: 10cc59,c8153b5b519ca029
X-Google-Attributes: gid10cc59,public
From: mrcope@primenet.com (Mike Copeland)
Subject: Re: HOW 2: Count days between two dates
Date: 1999/05/14
Message-ID: <MPG.11a60a6b7d42ce8498968d@news>
X-Deja-AN: 477885981
Sender: news@sundevil.az05.bull.com
X-Nntp-Posting-Host: copelandpc.az05.bull.com
References: <7hh0gu$3qn$1@zonnetje.NL.net>
Organization: Bull
Newsgroups: alt.lang.asm,borland.public.turbopascal,comp.lang.pascal,comp.lang.pascal.borland