home *** CD-ROM | disk | FTP | other *** search
/ Chip 2003 January / Chip_2003-01_cd1.bin / zkuste / delphi / unity / d56 / FNDUTL.ZIP / Utils / cDateTime.pas next >
Encoding:
Pascal/Delphi Source File  |  2002-10-29  |  59.1 KB  |  1,548 lines
  1. {$INCLUDE ..\cDefines.inc}
  2. unit cDateTime;
  3.  
  4. interface
  5.  
  6. uses
  7.   // Delphi
  8.   SysUtils;
  9.  
  10.  
  11.  
  12. {                                                                              }
  13. {                        DateTime functions v3.08                              }
  14. {                                                                              }
  15. {                     A collection of date/time functions.                     }
  16. {                                                                              }
  17. {                                                                              }
  18. {    This unit is copyrighted ⌐ 1999-2002 by David Butler (david@e.co.za)      }
  19. {                                                                              }
  20. {                  This unit is part of Delphi Fundamentals.                   }
  21. {                   Its original file name is cDateTime.pas                    }
  22. {       The latest version is available from the Fundamentals home page        }
  23. {                     http://fundementals.sourceforge.net/                     }
  24. {                                                                              }
  25. {                I invite you to use this unit, free of charge.                }
  26. {        I invite you to distibute this unit, but it must be for free.         }
  27. {             I also invite you to contribute to its development,              }
  28. {             but do not distribute a modified copy of this file.              }
  29. {                                                                              }
  30. {          A forum is available on SourceForge for general discussion          }
  31. {             http://sourceforge.net/forum/forum.php?forum_id=2117             }
  32. {                                                                              }
  33. {                                                                              }
  34. { Notes:                                                                       }
  35. {   A good source of information on calendars is the FAQ ABOUT CALENDARS,      }
  36. {   available at http://www.tondering.dk/claus/calendar.html                   }
  37. {                                                                              }
  38. {   Note the following (and more) is available in SysUtils:                    }
  39. {     Function IsLeapYear (Year : Word) : Boolean                              }
  40. {       (1 = Sunday .. 7 = Saturday)                                           }
  41. {     Function EncodeDate (Year, Month, Day : Word) : TDateTime;               }
  42. {     Procedure DecodeDate (D : DateTime; var Year, Month, Day : Word);        }
  43. {     var ShortDayNames, LongDayNames, ShortMonthNames, LongMonthNames : Array }
  44. {                                                                              }
  45. {                                                                              }
  46. { Revision history:                                                            }
  47. {   1999/11/10  0.01  Initial version from scratch. Add functions. DayOfYear.  }
  48. {   1999/11/21  0.02  EasterSunday function. Diff functions. ISOInteger.       }
  49. {   2000/03/04  1.03  Moved RFC functions to cInternetStandards.               }
  50. {   2000/03/05  1.04  Added Time Zone functions from cInternetStandards.       }
  51. {   2000/05/03  1.05  Added ISO Week functions, courtesy of Martin Boonstra    }
  52. {                     <m.boonstra@imn.nl>                                      }
  53. {   2000/08/16  1.06  Fixed bug in GMTBias reported by Gerhard Steinwedel      }
  54. {                     <steinwedel@gmx.de>                                      }
  55. {   2001/12/22  2.07  Added RFC DateTime functions from cInternetStandards.    }
  56. {   2002/01/10  3.08  Fixed bug with negative values in AddMonths as           }
  57. {                     reported by Michael Valentiner <MichaelVB@gmx.de>        }
  58. {                                                                              }
  59.  
  60. const
  61.   UnitName    = 'cDateTime';
  62.   UnitVersion = '3.08';
  63.   UnitDesc    = 'Date/Time functions';
  64.  
  65.  
  66. type
  67.   EDateTime = class (Exception);
  68.  
  69.  
  70.  
  71. {                                                                              }
  72. { Decoding                                                                     }
  73. {                                                                              }
  74. {$IFNDEF DELPHI6_UP}
  75. Procedure DecodeDateTime (const DateTime : TDateTime; var Year, Month, Day, Hour, Minute, Second, Millisecond : Word);
  76. {$ENDIF}
  77. Function  Century (const D : TDateTime) : Word;
  78. Function  Year (const D : TDateTime) : Word;
  79. Function  Month (const D : TDateTime) : Word;
  80. Function  Day (const D : TDateTime) : Word;
  81. Function  Hour (const D : TDateTime) : Word;
  82. Function  Minute (const D : TDateTime) : Word;
  83. Function  Second (const D : TDateTime) : Word;
  84. Function  Millisecond (const D : TDateTime) : Word;
  85.  
  86. const
  87.   OneDay         = 1.0;
  88.   OneHour        = OneDay / 24.0;
  89.   OneMinute      = OneHour / 60.0;
  90.   OneSecond      = OneMinute / 60.0;
  91.   OneMillisecond = OneSecond / 1000.0;
  92.  
  93.  
  94.  
  95. {                                                                              }
  96. { Encoding                                                                     }
  97. {                                                                              }
  98. {$IFNDEF DELPHI6_UP}
  99. Function  EncodeDateTime (const Year, Month, Day, Hour, Minute, Second, Millisecond : Word) : TDateTime;
  100. {$ENDIF}
  101. Procedure SetYear (var D : TDateTime; const Year : Word);
  102. Procedure SetMonth (var D : TDateTime; const Month : Word);
  103. Procedure SetDay (var D : TDateTime; const Day : Word);
  104. Procedure SetHour (var D : TDateTime; const Hour : Word);
  105. Procedure SetMinute (var D : TDateTime; const Minute : Word);
  106. Procedure SetSecond (var D : TDateTime; const Second : Word);
  107. Procedure SetMillisecond (var D : TDateTime; const Milliseconds : Word);
  108.  
  109.  
  110.  
  111. {                                                                              }
  112. { Comparison                                                                   }
  113. {                                                                              }
  114. Function  IsEqual (const D1, D2 : TDateTime) : Boolean; overload;
  115. Function  IsEqual (const D1 : TDateTime; const Ye, Mo, Da : Word) : Boolean; overload;
  116. Function  IsEqual (const D1 : TDateTime; const Ho, Mi, Se, ms : Word) : Boolean; overload;
  117. Function  IsAM (const D : TDateTime) : Boolean;
  118. Function  IsPM (const D : TDateTime) : Boolean;
  119. Function  IsMidnight (const D : TDateTime) : Boolean;
  120. Function  IsNoon (const D : TDateTime) : Boolean;
  121. Function  IsSunday (const D : TDateTime) : Boolean;
  122. Function  IsMonday (const D : TDateTime) : Boolean;
  123. Function  IsTuesday (const D : TDateTime) : Boolean;
  124. Function  IsWedneday (const D : TDateTime) : Boolean;
  125. Function  IsThursday (const D : TDateTime) : Boolean;
  126. Function  IsFriday (const D : TDateTime) : Boolean;
  127. Function  IsSaturday (const D : TDateTime) : Boolean;
  128. Function  IsWeekend (const D : TDateTime) : Boolean;
  129.  
  130.  
  131.  
  132. {                                                                              }
  133. { Relative date/times                                                          }
  134. {                                                                              }
  135. Function  Noon (const D : TDateTime) : TDateTime;
  136. Function  Midnight (const D : TDateTime) : TDateTime;
  137. Function  FirstDayOfMonth (const D : TDateTime) : TDateTime;
  138. Function  LastDayOfMonth (const D : TDateTime) : TDateTime;
  139. Function  NextWorkday (const D : TDateTime) : TDateTime;
  140. Function  PreviousWorkday (const D : TDateTime) : TDateTime;
  141. Function  FirstDayOfYear (const D : TDateTime) : TDateTime;
  142. Function  LastDayOfYear (const D : TDateTime) : TDateTime;
  143. Function  EasterSunday (const Year : Word) : TDateTime;
  144. Function  GoodFriday (const Year : Word) : TDateTime;
  145.  
  146. Function  AddMilliseconds (const D : TDateTime; const N : Int64) : TDateTime;
  147. Function  AddSeconds (const D : TDateTime; const N : Int64) : TDateTime;
  148. Function  AddMinutes (const D : TDateTime; const N : Integer) : TDateTime;
  149. Function  AddHours (const D : TDateTime; const N : Integer) : TDateTime;
  150. Function  AddDays (const D : TDateTime; const N : Integer) : TDateTime;
  151. Function  AddWeeks (const D : TDateTime; const N : Integer) : TDateTime;
  152. Function  AddMonths (const D : TDateTime; const N : Integer) : TDateTime;
  153. Function  AddYears (const D : TDateTime; const N : Integer) : TDateTime;
  154.  
  155.  
  156.  
  157. {                                                                              }
  158. { Counting                                                                     }
  159. {                                                                              }
  160. {   DayOfYear and WeekNumber start at 1.                                       }
  161. {   WeekNumber is not the ISO week number but the week number where week one   }
  162. {     starts at Jan 1.                                                         }
  163. {   For reference: ISO standard 8601:1988 - (European Standard EN 28601).      }
  164. {     "It states that a week is identified by its number in a given year.      }
  165. {      A week begins with a Monday (day 1) and ends with a Sunday (day 7).     }
  166. {      The first week of a year is the one which includes the first Thursday   }
  167. {      (day 4), or equivalently the one which includes January 4.              }
  168. {      In other words, the first week of a new year is the week that has the   }
  169. {      majority of its days in the new year."                                  }
  170. {   ISOFirstWeekOfYear returns the start date (Monday) of the first ISO week   }
  171. {     of a year (may be in the previous year).                                 }
  172. {   ISOWeekNumber returns the ISO Week number and the year to which the week   }
  173. {     number applies.                                                          }
  174. {                                                                              }
  175. Function  DayOfYear (const Ye, Mo, Da : Word) : Integer; overload;
  176. Function  DayOfYear (const D : TDateTime) : Integer; overload;
  177. Function  DaysInMonth (const Ye, Mo : Word) : Integer; overload;
  178. Function  DaysInMonth (const D : TDateTime) : Integer; overload;
  179. Function  DaysInYear (const Ye : Word) : Integer; overload;
  180. Function  DaysInYear (const D : TDateTime) : Integer; overload;
  181. Function  WeekNumber (const D : TDateTime) : Integer;
  182. Function  ISOFirstWeekOfYear (const Ye : Integer) : TDateTime;
  183. Procedure ISOWeekNumber (const D : TDateTime; var WeekNumber, WeekYear : Word);
  184. Function  DateTimeAsISO8601String (const D : TDateTime) : String;
  185. Function  ISO8601StringAsDateTime (const D : String) : TDateTime;
  186.  
  187.  
  188.  
  189. {                                                                              }
  190. { Difference                                                                   }
  191. {                                                                              }
  192. Function  DiffMilliseconds (const D1, D2 : TDateTime) : Int64;
  193. Function  DiffSeconds (const D1, D2 : TDateTime) : Integer;
  194. Function  DiffMinutes (const D1, D2 : TDateTime) : Integer;
  195. Function  DiffHours (const D1, D2 : TDateTime) : Integer;
  196. Function  DiffDays (const D1, D2 : TDateTime) : Integer;
  197. Function  DiffWeeks (const D1, D2 : TDateTime) : Integer;
  198. Function  DiffMonths (const D1, D2 : TDateTime) : Integer;
  199. Function  DiffYears (const D1, D2 : TDateTime) : Integer;
  200.  
  201.  
  202.  
  203. {                                                                              }
  204. { Time Zone                                                                    }
  205. {   Uses systems regional settings to convert between local and GMT time.      }
  206. {                                                                              }
  207. Function  GMTTimeToLocalTime (const D : TDateTime) : TDateTime;
  208. Function  LocalTimeToGMTTime (const D : TDateTime) : TDateTime;
  209.  
  210.  
  211.  
  212. {                                                                              }
  213. { Conversions                                                                  }
  214. {                                                                              }
  215. {   ANSI Integer is an integer in the format YYYYDDD (where DDD = day number)  }
  216. {   ISO-8601 Integer date is an integer in the format YYYYMMDD.                }
  217. {   TropicalYear is the time for one orbit of the earth around the sun.        }
  218. {   TwoDigitYearToYear returns the full year number given a two digit year.    }
  219. {   SynodicMonth is the time between two full moons.                           }
  220. {                                                                              }
  221. Function  DateTimeToANSI (const D : TDateTime) : Integer;
  222. Function  ANSIToDateTime (const Julian : Integer) : TDateTime;
  223. Function  DateTimeToISOInteger (const D : TDateTime) : Integer;
  224. Function  DateTimeToISO (const D : TDateTime) : String;
  225. Function  ISOIntegerToDateTime (const ISOInteger : Integer) : TDateTime;
  226. Function  TwoDigitYearToYear (const Y : Integer) : Integer;
  227. Function  DateTimeAsElapsedTime (const D : TDateTime) : String;
  228.  
  229.  
  230.  
  231. {                                                                              }
  232. { RFC DateTimes                                                                }
  233. {                                                                              }
  234. {   RFC1123 DateTime is the preferred representation on the Internet for all   }
  235. {   DateTime values.                                                           }
  236. {   Use DateTimeToRFCDateTime to convert local time to RFC1123 DateTime.       }
  237. {   Use RFCDateTimeToDateTime to convert RFC DateTime formats to local time.   }
  238. {   Returns 0.0 if not a recognised RFC DateTime.                              }
  239. {   See RFC822, RFC850, RFC1123, RFC1036, RFC1945.                             }
  240. {                                                                              }
  241. { From RFC 822 (Standard for the format of ARPA INTERNET Text Messages):       }
  242. {    "time        =  hour zone                      ; ANSI and Military        }
  243. {     hour        =  2DIGIT ":" 2DIGIT [":" 2DIGIT] ; 00:00:00 - 23:59:59      }
  244. {     zone        =  "UT"  / "GMT"                  ; Universal Time           }
  245. {                                                   ; North American : UT      }
  246. {                 /  "EST" / "EDT"                  ;  Eastern:  - 5/ - 4      }
  247. {                 /  "CST" / "CDT"                  ;  Central:  - 6/ - 5      }
  248. {                 /  "MST" / "MDT"                  ;  Mountain: - 7/ - 6      }
  249. {                 /  "PST" / "PDT"                  ;  Pacific:  - 8/ - 7      }
  250. {                 /  1ALPHA                         ; Military: Z = UT;        }
  251. {                                                   ;  A:-1; (J not used)      }
  252. {                                                   ;  M:-12; N:+1; Y:+12      }
  253. {                 / ( ("+" / "-") 4DIGIT )          ; Local differential       }
  254. {                                                   ;  hours+min. (HHMM)       }
  255. {     date-time   =  [ day "," ] date time          ; dd mm yy                 }
  256. {                                                   ;  hh:mm:ss zzz            }
  257. {     day         =  "Mon"  / "Tue" /  "Wed"  / "Thu"                          }
  258. {                 /  "Fri"  / "Sat" /  "Sun"                                   }
  259. {     date        =  1*2DIGIT month 2DIGIT        ; day month year             }
  260. {                                                 ;  e.g. 20 Jun 82            }
  261. {     month       =  "Jan"  /  "Feb" /  "Mar"  /  "Apr"                        }
  262. {                 /  "May"  /  "Jun" /  "Jul"  /  "Aug"                        }
  263. {                 /  "Sep"  /  "Oct" /  "Nov"  /  "Dec"                    "   }
  264. {                                                                              }
  265. { Note that even though RFC 822 states hour=2DIGIT":"2DIGIT, none of the       }
  266. {   examples given in the appendix include the ":",                            }
  267. {   for example: "26 Aug 76 1429 EDT"                                          }
  268. {                                                                              }
  269. {                                                                              }
  270. { From RFC 1036 (Standard for Interchange of USENET Messages):                 }
  271. {                                                                              }
  272. {   "Its format must be acceptable both in RFC-822 and to the getdate(3)       }
  273. {    routine that is provided with the Usenet software.   ...                  }
  274. {    One format that is acceptable to both is:                                 }
  275. {                                                                              }
  276. {                      Wdy, DD Mon YY HH:MM:SS TIMEZONE                        }
  277. {                                                                              }
  278. {    Note in particular that ctime(3) format:                                  }
  279. {                                                                              }
  280. {                          Wdy Mon DD HH:MM:SS YYYY                            }
  281. {                                                                              }
  282. {    is not acceptable because it is not a valid RFC-822 date.  However,       }
  283. {    since older software still generates this format, news                    }
  284. {    implementations are encouraged to accept this format and translate        }
  285. {    it into an acceptable format.                                         "   }
  286. {                                                                              }
  287. {   "Here is an example of a message in the old format (before the             }
  288. {    existence of this standard). It is recommended that                       }
  289. {    implementations also accept messages in this format to ease upward        }
  290. {    conversion.                                                               }
  291. {                                                                              }
  292. {               Posted: Fri Nov 19 16:14:55 1982                           "   }
  293. {                                                                              }
  294. {                                                                              }
  295. { From RFC 1945 (Hypertext Transfer Protocol -- HTTP/1.0)                      }
  296. {                                                                              }
  297. {  "HTTP/1.0 applications have historically allowed three different            }
  298. {   formats for the representation of date/time stamps:                        }
  299. {                                                                              }
  300. {       Sun, 06 Nov 1994 08:49:37 GMT    ; RFC 822, updated by RFC 1123        }
  301. {       Sunday, 06-Nov-94 08:49:37 GMT   ; RFC 850, obsoleted by RFC 1036      }
  302. {       Sun Nov  6 08:49:37 1994         ; ANSI C's asctime() format           }
  303. {                                                                              }
  304. {   The first format is preferred as an Internet standard and represents       }
  305. {   a fixed-length subset of that defined by RFC 1123 [6] (an update to        }
  306. {   RFC 822 [7]). The second format is in common use, but is based on the      }
  307. {   obsolete RFC 850 [10] date format and lacks a four-digit year.             }
  308. {   HTTP/1.0 clients and servers that parse the date value should accept       }
  309. {   all three formats, though they must never generate the third               }
  310. {   (asctime) format.                                                          }
  311. {                                                                              }
  312. {      Note: Recipients of date values are encouraged to be robust in          }
  313. {      accepting date values that may have been generated by non-HTTP          }
  314. {      applications, as is sometimes the case when retrieving or posting       }
  315. {      messages via proxies/gateways to SMTP or NNTP.                       "  }
  316. {                                                                              }
  317. {  "All HTTP/1.0 date/time stamps must be represented in Universal Time        }
  318. {   (UT), also known as Greenwich Mean Time (GMT), without exception.          }
  319. {                                                                              }
  320. {       HTTP-date      = rfc1123-date | rfc850-date | asctime-date             }
  321. {                                                                              }
  322. {       rfc1123-date   = wkday "," SP date1 SP time SP "GMT"                   }
  323. {       rfc850-date    = weekday "," SP date2 SP time SP "GMT"                 }
  324. {       asctime-date   = wkday SP date3 SP time SP 4DIGIT                      }
  325. {                                                                              }
  326. {       date1          = 2DIGIT SP month SP 4DIGIT                             }
  327. {                        ; day month year (e.g., 02 Jun 1982)                  }
  328. {       date2          = 2DIGIT "-" month "-" 2DIGIT                           }
  329. {                        ; day-month-year (e.g., 02-Jun-82)                    }
  330. {       date3          = month SP ( 2DIGIT | ( SP 1DIGIT ))                    }
  331. {                        ; month day (e.g., Jun  2)                            }
  332. {                                                                              }
  333. {       time           = 2DIGIT ":" 2DIGIT ":" 2DIGIT                          }
  334. {                        ; 00:00:00 - 23:59:59                                 }
  335. {                                                                              }
  336. {       wkday          = "Mon" | "Tue" | "Wed"                                 }
  337. {                      | "Thu" | "Fri" | "Sat" | "Sun"                         }
  338. {                                                                              }
  339. {       weekday        = "Monday" | "Tuesday" | "Wednesday"                    }
  340. {                      | "Thursday" | "Friday" | "Saturday" | "Sunday"         }
  341. {                                                                              }
  342. {       month          = "Jan" | "Feb" | "Mar" | "Apr"                         }
  343. {                      | "May" | "Jun" | "Jul" | "Aug"                         }
  344. {                      | "Sep" | "Oct" | "Nov" | "Dec"                      "  }
  345. {                                                                              }
  346. Function  GMTDateTimeToRFC1123DateTime (const D : TDateTime; const IncludeDayOfWeek : Boolean = True) : String;
  347. Function  DateTimeToRFCDateTime (const D : TDateTime) : String;
  348. Function  NowAsRFCDateTime : String;
  349.  
  350. Function  RFCDateTimeToGMTDateTime (const S : String) : TDateTime;
  351. Function  RFCDateTimeToDateTime (const S : String) : TDateTime;
  352.  
  353. Function  RFCTimeZoneToGMTBias (const Zone : String) : Integer;
  354.  
  355.  
  356.  
  357. {                                                                              }
  358. { High-precision timing                                                        }
  359. {                                                                              }
  360. {   StartTimer returns an encoded time (running timer).                        }
  361. {   StopTimer returns an encoded elapsed time (stopped timer).                 }
  362. {   ResumeTimer returns an encoded time (running timer), given an encoded      }
  363. {     elapsed time (stopped timer).                                            }
  364. {   StoppedTimer returns an encoded elapsed time of zero, ie a stopped timer   }
  365. {     with no time elapsed.                                                    }
  366. {   MillisecondsElapsed returns the time elapsed, given a running or a stopped }
  367. {     Timer.                                                                   }
  368. {   Times are encoded in CPU clock cycles.                                     }
  369. {   CPU clock frequency returns the number of CPU clock cycles per second.     }
  370. {                                                                              }
  371. type
  372.   THPTimer = Int64;
  373.  
  374. Function  StartTimer : THPTimer;
  375. Procedure StopTimer (var Timer : THPTimer);
  376. Procedure ResumeTimer (var StoppedTimer : THPTimer);
  377. Function  StoppedTimer : THPTimer;
  378. Function  ElapsedTimer (const Milliseconds : Integer) : THPTimer;
  379. Function  MillisecondsElapsed (const Timer : THPTimer; const TimerRunning : Boolean = True) : Integer;
  380. Function  MicrosecondsElapsed (const Timer : THPTimer; const TimerRunning : Boolean = True) : Integer;
  381. Function  CPUClockFrequency : Int64;
  382. Procedure DelayMicroSeconds (const MicroSeconds : Integer);
  383.  
  384.  
  385.  
  386. const
  387.   TropicalYear = 365.24219 * OneDay;  // 365 days, 5 hr, 48 min, 46 sec
  388.   SynodicMonth = 29.53059 * OneDay;
  389.  
  390.  
  391.  
  392. {                                                                              }
  393. { Self testing code                                                            }
  394. {                                                                              }
  395. Procedure SelfTest;
  396.  
  397.  
  398.  
  399. implementation
  400.  
  401.  
  402.  
  403. uses
  404.   // Delphi
  405.   Windows,
  406.   {$IFDEF DELPHI6_UP}
  407.   DateUtils,
  408.   {$ENDIF}
  409.  
  410.   // Fundamentals
  411.   cUtils,
  412.   cStrings;
  413.  
  414.  
  415.  
  416. {                                                                              }
  417. { Decoding                                                                     }
  418. {                                                                              }
  419. Function Century (const D : TDateTime) : Word;
  420.   Begin
  421.     Result := Year (D) div 100;
  422.   End;
  423.  
  424. Function Year (const D : TDateTime) : Word;
  425. var Mo, Da : Word;
  426.   Begin
  427.     DecodeDate (D, Result, Mo, Da);
  428.   End;
  429.  
  430. Function Month (const D : TDateTime) : Word;
  431. var Ye, Da : Word;
  432.   Begin
  433.     DecodeDate (D, Ye, Result, Da);
  434.   End;
  435.  
  436. Function Day (const D : TDateTime) : Word;
  437. var Ye, Mo : Word;
  438.   Begin
  439.     DecodeDate (D, Ye, Mo, Result);
  440.   End;
  441.  
  442. Function Hour (const D : TDateTime) : Word;
  443. var Mi, Se, MS : Word;
  444.   Begin
  445.     DecodeTime (D, Result, Mi, Se, MS);
  446.   End;
  447.  
  448. Function Minute (const D : TDateTime) : Word;
  449. var Ho, Se, MS : Word;
  450.   Begin
  451.     DecodeTime (D, Ho, Result, Se, MS);
  452.   End;
  453.  
  454. Function Second (const D : TDateTime) : Word;
  455. var Ho, Mi, MS : Word;
  456.   Begin
  457.     DecodeTime (D, Ho, Mi, Result, MS);
  458.   End;
  459.  
  460. Function Millisecond (const D : TDateTime) : Word;
  461. var Ho, Mi, Se : Word;
  462.   Begin
  463.     DecodeTime (D, Ho, Mi, Se, Result);
  464.   End;
  465.  
  466. {$IFNDEF DELPHI6_UP}
  467. Procedure DecodeDateTime (const DateTime : TDateTime; var Year, Month, Day, Hour, Minute, Second, Millisecond : Word);
  468.   Begin
  469.     DecodeDate (DateTime, Year, Month, Day);
  470.     DecodeTime (DateTime, Hour, Minute, Second, Millisecond);
  471.   End;
  472.  
  473. Function EncodeDateTime (const Year, Month, Day, Hour, Minute, Second, Millisecond : Word) : TDateTime;
  474.   Begin
  475.     Result := EncodeDate (Year, Month, Day) +
  476.               EncodeTime (Hour, Minute, Second, Millisecond);
  477.   End;
  478. {$ENDIF}
  479.  
  480.  
  481.  
  482.  
  483. {                                                                              }
  484. { Encoding                                                                     }
  485. {                                                                              }
  486. Procedure SetYear (var D : TDateTime; const Year : Word);
  487. var Ye, Mo, Da, Ho, Mi, Se, Ms : Word;
  488.   Begin
  489.     DecodeDateTime (D, Ye, Mo, Da, Ho, Mi, Se, Ms);
  490.     D := EncodeDateTime (Year, Mo, Da, Ho, Mi, Se, Ms);
  491.   End;
  492.  
  493. Procedure SetMonth (var D : TDateTime; const Month : Word);
  494. var Ye, Mo, Da, Ho, Mi, Se, Ms : Word;
  495.   Begin
  496.     DecodeDateTime (D, Ye, Mo, Da, Ho, Mi, Se, Ms);
  497.     D := EncodeDateTime (Ye, Month, Da, Ho, Mi, Se, Ms);
  498.   End;
  499.  
  500. Procedure SetDay (var D : TDateTime; const Day : Word);
  501. var Ye, Mo, Da, Ho, Mi, Se, Ms : Word;
  502.   Begin
  503.     DecodeDateTime (D, Ye, Mo, Da, Ho, Mi, Se, Ms);
  504.     D := EncodeDateTime (Ye, Mo, Day, Ho, Mi, Se, Ms);
  505.   End;
  506.  
  507. Procedure SetHour (var D : TDateTime; const Hour : Word);
  508. var Ye, Mo, Da, Ho, Mi, Se, Ms : Word;
  509.   Begin
  510.     DecodeDateTime (D, Ye, Mo, Da, Ho, Mi, Se, Ms);
  511.     D := EncodeDateTime (Ye, Mo, Da, Hour, Mi, Se, Ms);
  512.   End;
  513.  
  514. Procedure SetMinute (var D : TDateTime; const Minute : Word);
  515. var Ye, Mo, Da, Ho, Mi, Se, Ms : Word;
  516.   Begin
  517.     DecodeDateTime (D, Ye, Mo, Da, Ho, Mi, Se, Ms);
  518.     D := EncodeDateTime (Ye, Mo, Da, Ho, Minute, Se, Ms);
  519.   End;
  520.  
  521. Procedure SetSecond (var D : TDateTime; const Second : Word);
  522. var Ye, Mo, Da, Ho, Mi, Se, Ms : Word;
  523.   Begin
  524.     DecodeDateTime (D, Ye, Mo, Da, Ho, Mi, Se, Ms);
  525.     D := EncodeDateTime (Ye, Mo, Da, Ho, Mi, Second, Ms);
  526.   End;
  527.  
  528. Procedure SetMillisecond (var D : TDateTime; const Milliseconds : Word);
  529. var Ye, Mo, Da, Ho, Mi, Se, Ms : Word;
  530.   Begin
  531.     DecodeDateTime (D, Ye, Mo, Da, Ho, Mi, Se, Ms);
  532.     D := EncodeDateTime (Ye, Mo, Da, Ho, Mi, Se, Milliseconds);
  533.   End;
  534.  
  535.  
  536.  
  537. {                                                                              }
  538. { Comparison                                                                   }
  539. {                                                                              }
  540. Function IsEqual (const D1, D2 : TDateTime) : Boolean;
  541.   Begin
  542.     Result := Abs (D1 - D2) < OneMillisecond;
  543.   End;
  544.  
  545. Function IsEqual (const D1 : TDateTime; const Ye, Mo, Da : Word) : Boolean;
  546. var Ye1, Mo1, Da1 : Word;
  547.   Begin
  548.     DecodeDate (D1, Ye1, Mo1, Da1);
  549.     Result := (Da = Da1) and (Mo = Mo1) and (Ye = Ye1);
  550.   End;
  551.  
  552. Function IsEqual (const D1 : TDateTime; const Ho, Mi, Se, ms : Word) : Boolean;
  553. var Ho1, Mi1, Se1, ms1 : Word;
  554.   Begin
  555.     DecodeTime (D1, Ho1, Mi1, Se1, ms1);
  556.     Result := (ms = ms1) and (Se = Se1) and (Mi = Mi1) and (Ho = Ho1);
  557.   End;
  558.  
  559. Function IsAM (const D : TDateTime) : Boolean;
  560.   Begin
  561.     Result := Frac (D) < 0.5;
  562.   End;
  563.  
  564. Function IsPM (const D : TDateTime) : Boolean;
  565.   Begin
  566.     Result := Frac (D) >= 0.5;
  567.   End;
  568.  
  569. Function IsNoon (const D : TDateTime) : Boolean;
  570.   Begin
  571.     Result := Abs (Frac (D) - 0.5) < OneMillisecond;
  572.   End;
  573.  
  574. Function IsMidnight (const D : TDateTime) : Boolean;
  575. var T : TDateTime;
  576.   Begin
  577.     T := Frac (D);
  578.     Result := (T < OneMillisecond) or (T > 1.0 - OneMillisecond);
  579.   End;
  580.  
  581. Function IsSunday (const D : TDateTime) : Boolean;
  582.   Begin
  583.     Result := DayOfWeek (D) = 1;
  584.   End;
  585.  
  586. Function IsMonday (const D : TDateTime) : Boolean;
  587.   Begin
  588.     Result := DayOfWeek (D) = 2;
  589.   End;
  590.  
  591. Function IsTuesday (const D : TDateTime) : Boolean;
  592.   Begin
  593.     Result := DayOfWeek (D) = 3;
  594.   End;
  595.  
  596. Function IsWedneday (const D : TDateTime) : Boolean;
  597.   Begin
  598.     Result := DayOfWeek (D) = 4;
  599.   End;
  600.  
  601. Function IsThursday (const D : TDateTime) : Boolean;
  602.   Begin
  603.     Result := DayOfWeek (D) = 5;
  604.   End;
  605.  
  606. Function IsFriday (const D : TDateTime) : Boolean;
  607.   Begin
  608.     Result := DayOfWeek (D) = 6;
  609.   End;
  610.  
  611. Function IsSaturday (const D : TDateTime) : Boolean;
  612.   Begin
  613.     Result := DayOfWeek (D) = 7;
  614.   End;
  615.  
  616. Function IsWeekend (const D : TDateTime) : Boolean;
  617.   Begin
  618.     Result := DayOfWeek (D) in [1, 7];
  619.   End;
  620.  
  621. Function IsWeekday (const D : TDateTime) : Boolean;
  622.   Begin
  623.     Result := DayOfWeek (D) in [2..6];
  624.   End;
  625.  
  626.  
  627.  
  628. {                                                                              }
  629. { Relative calculations                                                        }
  630. {                                                                              }
  631. Function Noon (const D : TDateTime) : TDateTime;
  632.   Begin
  633.     Result := Int (D) + 0.5 * OneDay;
  634.   End;
  635.  
  636. Function Midnight (const D : TDateTime) : TDateTime;
  637.   Begin
  638.     Result := Int (D);
  639.   End;
  640.  
  641. Function NextWorkday (const D : TDateTime) : TDateTime;
  642.   Begin
  643.     Case DayOfWeek (D) of
  644.       1..5 : Result := Trunc (D) + OneDay;                                      // 1..5 Sun..Thu
  645.       6    : Result := Trunc (D) + 3 * OneDay;                                  // 6    Fri
  646.       else Result := Trunc (D) + 2 * OneDay;                                    // 7    Sat
  647.     end;
  648.   End;
  649.  
  650. Function PreviousWorkday (const D : TDateTime) : TDateTime;
  651.   Begin
  652.     Case DayOfWeek (D) of
  653.       1 : Result := Trunc (D) - 2 * OneDay;                                     // 1    Sun
  654.       2 : Result := Trunc (D) - 3 * OneDay;                                     // 2    Mon
  655.       else Result := Trunc (D) - OneDay;                                        // 3..7 Tue-Sat
  656.     end;
  657.   End;
  658.  
  659. Function LastDayOfMonth (const D : TDateTime) : TDateTime;
  660. var Ye, Mo, Da : Word;
  661.   Begin
  662.     DecodeDate (D, Ye, Mo, Da);
  663.     Result := EncodeDate (Ye, Mo, DaysInMonth (Ye, Mo));
  664.   End;
  665.  
  666. Function FirstDayOfMonth (const D : TDateTime) : TDateTime;
  667. var Ye, Mo, Da : Word;
  668.   Begin
  669.     DecodeDate (D, Ye, Mo, Da);
  670.     Result := EncodeDate (Ye, Mo, 1);
  671.   End;
  672.  
  673. Function LastDayOfYear (const D : TDateTime) : TDateTime;
  674. var Ye, Mo, Da : Word;
  675.   Begin
  676.     DecodeDate (D, Ye, Mo, Da);
  677.     Result := EncodeDate (Ye, 12, 31);
  678.   End;
  679.  
  680. Function FirstDayOfYear (const D : TDateTime) : TDateTime;
  681. var Ye, Mo, Da : Word;
  682.   Begin
  683.     DecodeDate (D, Ye, Mo, Da);
  684.     Result := EncodeDate (Ye, 1, 1);
  685.   End;
  686.  
  687. { This algorithm comes from http://www.tondering.dk/claus/calendar.html:       }
  688. { " This algorithm is based in part on the algorithm of Oudin (1940) as        }
  689. {   quoted in "Explanatory Supplement to the Astronomical Almanac",            }
  690. {   P. Kenneth Seidelmann, editor.                                             }
  691. {   People who want to dig into the workings of this algorithm, may be         }
  692. {   interested to know that                                                    }
  693. {     G is the Golden Number-1                                                 }
  694. {     H is 23-Epact (modulo 30)                                                }
  695. {     I is the number of days from 21 March to the Paschal full moon           }
  696. {     J is the weekday for the Paschal full moon (0=Sunday, 1=Monday,etc.)     }
  697. {     L is the number of days from 21 March to the Sunday on or before         }
  698. {       the Paschal full moon (a number between -6 and 28) "                   }
  699. Function EasterSunday (const Year : Word) : TDateTime;
  700. var C, I, J, H, G, L : Integer;
  701.     D, M : Word;
  702.   Begin
  703.     G := Year mod 19;
  704.     C := Year div 100;
  705.     H := (C - C div 4 - (8 * C + 13) div 25 + 19 * G + 15) mod 30;
  706.     I := H - (H div 28) * (1 - (H div 28) * (29 div (H + 1)) * ((21 - G) div 11));
  707.     J := (Year + Year div 4 + I + 2 - C + C div 4) mod 7;
  708.     L := I - J;
  709.     M := 3 + (L + 40) div 44;
  710.     D := L + 28 - 31 * (M div 4);
  711.     Result := EncodeDate (Year, M, D);
  712.   End;
  713.  
  714. Function GoodFriday (const Year : Word) : TDateTime;
  715.   Begin
  716.     Result := EasterSunday (Year) - 2 * OneDay;
  717.   End;
  718.  
  719. Function AddMilliseconds (const D : TDateTime; const N : Int64) : TDateTime;
  720.   Begin
  721.     Result := D + OneMillisecond * N;
  722.   End;
  723.  
  724. Function AddSeconds (const D : TDateTime; const N : Int64) : TDateTime;
  725.   Begin
  726.     Result := D + OneSecond * N;
  727.   End;
  728.  
  729. Function AddMinutes (const D : TDateTime; const N : Integer) : TDateTime;
  730.   Begin
  731.     Result := D + OneMinute * N;
  732.   End;
  733.  
  734. Function AddHours (const D : TDateTime; const N : Integer) : TDateTime;
  735.   Begin
  736.     Result := D + OneHour * N;
  737.   End;
  738.  
  739. Function AddDays (const D : TDateTime; const N : Integer) : TDateTime;
  740.   Begin
  741.     Result := D + N;
  742.   End;
  743.  
  744. Function AddWeeks (const D : TDateTime; const N : Integer) : TDateTime;
  745.   Begin
  746.     Result := D + N * 7 * OneDay;
  747.   End;
  748.  
  749. Function AddMonths (const D : TDateTime; const N : Integer) : TDateTime;
  750. var Ye, Mo, Da : Word;
  751.     IMo : Integer;
  752.   Begin
  753.     DecodeDate (D, Ye, Mo, Da);
  754.     Inc (Ye, N div 12);
  755.     IMo := Mo;
  756.     Inc (IMo, N mod 12);
  757.     if IMo > 12 then
  758.       begin
  759.         Dec (IMo, 12);
  760.         Inc (Ye);
  761.       end else
  762.       if IMo < 1 then
  763.         begin
  764.           Inc (IMo, 12);
  765.           Dec (Ye);
  766.         end;
  767.     Mo := IMo;
  768.     Da := MinI (Da, DaysInMonth (Ye, Mo));
  769.     Result := EncodeDate (Ye, Mo, Da) + Frac (D);
  770.   End;
  771.  
  772. Function AddYears (const D : TDateTime; const N : Integer) : TDateTime;
  773. var Ye, Mo, Da : Word;
  774.   Begin
  775.     DecodeDate (D, Ye, Mo, Da);
  776.     Inc (Ye, N);
  777.     Da := MinI (Da, DaysInMonth (Ye, Mo));
  778.     Result := EncodeDate (Ye, Mo, Da);
  779.   End;
  780.  
  781.  
  782.  
  783.  
  784. {                                                                              }
  785. { Counting                                                                     }
  786. {                                                                              }
  787. const
  788.   DaysInNonLeapMonth : Array [1..12] of Integer = (
  789.     31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
  790.   CumDaysInNonLeapMonth : Array [1..12] of Integer = (
  791.     0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334);
  792.  
  793. Function DayOfYear (const Ye, Mo, Da : Word) : Integer; overload;
  794.   Begin
  795.     Result := CumDaysInNonLeapMonth [Mo] + Da;
  796.     if (Mo > 2) and IsLeapYear (Ye) then
  797.       Inc (Result);
  798.   End;
  799.  
  800. Function DayOfYear (const D : TDateTime) : Integer; overload;
  801. var Ye, Mo, Da : Word;
  802.   Begin
  803.     DecodeDate (D, Ye, Mo, Da);
  804.     Result := DayOfYear (Ye, Mo, Da);
  805.   End;
  806.  
  807. Function DaysInMonth (const Ye, Mo : Word) : Integer;
  808.   Begin
  809.     Result := DaysInNonLeapMonth [Mo];
  810.     if (Mo = 2) and IsLeapYear (Ye) then
  811.       Inc (Result);
  812.   End;
  813.  
  814. Function DaysInMonth (const D : TDateTime) : Integer;
  815. var Ye, Mo, Da : Word;
  816.   Begin
  817.     DecodeDate (D, Ye, Mo, Da);
  818.     Result := DaysInMonth (Ye, Mo);
  819.   End;
  820.  
  821. Function DaysInYear (const Ye : Word) : Integer;
  822.   Begin
  823.     if IsLeapYear (Ye) then
  824.       Result := 366 else
  825.       Result := 365;
  826.   End;
  827.  
  828. Function DaysInYear (const D : TDateTime) : Integer;
  829. var Ye, Mo, Da : Word;
  830.   Begin
  831.     DecodeDate (D, Ye, Mo, Da);
  832.     Result := DaysInYear (Ye);
  833.   End;
  834.  
  835. Function WeekNumber (const D : TDateTime) : Integer;
  836.   Begin
  837.     Result := (DiffDays (FirstDayOfYear (D), D) div 7) + 1;
  838.   End;
  839.  
  840. { ISO Week functions courtesy of Martin Boonstra (m.boonstra@imn.nl)           }
  841. Function ISOFirstWeekOfYear (const Ye : Integer) : TDateTime;
  842. const WeekStartOffset : Array [1..7] of Integer = (1, 0, -1, -2, -3, 3, 2);
  843.             // Weekday  Start of ISO week 1 is
  844.             //  1 Su          02-01-Year
  845.             //  2 Mo          01-01-Year
  846.             //  3 Tu          31-12-(Year-1)
  847.             //  4 We          30-12-(Year-1)
  848.             //  5 Th          29-12-(Year-1)
  849.             //  6 Fr          04-01-Year
  850.             //  7 Sa          03-01-Year
  851.   Begin
  852.     // Adjust with an offset from 01-01-Ye
  853.     Result := EncodeDate (Ye, 1, 1);
  854.     Result := AddDays (Result, WeekStartOffset [DayOfWeek (Result)]);
  855.   End;
  856.  
  857. Procedure ISOWeekNumber (const D : TDateTime; var WeekNumber, WeekYear : Word);
  858. var Ye : Word;
  859.     ISOFirstWeekOfPrevYear,
  860.     ISOFirstWeekOfCurrYear,
  861.     ISOFirstWeekOfNextYear : TDateTime;
  862.   Begin
  863.     { 3 cases:                                                       }
  864.     {   1: D < ISOFirstWeekOfCurrYear                                }
  865.     {       D lies in week 52/53 of previous year                    }
  866.     {   2: ISOFirstWeekOfCurrYear <= D < ISOFirstWeekOfNextYear      }
  867.     {       D lies in week N (1..52/53) of this year                 }
  868.     {   3: D >= ISOFirstWeekOfNextYear                               }
  869.     {       D lies in week 1 of next year                            }
  870.     Ye := Year (D);
  871.     ISOFirstWeekOfCurrYear := ISOFirstWeekOfYear (Ye);
  872.     if D >= ISOFirstWeekOfCurrYear then
  873.       begin
  874.         ISOFirstWeekOfNextYear := ISOFirstWeekOfYear (Ye + 1);
  875.         if (D < ISOFirstWeekOfNextYear) then
  876.           begin // case 2
  877.             WeekNumber := DiffDays (ISOFirstWeekOfCurrYear, D) div 7 + 1;
  878.             WeekYear := Ye;
  879.           end else
  880.           begin // case 3
  881.             WeekNumber := 1;
  882.             WeekYear := Ye + 1;
  883.           end;
  884.       end else
  885.       begin // case 1
  886.         ISOFirstWeekOfPrevYear := ISOFirstWeekOfYear (Ye - 1);
  887.         WeekNumber := DiffDays (ISOFirstWeekOfPrevYear, D) div 7 + 1;
  888.         WeekYear := Ye - 1;
  889.       end;
  890.   End;
  891.  
  892. Function DateTimeAsISO8601String (const D : TDateTime) : String;
  893.   Begin
  894.     Result := FormatDateTime ('yyyymmdd', D) + 'T' + FormatDateTime ('hh:nn:ss', D);
  895.   End;
  896.  
  897. Function ISO8601StringAsDateTime (const D : String) : TDateTime;
  898. var Date, Time : String;
  899.     Ye, Mo, Da : Integer;
  900.   Begin
  901.     Split (UpperCase (D), 'T', Date, Time);
  902.     Ye := StrToInt (CopyLeft (Date, 4));
  903.     Mo := StrToInt (CopyRange (Date, 5, 6));
  904.     Da := StrToInt (CopyRange (Date, 7, 8));
  905.     Result := EncodeDate (Ye, Mo, Da) + StrToTime (Time);
  906.   End;
  907.  
  908.  
  909.  
  910. {                                                                              }
  911. { Difference                                                                   }
  912. {                                                                              }
  913. Function DiffMilliseconds (const D1, D2 : TDateTime) : Int64;
  914.   Begin
  915.     Result := Trunc ((D2 - D1) / OneMillisecond);
  916.   End;
  917.  
  918. Function DiffSeconds (const D1, D2 : TDateTime) : Integer;
  919.   Begin
  920.     Result := Trunc ((D2 - D1) / OneSecond);
  921.   End;
  922.  
  923. Function DiffMinutes (const D1, D2 : TDateTime) : Integer;
  924.   Begin
  925.     Result := Trunc ((D2 - D1) / OneMinute);
  926.   End;
  927.  
  928. Function DiffHours (const D1, D2 : TDateTime) : Integer;
  929.   Begin
  930.     Result := Trunc ((D2 - D1) / OneHour);
  931.   End;
  932.  
  933. Function DiffDays (const D1, D2 : TDateTime) : Integer;
  934.   Begin
  935.     Result := Trunc (D2 - D1);
  936.   End;
  937.  
  938. Function DiffWeeks (const D1, D2 : TDateTime) : Integer;
  939.   Begin
  940.     Result := Trunc (D2 - D1) div 7;
  941.   End;
  942.  
  943. Function DiffMonths (const D1, D2 : TDateTime) : Integer;
  944. var Ye1, Mo1, Da1 : Word;
  945.     Ye2, Mo2, Da2 : Word;
  946.     ModMonth1,
  947.     ModMonth2     : TDateTime;
  948.   Begin
  949.     DecodeDate (D1, Ye1, Mo1, Da1);
  950.     DecodeDate (D2, Ye2, Mo2, Da2);
  951.     Result := (Ye2 - Ye1) * 12 + (Mo2 - Mo1);
  952.     ModMonth1 := Da1 + Frac (D1);
  953.     ModMonth2 := Da2 + Frac (D2);
  954.     if (D2 > D1) and (ModMonth2 < ModMonth1) then
  955.       Dec (Result);
  956.     if (D2 < D1) and (ModMonth2 > ModMonth1) then
  957.       Inc (Result);
  958.   End;
  959.  
  960. Function DiffYears (const D1, D2 : TDateTime) : Integer;
  961. var Ye1, Mo1, Da1 : Word;
  962.     Ye2, Mo2, Da2 : Word;
  963.     ModYear1,
  964.     ModYear2      : TDateTime;
  965.   Begin
  966.     DecodeDate (D1, Ye1, Mo1, Da1);
  967.     DecodeDate (D2, Ye2, Mo2, Da2);
  968.     Result := Ye2 - Ye1;
  969.     ModYear1 := Mo1 * 31 + Da1 + Frac (Da1);
  970.     ModYear2 := Mo2 * 31 + Da2 + Frac (Da2);
  971.     if (D2 > D1) and (ModYear2 < ModYear1) then
  972.       Dec (Result);
  973.     if (D2 < D1) and (ModYear2 > ModYear1) then
  974.       Inc (Result);
  975.   End;
  976.  
  977.  
  978.  
  979. {                                                                              }
  980. { Conversions                                                                  }
  981. {                                                                              }
  982. Function DateTimeToANSI (const D : TDateTime) : Integer;
  983. var Ye, Mo, Da : Word;
  984.   Begin
  985.     DecodeDate (D, Ye, Mo, Da);
  986.     Result := Ye * 1000 + DayOfYear (Ye, Mo, Da);
  987.   End;
  988.  
  989. Function ANSIToDateTime (const Julian : Integer) : TDateTime;
  990. var DDD, M, Y : Integer;
  991.     I, C, J   : Integer;
  992.   Begin
  993.     DDD := Julian mod 1000;
  994.     if DDD = 0 then
  995.       raise EDateTime.Create ('Invalid ANSI date format');
  996.  
  997.     Y := Julian div 1000;
  998.     M := 0;
  999.     C := 0;
  1000.     For I := 1 to 12 do
  1001.       begin
  1002.         J := DaysInNonLeapMonth [I];
  1003.         if (I = 2) and IsLeapYear (Y) then
  1004.           Inc (J);
  1005.         Inc (C, J);
  1006.         if C >= DDD then
  1007.           begin
  1008.             M := I;
  1009.             break;
  1010.           end;
  1011.       end;
  1012.     if M = 0 then // DDD > end of year
  1013.       raise EDateTime.Create ('Invalid ANSI date format');
  1014.  
  1015.     Result := EncodeDate (Y, M, DDD - C + J);
  1016.   End;
  1017.  
  1018. Function DateTimeToISOInteger (const D : TDateTime) : Integer;
  1019. var Ye, Mo, Da : Word;
  1020.   Begin
  1021.     DecodeDate (D, Ye, Mo, Da);
  1022.     Result := Ye * 10000 + Mo * 100 + Da;
  1023.   End;
  1024.  
  1025. Function DateTimeToISO (const D : TDateTime) : String;
  1026. var Ye, Mo, Da : Word;
  1027.   Begin
  1028.     DecodeDate (D, Ye, Mo, Da);
  1029.     Result := IntToStr (Ye) + '-' +
  1030.               PadLeft (IntToStr (Mo), '0', 2) + '-' +
  1031.               PadLeft (IntToStr (Da), '0', 2);
  1032.   End;
  1033.  
  1034. Function ISOIntegerToDateTime (const ISOInteger : Integer) : TDateTime;
  1035. var Ye, Mo, Da : Word;
  1036.   Begin
  1037.     Ye := ISOInteger div 10000;
  1038.     Mo := (ISOInteger mod 10000) div 100;
  1039.     if (Mo < 1) or (Mo > 12) then
  1040.       raise EDateTime.Create ('Invalid ISO Integer date format');
  1041.     Da := ISOInteger mod 100;
  1042.     if (Da < 1) or (Da > DaysInMonth (Ye, Mo)) then
  1043.       raise EDateTime.Create ('Invalid ISO Integer date format');
  1044.     Result := EncodeDate (Ye, Mo, Da);
  1045.   End;
  1046.  
  1047. Function DateTimeAsElapsedTime (const D : TDateTime) : String;
  1048.   Begin
  1049.     Result := IntToStr (Trunc (D) * 24 + Hour (D)) + ':' +
  1050.               PadLeft (IntToStr (Minute (D)), '0', 2) + ':' +
  1051.               PadLeft (IntToStr (Second (D)), '0', 2);
  1052.   End;
  1053.  
  1054.  
  1055.  
  1056. {                                                                              }
  1057. { Time Zone                                                                    }
  1058. {                                                                              }
  1059.  
  1060. { Returns the GMT bias (in minutes) from the operating system's regional       }
  1061. { settings.                                                                    }
  1062. Function GMTBias : Integer;
  1063. var TZI : TTimeZoneInformation;
  1064.   Begin
  1065.     if GetTimeZoneInformation (TZI) = TIME_ZONE_ID_DAYLIGHT then
  1066.       Result := TZI.DaylightBias else
  1067.       Result := 0;
  1068.     Result := Result + TZI.Bias;
  1069.   End;
  1070.  
  1071. { Converts GMT Time to Local Time                                              }
  1072. Function GMTTimeToLocalTime (const D : TDateTime) : TDateTime;
  1073.   Begin
  1074.     Result := D - GMTBias / (24 * 60);
  1075.   End;
  1076.  
  1077. { Converts Local Time to GMT Time                                              }
  1078. Function LocalTimeToGMTTime (const D : TDateTime) : TDateTime;
  1079.   Begin
  1080.     Result := D + GMTBias / (24 * 60);
  1081.   End;
  1082.  
  1083. { Quickie: Hard coded with a radix of year 2000.                               }
  1084. Function TwoDigitYearToYear (const Y : Integer) : Integer;
  1085.   Begin
  1086.     if Y < 50 then
  1087.       Result := 2000 + Y else
  1088.       Result := 1900 + Y;
  1089.   End;
  1090.  
  1091.  
  1092.  
  1093. {                                                                              }
  1094. { RFC DateTime                                                                 }
  1095. {                                                                              }
  1096. const
  1097.   RFC850DayNames : Array [1..7] of String = (
  1098.       'Sunday', 'Monday', 'Tuesday', 'Wednesday', 'Thursday', 'Friday', 'Saturday');
  1099.   RFC1123DayNames : Array [1..7] of String = (
  1100.       'Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat');
  1101.   RFCMonthNames : Array [1..12] of String = (
  1102.       'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec');
  1103.  
  1104. Function RFC850DayOfWeek (const S : String) : Integer;
  1105. var I : Integer;
  1106.   Begin
  1107.     For I := 1 to 7 do
  1108.       if IsEqualNoCase (RFC850DayNames [I], S) then
  1109.         begin
  1110.           Result := I;
  1111.           exit;
  1112.         end;
  1113.     Result := -1;
  1114.   End;
  1115.  
  1116. Function RFC1123DayOfWeek (const S : String) : Integer;
  1117. var I : Integer;
  1118.   Begin
  1119.     For I := 1 to 7 do
  1120.       if IsEqualNoCase (RFC1123DayNames [I], S) then
  1121.         begin
  1122.           Result := I;
  1123.           exit;
  1124.         end;
  1125.     Result := -1;
  1126.   End;
  1127.  
  1128. Function RFCMonth (const S : String) : Integer;
  1129. var I : Integer;
  1130.   Begin
  1131.     For I := 1 to 12 do
  1132.       if IsEqualNoCase (RFCMonthNames [I], S) then
  1133.         begin
  1134.           Result := I;
  1135.           exit;
  1136.         end;
  1137.     Result := -1;
  1138.   End;
  1139.  
  1140. Function GMTTimeToRFC1123Time (const D : TDateTime; const IncludeSeconds : Boolean) : String;
  1141. var Ho, Mi, Se, Ms : Word;
  1142.   Begin
  1143.     DecodeTime (D, Ho, Mi, Se, Ms);
  1144.     Result := PadLeft (IntToStr (Ho), '0', 2) + ':' +
  1145.               PadLeft (IntToStr (Mi), '0', 2);
  1146.     if IncludeSeconds then
  1147.       Result := Result + ':' + PadLeft (IntToStr (Se), '0', 2);
  1148.     Result := Result + ' GMT';
  1149.   End;
  1150.  
  1151. Function GMTDateTimeToRFC1123DateTime (const D : TDateTime; const IncludeDayOfWeek : Boolean) : String;
  1152. var Ye, Mo, Da : Word;
  1153.   Begin
  1154.     DecodeDate (D, Ye, Mo, Da);
  1155.     if IncludeDayOfWeek then
  1156.       Result := RFC1123DayNames [DayOfWeek (D)] + ', ' else
  1157.       Result := '';
  1158.     Result := Result +
  1159.               PadLeft (IntToStr (Da), '0', 2) + ' ' +
  1160.               RFCMonthNames [Mo] + ' ' +
  1161.               IntToStr (Ye) + ' ' +
  1162.               GMTTimeToRFC1123Time (D, True);
  1163.   End;
  1164.  
  1165. Function DateTimeToRFCDateTime (const D : TDateTime) : String;
  1166.   Begin
  1167.     Result := GMTDateTimeToRFC1123DateTime (LocalTimeToGMTTime (D), True);
  1168.   End;
  1169.  
  1170. Function RFCTimeZoneToGMTBias (const Zone : String) : Integer;
  1171. type
  1172.   TZoneBias = record
  1173.      Zone : String;
  1174.      Bias : Integer;
  1175.    end;
  1176.  
  1177. const
  1178.   SPACE = cs_WhiteSpace;
  1179.   TimeZones = 35;
  1180.   ZoneBias : Array [1..TimeZones] of TZoneBias =
  1181.       ((Zone:'GMT'; Bias:0),       (Zone:'UT';  Bias:0),
  1182.        (Zone:'EST'; Bias:-5*60),   (Zone:'EDT'; Bias:-4*60),
  1183.        (Zone:'CST'; Bias:-6*60),   (Zone:'CDT'; Bias:-5*60),
  1184.        (Zone:'MST'; Bias:-7*60),   (Zone:'MDT'; Bias:-6*60),
  1185.        (Zone:'PST'; Bias:-8*60),   (Zone:'PDT'; Bias:-7*60),
  1186.        (Zone:'Z';   Bias:0),       (Zone:'A';   Bias:-1*60),
  1187.        (Zone:'B';   Bias:-2*60),   (Zone:'C';   Bias:-3*60),
  1188.        (Zone:'D';   Bias:-4*60),   (Zone:'E';   Bias:-5*60),
  1189.        (Zone:'F';   Bias:-6*60),   (Zone:'G';   Bias:-7*60),
  1190.        (Zone:'H';   Bias:-8*60),   (Zone:'I';   Bias:-9*60),
  1191.        (Zone:'K';   Bias:-10*60),  (Zone:'L';   Bias:-11*60),
  1192.        (Zone:'M';   Bias:-12*60),  (Zone:'N';   Bias:1*60),
  1193.        (Zone:'O';   Bias:2*60),    (Zone:'P';   Bias:3*60),
  1194.        (Zone:'Q';   Bias:4*60),    (Zone:'R';   Bias:3*60),
  1195.        (Zone:'S';   Bias:6*60),    (Zone:'T';   Bias:3*60),
  1196.        (Zone:'U';   Bias:8*60),    (Zone:'V';   Bias:3*60),
  1197.        (Zone:'W';   Bias:10*60),   (Zone:'X';   Bias:3*60),
  1198.        (Zone:'Y';   Bias:12*60));
  1199.  
  1200. var
  1201.   S : String;
  1202.   I : Integer;
  1203.  
  1204.   Begin
  1205.     if Zone [1] in ['+', '-'] then // +hhmm format
  1206.       begin
  1207.         S := Trim (Zone, SPACE);
  1208.         Result := MaxI (-23, MinI (23, StrToIntDef (Copy (S, 2, 2), 0))) * 60;
  1209.         S := CopyFrom (S, 4);
  1210.         if S <> '' then
  1211.           Result := Result + MinI (59, MaxI (0, StrToIntDef (S, 0)));
  1212.         if Zone [1] = '-' then
  1213.           Result := -Result;
  1214.       end else
  1215.       begin // named format
  1216.         S := Trim (Zone, SPACE);
  1217.         For I := 1 to TimeZones do
  1218.           if IsEqualNoCase (ZoneBias [I].Zone, S) then
  1219.             begin
  1220.               Result := ZoneBias [I].Bias;
  1221.               exit;
  1222.             end;
  1223.         Result := 0;
  1224.       end;
  1225.   End;
  1226.  
  1227. Function RFCTimeToGMTTime (const S : String) : TDateTime;
  1228. const
  1229.   SPACE = cs_WhiteSpace;
  1230.  
  1231. var
  1232.   I : Integer;
  1233.   T : String;
  1234.   HH, MM, SS : Integer;
  1235.   U : StringArray;
  1236.  
  1237.   Begin
  1238.     U := nil;
  1239.     Result := 0.0;
  1240.     T := Trim (S, SPACE);
  1241.     if T = '' then
  1242.       exit;
  1243.  
  1244.     // Get Zone bias
  1245.     I := Pos (SPACE, T, [foReverse]);
  1246.     if I > 0 then
  1247.       begin
  1248.         Result := Int (RFCTimeZoneToGMTBias (CopyFrom (T, I + 1))) / 1440.0;
  1249.         T := Trim (CopyLeft (T, I - 1), SPACE);
  1250.       end;
  1251.  
  1252.     // Get time
  1253.     U := Split (T, ':');
  1254.     if (Length (U) = 1) and (Length (U [0]) = 4) then
  1255.       begin // old hhmm format
  1256.         HH := StrToIntDef (Copy (U [0], 1, 2), 0);
  1257.         MM := StrToIntDef (Copy (U [0], 3, 2), 0);
  1258.         SS := 0;
  1259.       end else
  1260.     if (Length (U) >= 2) or (Length (U) <= 3) then // hh:mm[:ss] format (RFC1123)
  1261.       begin
  1262.         HH := StrToIntDef (Trim (U [0], SPACE), 0);
  1263.         MM := StrToIntDef (Trim (U [1], SPACE), 0);
  1264.         if Length (U) = 3 then
  1265.           SS := StrToIntDef (Trim (U [2], SPACE), 0) else
  1266.           SS := 0;
  1267.       end else
  1268.       exit;
  1269.  
  1270.     Result := Result + EncodeTime (MaxI (0, MinI (23, HH)), MaxI (0, MinI (59, MM)),
  1271.         MaxI (0, MinI (59, SS)), 0);
  1272.   End;
  1273.  
  1274. Function RFCDateTimeToGMTDateTime (const S : String) : TDateTime;
  1275. const
  1276.   SPACE = cs_WhiteSpace;
  1277.  
  1278. var
  1279.   T, U : String;
  1280.   I : Integer;
  1281.   D, M, Y, DOW : Integer;
  1282.   V, W : StringArray;
  1283.  
  1284.   Begin
  1285.     Result := 0.0;
  1286.  
  1287.     W := nil;
  1288.     T := Trim (S, SPACE);
  1289.  
  1290.     // Extract Day of week
  1291.     I := Pos (SPACE + [','], T);
  1292.     if I > 0 then
  1293.       begin
  1294.         U := CopyLeft (T, I - 1);
  1295.         DOW := RFC850DayOfWeek (U);
  1296.         if DOW = -1 then
  1297.           DOW := RFC1123DayOfWeek (U);
  1298.         if DOW <> -1 then
  1299.           T := Trim (CopyFrom (S, I + 1), SPACE);
  1300.       end;
  1301.  
  1302.     V := Split (T, SPACE);
  1303.     if Length (V) < 3 then
  1304.       exit;
  1305.  
  1306.     if Pos ('-', V [0]) > 0 then // RFC850 date, eg "Sunday, 06-Nov-94 08:49:37 GMT"
  1307.       begin
  1308.         W := Split (V [0], '-');
  1309.         if Length (W) <> 3 then
  1310.           exit;
  1311.         M := RFCMonth (W [1]);
  1312.         if M = -1 then
  1313.           exit;
  1314.         D := StrToIntDef (W [0], 0);
  1315.         Y := StrToIntDef (W [2], 0);
  1316.         if Y < 100 then
  1317.           Y := TwoDigitYearToYear (Y);
  1318.         Result := EncodeDate (Y, M, D) + RFCTimeToGMTTime (V [1] + V [2]);
  1319.         exit;
  1320.       end;
  1321.  
  1322.     M := RFCMonth (V [1]);
  1323.     if M >= 1 then // RFC822 date, eg Sun, 06 Nov 1994 08:49:37 GMT
  1324.       begin
  1325.         D := StrToIntDef (V [0], 0);
  1326.         Y := StrToIntDef (V [2], 0);
  1327.         Result := EncodeDate (Y, M, D);
  1328.         if Length (V) = 4 then
  1329.           Result := Result + RFCTimeToGMTTime (V [3]) else
  1330.           if Length (V) >= 5 then
  1331.             Result := Result + RFCTimeToGMTTime (V [3] + ' ' + V [4]);
  1332.         exit;
  1333.       end;
  1334.  
  1335.     M := RFCMonth (V [0]);
  1336.     if M >= 1 then // ANSI C asctime() format, eg "Sun Nov  6 08:49:37 1994"
  1337.       begin
  1338.         D := StrToIntDef (V [1], 0);
  1339.         Y := StrToIntDef (V [3], 0);
  1340.         Result := EncodeDate (Y, M, D) + RFCTimeToGMTTime (V [2]);
  1341.       end;
  1342.   End;
  1343.  
  1344. Function RFCDateTimeToDateTime (const S : String) : TDateTime;
  1345.   Begin
  1346.     Result := GMTTimeToLocalTime (RFCDateTimeToGMTDateTime (S));
  1347.   End;
  1348.  
  1349. Function NowAsRFCDateTime : String;
  1350.   Begin
  1351.     Result := DateTimeToRFCDateTime (Now);
  1352.   End;
  1353.  
  1354.  
  1355.  
  1356. {                                                                              }
  1357. { High-precision timing                                                        }
  1358. {                                                                              }
  1359. var
  1360.   HighPrecisionTimerInit   : Boolean = False;
  1361.   HighPrecisionMilliFactor : Int64;  // millisecond factor
  1362.   HighPrecisionMicroFactor : Int64;  // microsecond factor
  1363.  
  1364. Function CPUClockFrequency : Int64;
  1365.   Begin
  1366.     if not QueryPerformanceFrequency (Result) then
  1367.       raise EDateTime.Create ('High resolution timer not available');
  1368.   End;
  1369.  
  1370. Procedure InitHighPrecisionTimer;
  1371.   Begin
  1372.     HighPrecisionMilliFactor := CPUClockFrequency;
  1373.     HighPrecisionMilliFactor := HighPrecisionMilliFactor div 1000;
  1374.     HighPrecisionMicroFactor := CPUClockFrequency;
  1375.     HighPrecisionMicroFactor := HighPrecisionMicroFactor div 1000000;
  1376.     HighPrecisionTimerInit := True;
  1377.   End;
  1378.  
  1379. Function StartTimer : Int64;
  1380.   Begin
  1381.     if not HighPrecisionTimerInit then
  1382.       InitHighPrecisionTimer;
  1383.     QueryPerformanceCounter (Result);
  1384.   End;
  1385.  
  1386. Function MillisecondsElapsed (const Timer : Int64; const TimerRunning : Boolean = True) : Integer;
  1387. var I : Int64;
  1388.   Begin
  1389.     if not HighPrecisionTimerInit then
  1390.       InitHighPrecisionTimer;
  1391.     if not TimerRunning then
  1392.       Result := Timer div HighPrecisionMilliFactor else
  1393.       begin
  1394.         QueryPerformanceCounter (I);
  1395.         {$IFDEF DELPHI5}
  1396.         {$Q-}
  1397.         Result := (I - Timer) div HighPrecisionMilliFactor;
  1398.         {$ELSE}
  1399.         Result := Int64 (I - Timer) div HighPrecisionMilliFactor;
  1400.         {$ENDIF}
  1401.       end;
  1402.   End;
  1403.  
  1404. Function MicrosecondsElapsed (const Timer : Int64; const TimerRunning : Boolean = True) : Integer;
  1405. var I : Int64;
  1406.   Begin
  1407.     if not HighPrecisionTimerInit then
  1408.       InitHighPrecisionTimer;
  1409.     if not TimerRunning then
  1410.       Result := Timer div HighPrecisionMicroFactor else
  1411.       begin
  1412.         QueryPerformanceCounter (I);
  1413.         {$IFDEF DELPHI5}
  1414.         {$Q-}
  1415.         Result := (I - Timer) div HighPrecisionMicroFactor;
  1416.         {$ELSE}
  1417.         Result := Int64 (I - Timer) div HighPrecisionMicroFactor;
  1418.         {$ENDIF}
  1419.       end;
  1420.   End;
  1421.  
  1422. Procedure StopTimer (var Timer : Int64);
  1423. var I : Int64;
  1424.   Begin
  1425.     QueryPerformanceCounter (I);
  1426.     {$IFDEF DELPHI5}
  1427.     {$Q-}
  1428.     Timer := I - Timer;
  1429.     {$ELSE}
  1430.     Timer := Int64 (I - Timer);
  1431.     {$ENDIF}
  1432.   End;
  1433.  
  1434. Procedure ResumeTimer (var StoppedTimer : Int64);
  1435.   Begin
  1436.     StoppedTimer := Int64 (StartTimer - StoppedTimer);
  1437.   End;
  1438.  
  1439. Function StoppedTimer : Int64;
  1440.   Begin
  1441.     if not HighPrecisionTimerInit then
  1442.       InitHighPrecisionTimer;
  1443.     Result := 0;
  1444.   End;
  1445.  
  1446. Function ElapsedTimer (const Milliseconds : Integer) : THPTimer;
  1447. var I : Int64;
  1448.   Begin
  1449.     if not HighPrecisionTimerInit then
  1450.       InitHighPrecisionTimer;
  1451.     QueryPerformanceCounter (I);
  1452.     {$IFDEF DELPHI5}
  1453.     {$Q-}
  1454.     Result := I - (Milliseconds * HighPrecisionMilliFactor);
  1455.     {$ELSE}
  1456.     Result := Int64 (I - (Milliseconds * HighPrecisionMilliFactor));
  1457.     {$ENDIF}
  1458.   End;
  1459.  
  1460. Procedure DelayMicroSeconds (const MicroSeconds : Integer);
  1461. var I, J, F : Int64;
  1462.   Begin
  1463.     if MicroSeconds <= 0 then
  1464.       exit;
  1465.     if not HighPrecisionTimerInit then
  1466.       InitHighPrecisionTimer;
  1467.     if not QueryPerformanceCounter (I) then
  1468.       exit;
  1469.     {$IFDEF DELPHI5}
  1470.     {$Q-}
  1471.     F := MicroSeconds * HighPrecisionMicroFactor;
  1472.     Repeat
  1473.       QueryPerformanceCounter (J);
  1474.       J := J - I;
  1475.     Until J >= F;
  1476.     {$ELSE}
  1477.     F := Int64 (MicroSeconds * HighPrecisionMicroFactor);
  1478.     Repeat
  1479.       QueryPerformanceCounter (J);
  1480.     Until Int64 (J - I) >= F;
  1481.     {$ENDIF}
  1482.   End;
  1483.  
  1484.  
  1485.  
  1486. {                                                                              }
  1487. { Self testing code                                                            }
  1488. {                                                                              }
  1489. Procedure SelfTest;
  1490. var A, B : TDateTime;
  1491.     Ye, Mo, Da, Ho, Mi, Se, Ms : Word;
  1492.     Ye2, Mo2, Da2, Ho2, Mi2, Se2, Ms2 : Word;
  1493.     S : String;
  1494.   Begin
  1495.     Ho := 7;
  1496.     Mi := 10;
  1497.     Da := 8;
  1498.     Ms := 3;
  1499.     For Ye := 1999 to 2001 do
  1500.       For Mo := 1 to 12 do
  1501.         For Se := 0 to 59 do
  1502.           begin
  1503.             A := EncodeDateTime (Ye, Mo, Da, Ho, Mi, Se, Ms);
  1504.             DecodeDateTime (A, Ye2, Mo2, Da2, Ho2, Mi2, Se2, Ms2);
  1505.             Assert (Ye = Ye2, 'DecodeDate');
  1506.             Assert (Mo = Mo2, 'DecodeDate');
  1507.             Assert (Da = Da2, 'DecodeDate');
  1508.             Assert (Ho = Ho2, 'DecodeDate');
  1509.             Assert (Mi = Mi2, 'DecodeDate');
  1510.             Assert (Se = Se2, 'DecodeDate');
  1511.             Assert (Ms = Ms2, 'DecodeDate');
  1512.             Assert (Year (A) = Ye, 'Year');
  1513.             Assert (Month (A) = Mo, 'Month');
  1514.             Assert (Day (A) = Da, 'Day');
  1515.             Assert (Hour (A) = Ho, 'Hour');
  1516.             Assert (Minute (A) = Mi, 'Minute');
  1517.             Assert (Second (A) = Se, 'Second');
  1518.             Assert (Millisecond (A) = Ms, 'Millisecond');
  1519.           end;
  1520.     A := EncodeDateTime (2002, 05, 31, 07, 04, 01, 02);
  1521.     Assert (IsEqual (A, 2002, 05, 31), 'IsEqual');
  1522.     Assert (IsEqual (A, 07, 04, 01, 02), 'IsEqual');
  1523.     Assert (IsFriday (A), 'IsFriday');
  1524.     Assert (not IsMonday (A), 'IsMonday');
  1525.     A := AddWeeks (A, 2);
  1526.     Assert (IsEqual (A, 2002, 06, 14), 'AddWeeks');
  1527.     A := AddHours (A, 2);
  1528.     Assert (IsEqual (A, 09, 04, 01, 02), 'AddHours');
  1529.     A := EncodeDateTime (2004, 03, 01, 0, 0, 0, 0);
  1530.     Assert (DayOfYear (A) = 61, 'DayOfYear');
  1531.     Assert (DaysInMonth (2004, 02) = 29, 'DaysInMonth');
  1532.     Assert (DaysInMonth (2005, 02) = 28, 'DaysInMonth');
  1533.     Assert (DaysInMonth (2001, 01) = 31, 'DaysInMonth');
  1534.     Assert (DaysInYear (2000) = 366, 'DaysInYear');
  1535.     Assert (DaysInYear (2004) = 366, 'DaysInYear');
  1536.     Assert (DaysInYear (2006) = 365, 'DaysInYear');
  1537.     A := EncodeDateTime (2001, 09, 02, 12, 11, 10, 0);
  1538.     S := GMTDateTimeToRFC1123DateTime (A, True);
  1539.     Assert (S = 'Sun, 02 Sep 2001 12:11:10 GMT', 'GMTDateTimeToRFC1123DateTime');
  1540.     B := RFCDateTimeToGMTDateTime (S);
  1541.     Assert (IsEqual (A, B), 'RFCDateTimeToGMTDateTime');
  1542.   End;
  1543.  
  1544.  
  1545.  
  1546. end.
  1547.  
  1548.