Article View: alt.lang.asm
Article #369Re: HOW 2: Count days between two dates
From: Mike Copeland
Date: Fri, 14 May 1999 00:00
Date: Fri, 14 May 1999 00:00
302 lines
12519 bytes
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-mailReferences:
<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