Author: William Gerbert
Some useful date calculation routines
Answer:
Ever notice how some date routines are missing from SysUtils? Well as they say,
necessity is the mother of invention, I've come up with some date calculation
routines that you can include in your own programs that require some date
calculations. If you've got any more than this, please feel free to share them!
1 type
2 TDatePart = (dpYear, dpMonth, dpDay);
3
4 {Purpose : Return a date part.}
5
6 function GetDatePart(Date: TDateTime; DatePart: TDatePart): Word;
7 var
8 D, M, Y: Word;
9 begin
10 //Initialize Result - avoids compiler warning
11 Result := 0;
12 DecodeDate(Date, Y, M, D);
13 case DatePart of
14 dpYear: Result := Y;
15 dpMonth: Result := M;
16 dpDay: Result := D;
17 end;
18 end;
19
20 {Purpose : Extracts the date portion of a date time. Useful for
21 seeing if two date time values fall on the same day}
22
23 function ExtractDatePart(Date: TDateTime): TDate;
24 begin
25 Result := Int(Date);
26 end;
27
28 {Purpose : Gets the time portion of a date time. Like ExtractDatePart
29 this is useful for comparing times.}
30
31 function ExtractTimePart(Date: TDateTime): TTime;
32 begin
33 Result := Frac(Date);
34 end;
35
36 {Purpose : Used for determining whether or not a DateTime is
37 a weekday.}
38
39 function IsWeekday(Day: TDateTime): Boolean;
40 begin
41 Result := (DayOfWeek(Day) >= 2) and (DayOfWeek(Day) <= 6);
42 end;
43
44 {Purpose : Function returns the date of the relative day of a
45 month/year combo such as the date of the "Third
46 Monday of January." The formal parameters depart a bit
47 from the MS SQL Server Schedule agent constants in that
48 the RelativeFactor parameter (Freq_Relative_Interval in
49 MS-SQL), takes integer values from 1 to 5 as opposed to
50 integer values from 2 to the 0th to 2 to the 4th power.
51
52 Formal Parameters
53 ====================================================================================
54 ==
55 Year : Year in question
56 Month : Month in question
57 RelativeFactor : 1 = First; 2 = Second; 3 = Third; 4 = Fourth; 5 = Last
58 Day : 1 - 7, day starting on Sunday; 8 = Day;
59 9 = Weekday; 10 = Weekend Day
60 }
61
62 function GetRelativeDate(Year, Month,
63 RelativeFactor, Day: Integer): TDateTime;
64 var
65 TempDate: TDateTime;
66 DayIndex: Integer;
67 begin
68 TempDate := EncodeDate(Year, Month, 1);
69 DayIndex := 0;
70 //Now, if you're looking for the last day, just go to the last
71 //day of the month, and count backwards until you hit the day
72 //you're interested in.
73 if (RelativeFactor = 5) then
74 begin
75 TempDate := EncodeDate(Year, Month, MonthDays[IsLeapYear(Year), Month]);
76 case Day of
77 1..7:
78 if (DayOfWeek(TempDate) = Day) then
79 Result := TempDate
80 else
81 begin
82 while (DayOfWeek(TempDate) <> Day) do
83 TempDate := TempDate - 1;
84 Result := TempDate;
85 end;
86 9:
87 begin
88 if IsWeekday(TempDate) then
89 Result := TempDate
90 else
91 begin
92 while not IsWeekday(TempDate) do
93 TempDate := TempDate - 1;
94 Result := TempDate;
95 end;
96 end;
97 10:
98 begin
99 if not IsWeekday(TempDate) then
100 Result := TempDate
101 else
102 begin
103 while IsWeekday(TempDate) do
104 TempDate := TempDate - 1;
105 Result := TempDate;
106 end;
107 end;
108 else
109 //This only happens if you're going after the very last day of the month
110 Result := TempDate;
111 end;
112 end
113 else
114 //Otherwise, you have to go through the month day by day until you get
115 //to the day you want. Since the relative week is a power of 2, just
116 //see if the day exponent is a
117 case Day of
118 1..7:
119 begin
120 while (DayIndex < RelativeFactor) do
121 begin
122 if (DayOfWeek(TempDate) = Day) then
123 Inc(DayIndex);
124 TempDate := TempDate + 1;
125 end;
126 Result := TempDate - 1;
127 end;
128 9:
129 begin
130 while (DayIndex < RelativeFactor) do
131 begin
132 if IsWeekDay(TempDate) then
133 Inc(DayIndex);
134 TempDate := TempDate + 1;
135 end;
136 Result := TempDate - 1;
137 end;
138 10:
139 begin
140 while (DayIndex < RelativeFactor) do
141 begin
142 if not IsWeekDay(TempDate) then
143 Inc(DayIndex);
144 TempDate := TempDate + 1;
145 end;
146 Result := TempDate - 1;
147 end;
148 else
149 Result := TempDate + RelativeFactor;
150 end;
151 end;
152
153 type
154 TDecimalTimeType = (dtSecond, dtMinute, dtHour);
155
156 {Purpose : Returns hours, minutes, or seconds in decimal format for use
157 in date time calculations}
158
159 function GetDecimalTime(Count: Integer;
160 DecimalTimeType: TDecimalTimeType): Double;
161 const
162 Second = 1 / 86400;
163 Minute = 1 / 1440;
164 Hour = 1 / 24;
165 begin
166 //Initialize result
167 Result := 0;
168 case DecimalTimeType of
169 dtSecond: Result := Count * Second;
170 dtMinute: Result := Count * Minute;
171 dtHour: Result := Count * Hour;
172 end;
173 end;
174
175 {Purpose : Converts a MS-style integer time to a TTime}
176
177 function IntTimeToTime(Time: Integer): TTime;
178 var
179 S: string;
180 begin
181 S := IntToStr(Time);
182 //String must be 5 or 6 character long
183 if (Length(S) < 5) or (Length(S) > 6) then
184 Result := 0
185 else
186 begin
187 if (Length(S) = 5) then //A morning time
188 S := Copy(S, 1, 1) + ':' + Copy(S, 2, 2) + ':' + Copy(S, 4, 2)
189 else //Afternoon, evening time
190 S := Copy(S, 1, 2) + ':' + Copy(S, 3, 2) + ':' + Copy(S, 5, 2);
191 Result := StrToTime(S);
192 end;
193 end;
// Got a valid specifier ? - evaluate it from data string
if (Mask <> '') and (length(Data) > 0) then
begin
// Day 1..31
if (Mask = 'DD') then
begin
Day := StrToIntDef(trim(copy(Data, 1, 2)), 0);
delete(Data, 1, 2);
end;
// Day Sun..Sat (Just remove from data string)
if Mask = 'DDD' then
delete(Data, 1, 3);
// Day Sunday..Saturday (Just remove from data string LEN)
if Mask = 'DDDD' then
begin
Tmp := copy(Data, 1, 3);
for iii := 1 to 7 do
begin
if Tmp = Uppercase(copy(LongDayNames[iii], 1, 3)) then
begin
delete(Data, 1, length(LongDayNames[iii]));
Break;
end;
end;
end;
// Month 1..12
if (Mask = 'MM') then
begin
Month := StrToIntDef(trim(copy(Data, 1, 2)), 0);
delete(Data, 1, 2);
end;
// Month Jan..Dec
if Mask = 'MMM' then
begin
Tmp := copy(Data, 1, 3);
for iii := 1 to 12 do
begin
if Tmp = Uppercase(copy(LongMonthNames[iii], 1, 3)) then
begin
Month := iii;
delete(Data, 1, 3);
Break;
end;
end;
end;
// Month January..December
if Mask = 'MMMM' then
begin
Tmp := copy(Data, 1, 3);
for iii := 1 to 12 do
begin
if Tmp = Uppercase(copy(LongMonthNames[iii], 1, 3)) then
begin
Month := iii;
delete(Data, 1, length(LongMonthNames[iii]));
Break;
end;
end;
end;
// Year 2 Digit
if Mask = 'YY' then
begin
Year := StrToIntDef(copy(Data, 1, 2), 0);
delete(Data, 1, 2);
if Year < TwoDigitYearCenturyWindow then
Year := (YearOf(Date) div 100) * 100 + Year
else
Year := (YearOf(Date) div 100 - 1) * 100 + Year;
end;
// Year 4 Digit
if Mask = 'YYYY' then
begin
Year := StrToIntDef(copy(Data, 1, 4), 0);
delete(Data, 1, 4);
end;
// Hours
if Mask = 'HH' then
begin
Hour := StrToIntDef(trim(copy(Data, 1, 2)), 0);
delete(Data, 1, 2);
end;
// Minutes
if Mask = 'NN' then
begin
Minute := StrToIntDef(trim(copy(Data, 1, 2)), 0);
delete(Data, 1, 2);
end;
// Seconds
if Mask = 'SS' then
begin
Second := StrToIntDef(trim(copy(Data, 1, 2)), 0);
delete(Data, 1, 2);
end;
// Milliseconds
if (Mask = 'ZZ') or (Mask = 'ZZZ') then
begin
MSec := StrToIntDef(trim(copy(Data, 1, 3)), 0);
delete(Data, 1, 3);
end;
// AmPm A or P flag
if (Mask = 'AP') then
begin
if Data[1] = 'A' then
AmPm := -1
else
AmPm := 1;
delete(Data, 1, 1);
end;
// AmPm AM or PM flag
if (Mask = 'AM') or (Mask = 'AMP') or (Mask = 'AMPM') then
begin
if copy(Data, 1, 2) = 'AM' then
AmPm := -1
else
AmPm := 1;
delete(Data, 1, 2);
end;
Mask := '';
i := ii;
end;
end
else
begin
// Remove delimiter from data string
if length(Data) > 1 then
delete(Data, 1, 1);
inc(i);
end;
end;
if AmPm = 1 then
Hour := Hour + 12;
if not TryEncodeDateTime(Year, Month, Day, Hour, Minute, Second, MSec, Retvar)
then
Retvar := 0.0;
Result := Retvar;
end;ttom of Form 1
|