Articles   Members Online:
-Article/Tip Search
-News Group Search over 21 Million news group articles.
-Delphi/Pascal
-CBuilder/C++
-C#Builder/C#
-JBuilder/Java
-Kylix
Member Area
-Home
-Account Center
-Top 10 NEW!!
-Submit Article/Tip
-Forums Upgraded!!
-My Articles
-Edit Information
-Login/Logout
-Become a Member
-Why sign up!
-Newsletter
-Chat Online!
-Indexes NEW!!
Employment
-Build your resume
-Find a job
-Post a job
-Resume Search
Contacts
-Contacts
-Feedbacks
-Link to us
-Privacy/Disclaimer
Embarcadero
Visit Embarcadero
Embarcadero Community
JEDI
Links
Some useful date calculation routines Turn on/off line numbers in source code. Switch to Orginial background IDE or DSP color Comment or reply to this aritlce/tip for discussion. Bookmark this article to my favorite article(s). Print this article
19-Nov-02
Category
Algorithm
Language
Delphi 2.x
Views
113
User Rating
No Votes
# Votes
0
Replies
0
Publisher:
DSP, Administrator
Reference URL:
DKB
			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

			
Vote: How useful do you find this Article/Tip?
Bad Excellent
1 2 3 4 5 6 7 8 9 10

 

Advertisement
Share this page
Advertisement
Download from Google

Copyright © Mendozi Enterprises LLC