dati.inc 48 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605
  1. {
  2. *********************************************************************
  3. Copyright (C) 1997, 1998 Gertjan Schouten
  4. See the file COPYING.FPC, included in this distribution,
  5. for details about the copyright.
  6. This program is distributed in the hope that it will be useful,
  7. but WITHOUT ANY WARRANTY; without even the implied warranty of
  8. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  9. **********************************************************************
  10. System Utilities For Free Pascal
  11. }
  12. {==============================================================================}
  13. { internal functions }
  14. {==============================================================================}
  15. Function DoEncodeDate(Year, Month, Day: Word): longint;
  16. Var
  17. D : TDateTime;
  18. begin
  19. If TryEncodeDate(Year,Month,Day,D) then
  20. Result:=Trunc(D)
  21. else
  22. Result:=0;
  23. end;
  24. function DoEncodeTime(Hour, Minute, Second, MilliSecond: word): TDateTime;
  25. begin
  26. If not TryEncodeTime(Hour,Minute,Second,MilliSecond,Result) then
  27. Result:=0;
  28. end;
  29. {==============================================================================}
  30. { Public functions }
  31. {==============================================================================}
  32. { ComposeDateTime converts a Date and a Time into one TDateTime }
  33. function ComposeDateTime(Date,Time : TDateTime) : TDateTime;
  34. begin
  35. if Date < 0 then Result := trunc(Date) - Abs(frac(Time))
  36. else Result := trunc(Date) + Abs(frac(Time));
  37. end;
  38. { DateTimeToTimeStamp converts DateTime to a TTimeStamp }
  39. function DateTimeToTimeStamp(DateTime: TDateTime): TTimeStamp;
  40. Var
  41. D : Double;
  42. begin
  43. D:=DateTime * Single(MSecsPerDay);
  44. if D<0 then
  45. D:=D-0.5
  46. else
  47. D:=D+0.5;
  48. result.Time := Abs(Trunc(D)) Mod MSecsPerDay;
  49. result.Date := DateDelta + Trunc(D) div MSecsPerDay;
  50. end;
  51. { TimeStampToDateTime converts TimeStamp to a TDateTime value }
  52. function TimeStampToDateTime(const TimeStamp: TTimeStamp): TDateTime;
  53. begin
  54. Result := ComposeDateTime(TimeStamp.Date - DateDelta,TimeStamp.Time / MSecsPerDay)
  55. end;
  56. { MSecsToTimeStamp }
  57. function MSecsToTimeStamp(MSecs: comp): TTimeStamp;
  58. begin
  59. result.Date := Trunc(msecs / msecsperday);
  60. msecs:= msecs-comp(result.date)*msecsperday;
  61. result.Time := Round(MSecs);
  62. end ;
  63. { TimeStampToMSecs }
  64. function TimeStampToMSecs(const TimeStamp: TTimeStamp): comp;
  65. begin
  66. result := TimeStamp.Time + comp(timestamp.date)*msecsperday;
  67. end ;
  68. Function TryEncodeDate(Year,Month,Day : Word; Out Date : TDateTime) : Boolean;
  69. var
  70. c, ya: cardinal;
  71. begin
  72. Result:=(Year>0) and (Year<10000) and
  73. (Month in [1..12]) and
  74. (Day>0) and (Day<=MonthDays[IsleapYear(Year),Month]);
  75. If Result then
  76. begin
  77. if month > 2 then
  78. Dec(Month,3)
  79. else
  80. begin
  81. Inc(Month,9);
  82. Dec(Year);
  83. end;
  84. c:= Year DIV 100;
  85. ya:= Year - 100*c;
  86. Date := (146097*c) SHR 2 + (1461*ya) SHR 2 + (153*cardinal(Month)+2) DIV 5 + cardinal(Day);
  87. // Note that this line can't be part of the line above, since TDateTime is
  88. // signed and c and ya are not
  89. Date := Date - 693900;
  90. end
  91. end;
  92. function TryEncodeTime(Hour, Min, Sec, MSec:word; Out Time : TDateTime) : boolean;
  93. begin
  94. Result:=(Hour<24) and (Min<60) and (Sec<60) and (MSec<1000);
  95. If Result then
  96. Time:=TDateTime(cardinal(Hour)*3600000+cardinal(Min)*60000+cardinal(Sec)*1000+MSec)/MSecsPerDay;
  97. end;
  98. { EncodeDate packs three variables Year, Month and Day into a
  99. TDateTime value the result is the number of days since 12/30/1899 }
  100. function EncodeDate(Year, Month, Day: word): TDateTime;
  101. begin
  102. If Not TryEncodeDate(Year,Month,Day,Result) then
  103. Raise EConvertError.CreateFmt('%d-%d-%d is not a valid date specification',
  104. [Year,Month,Day]);
  105. end;
  106. { EncodeTime packs four variables Hour, Minute, Second and MilliSecond into
  107. a TDateTime value }
  108. function EncodeTime(Hour, Minute, Second, MilliSecond:word):TDateTime;
  109. begin
  110. If not TryEncodeTime(Hour,Minute,Second,MilliSecond,Result) then
  111. Raise EConvertError.CreateFmt('%d:%d:%d.%d is not a valid time specification',
  112. [Hour,Minute,Second,MilliSecond]);
  113. end;
  114. { DecodeDate unpacks the value Date into three values:
  115. Year, Month and Day }
  116. procedure DecodeDate(Date: TDateTime; out Year, Month, Day: word);
  117. var
  118. ly,ld,lm,j : cardinal;
  119. begin
  120. if Date <= -datedelta then // If Date is before 1-1-1 then return 0-0-0
  121. begin
  122. Year := 0;
  123. Month := 0;
  124. Day := 0;
  125. end
  126. else
  127. begin
  128. if Date>0 then
  129. Date:=Date+1/(msecsperday*2)
  130. else
  131. Date:=Date-1/(msecsperday*2);
  132. if Date>MaxDateTime then
  133. Date:=MaxDateTime;
  134. // Raise EConvertError.CreateFmt('%f is not a valid TDatetime encoding, maximum value is %f.',[Date,MaxDateTime]);
  135. j := pred((longint(Trunc(System.Int(Date))) + 693900) SHL 2);
  136. ly:= j DIV 146097;
  137. j:= j - 146097 * cardinal(ly);
  138. ld := j SHR 2;
  139. j:=(ld SHL 2 + 3) DIV 1461;
  140. ld:= (cardinal(ld) SHL 2 + 7 - 1461*j) SHR 2;
  141. lm:=(5 * ld-3) DIV 153;
  142. ld:= (5 * ld +2 - 153*lm) DIV 5;
  143. ly:= 100 * cardinal(ly) + j;
  144. if lm < 10 then
  145. inc(lm,3)
  146. else
  147. begin
  148. dec(lm,9);
  149. inc(ly);
  150. end;
  151. year:=ly;
  152. month:=lm;
  153. day:=ld;
  154. end;
  155. end;
  156. function DecodeDateFully(const DateTime: TDateTime; out Year, Month, Day, DOW: Word): Boolean;
  157. begin
  158. DecodeDate(DateTime,Year,Month,Day);
  159. DOW:=DayOfWeek(DateTime);
  160. Result:=IsLeapYear(Year);
  161. end;
  162. { DecodeTime unpacks Time into four values:
  163. Hour, Minute, Second and MilliSecond }
  164. procedure DecodeTime(Time: TDateTime; out Hour, Minute, Second, MilliSecond: word);
  165. Var
  166. l : cardinal;
  167. begin
  168. l := DateTimeToTimeStamp(Time).Time;
  169. Hour := l div 3600000;
  170. l := l mod 3600000;
  171. Minute := l div 60000;
  172. l := l mod 60000;
  173. Second := l div 1000;
  174. l := l mod 1000;
  175. MilliSecond := l;
  176. end;
  177. { DateTimeToSystemTime converts DateTime value to SystemTime }
  178. procedure DateTimeToSystemTime(DateTime: TDateTime; out SystemTime: TSystemTime);
  179. begin
  180. DecodeDateFully(DateTime, SystemTime.Year, SystemTime.Month, SystemTime.Day,SystemTime.DayOfWeek);
  181. DecodeTime(DateTime, SystemTime.Hour, SystemTime.Minute, SystemTime.Second, SystemTime.MilliSecond);
  182. Dec(SystemTime.DayOfWeek);
  183. end ;
  184. { SystemTimeToDateTime converts SystemTime to a TDateTime value }
  185. function SystemTimeToDateTime(const SystemTime: TSystemTime): TDateTime;
  186. begin
  187. result := ComposeDateTime(DoEncodeDate(SystemTime.Year, SystemTime.Month, SystemTime.Day),
  188. DoEncodeTime(SystemTime.Hour, SystemTime.Minute, SystemTime.Second, SystemTime.MilliSecond));
  189. end ;
  190. { DayOfWeek returns the Day of the week (sunday is day 1) }
  191. function DayOfWeek(DateTime: TDateTime): integer;
  192. begin
  193. Result := 1 + ((Trunc(DateTime) - 1) mod 7);
  194. If (Result<=0) then
  195. Inc(Result,7);
  196. end;
  197. { Date returns the current Date }
  198. function Date: TDateTime;
  199. var
  200. SystemTime: TSystemTime;
  201. begin
  202. GetLocalTime(SystemTime);
  203. result := DoEncodeDate(SystemTime.Year, SystemTime.Month, SystemTime.Day);
  204. end ;
  205. { Time returns the current Time }
  206. function Time: TDateTime;
  207. var
  208. SystemTime: TSystemTime;
  209. begin
  210. GetLocalTime(SystemTime);
  211. Result := DoEncodeTime(SystemTime.Hour,SystemTime.Minute,SystemTime.Second,SystemTime.MilliSecond);
  212. end ;
  213. { Now returns the current Date and Time }
  214. function Now: TDateTime;
  215. var
  216. SystemTime: TSystemTime;
  217. begin
  218. GetLocalTime(SystemTime);
  219. result := systemTimeToDateTime(SystemTime);
  220. end;
  221. { NowUTC returns the current UTC Date and Time if available on the OS. If not, local date is returned }
  222. function NowUTC: TDateTime;
  223. var
  224. SystemTime: TSystemTime;
  225. begin
  226. if not GetUniversalTime(SystemTime) then
  227. GetLocalTime(SystemTime);
  228. result := systemTimeToDateTime(SystemTime);
  229. end;
  230. { IncMonth increments DateTime with NumberOfMonths months,
  231. NumberOfMonths can be less than zero }
  232. function IncMonth(const DateTime: TDateTime; NumberOfMonths: integer = 1 ): TDateTime;
  233. var
  234. Year, Month, Day : word;
  235. begin
  236. DecodeDate(DateTime, Year, Month, Day);
  237. IncAMonth(Year, Month, Day, NumberOfMonths);
  238. result := ComposeDateTime(DoEncodeDate(Year, Month, Day), DateTime);
  239. end ;
  240. { IncAMonth is the same as IncMonth, but operates on decoded date }
  241. procedure IncAMonth(var Year, Month, Day: Word; NumberOfMonths: Integer = 1);
  242. var
  243. TempMonth, S: Integer;
  244. begin
  245. If NumberOfMonths>=0 then
  246. s:=1
  247. else
  248. s:=-1;
  249. inc(Year,(NumberOfMonths div 12));
  250. TempMonth:=Month+(NumberOfMonths mod 12)-1;
  251. if (TempMonth>11) or
  252. (TempMonth<0) then
  253. begin
  254. Dec(TempMonth, S*12);
  255. Inc(Year, S);
  256. end;
  257. Month:=TempMonth+1; { Months from 1 to 12 }
  258. If (Day>MonthDays[IsLeapYear(Year)][Month]) then
  259. Day:=MonthDays[IsLeapYear(Year)][Month];
  260. end;
  261. { IsLeapYear returns true if Year is a leap year }
  262. function IsLeapYear(Year: Word): boolean;
  263. begin
  264. Result := (Year mod 4 = 0) and ((Year mod 100 <> 0) or (Year mod 400 = 0));
  265. end;
  266. { DateToStr returns a string representation of Date using ShortDateFormat }
  267. function DateToStr(Date: TDateTime): string;
  268. begin
  269. DateTimeToString(Result, 'ddddd', Date);
  270. end ;
  271. function DateToStr(Date: TDateTime; const FormatSettings: TFormatSettings): string;
  272. begin
  273. DateTimeToString(result, FormatSettings.ShortDateFormat, Date, FormatSettings);
  274. end;
  275. { TimeToStr returns a string representation of Time using LongTimeFormat }
  276. function TimeToStr(Time: TDateTime): string;
  277. begin
  278. DateTimeToString(Result, 'tt', Time);
  279. end ;
  280. function TimeToStr(Time: TDateTime; const FormatSettings: TFormatSettings): string;
  281. begin
  282. DateTimeToString(Result, FormatSettings.LongTimeFormat, Time, FormatSettings);
  283. end;
  284. { DateTimeToStr returns a string representation of DateTime using ShortDateFormat and LongTimeFormat }
  285. Const
  286. DateTimeToStrFormat : Array[Boolean] of string = ('c','f');
  287. function DateTimeToStr(DateTime: TDateTime; ForceTimeIfZero : Boolean = False): string;
  288. begin
  289. DateTimeToString(Result, DateTimeToStrFormat[ForceTimeIfZero], DateTime)
  290. end ;
  291. function DateTimeToStr(DateTime: TDateTime; const FormatSettings: TFormatSettings; ForceTimeIfZero : Boolean = False): string;
  292. begin
  293. DateTimeToString(Result, DateTimeToStrFormat[ForceTimeIfZero], DateTime ,FormatSettings);
  294. end;
  295. { StrToDate converts the string S to a TDateTime value
  296. if S does not represent a valid date value
  297. an EConvertError will be raised }
  298. function IntStrToDate(Out ErrorMsg : AnsiString; const S: PChar; Len : integer; const useformat : string; const defs:TFormatSettings; separator : char = #0): TDateTime;
  299. const SInvalidDateFormat = '"%s" is not a valid date format';
  300. procedure FixErrorMsg(const errm :ansistring;const errmarg : ansistring);
  301. begin
  302. errormsg:=format(errm,[errmarg]);
  303. end;
  304. var
  305. df:string;
  306. d,m,y,ly:integer;
  307. n,i:longint;
  308. c:word;
  309. dp,mp,yp,which : Byte;
  310. s1:string;
  311. values:array[0..3] of longint;
  312. LocalTime:tsystemtime;
  313. YearMoreThenTwoDigits : boolean;
  314. begin
  315. ErrorMsg:=''; Result:=0;
  316. While (Len>0) and (S[Len-1] in [' ',#8,#9,#10,#12,#13]) do
  317. Dec(len);
  318. if (Len=0) then
  319. begin
  320. FixErrorMsg(SInvalidDateFormat,'');
  321. exit;
  322. end;
  323. YearMoreThenTwoDigits := False;
  324. if separator = #0 then
  325. separator := defs.DateSeparator;
  326. df := UpperCase(useFormat);
  327. { Determine order of D,M,Y }
  328. yp:=0;
  329. mp:=0;
  330. dp:=0;
  331. Which:=0;
  332. i:=0;
  333. while (i<Length(df)) and (Which<3) do
  334. begin
  335. inc(i);
  336. Case df[i] of
  337. 'Y' :
  338. if yp=0 then
  339. begin
  340. Inc(Which);
  341. yp:=which;
  342. end;
  343. 'M' :
  344. if mp=0 then
  345. begin
  346. Inc(Which);
  347. mp:=which;
  348. end;
  349. 'D' :
  350. if dp=0 then
  351. begin
  352. Inc(Which);
  353. dp:=which;
  354. end;
  355. end;
  356. end;
  357. for i := 1 to 3 do
  358. values[i] := 0;
  359. s1 := '';
  360. n := 0;
  361. dec(len);
  362. for i := 0 to len do
  363. begin
  364. if s[i] in ['0'..'9'] then
  365. s1 := s1 + s[i];
  366. { space can be part of the shortdateformat, and is defaultly in slovak
  367. windows, therefor it shouldn't be taken as separator (unless so specified)
  368. and ignored }
  369. if (Separator <> ' ') and (s[i] = ' ') then
  370. Continue;
  371. if (s[i] = separator) or ((i = len) and (s[i] in ['0'..'9'])) then
  372. begin
  373. inc(n);
  374. if n>3 then
  375. begin
  376. FixErrorMsg(SInvalidDateFormat,s);
  377. exit;
  378. end;
  379. // Check if the year has more then two digits (if n=yp, then we are evaluating the year.)
  380. if (n=yp) and (length(s1)>2) then YearMoreThenTwoDigits := True;
  381. val(s1, values[n], c);
  382. // Writeln(s1,'->',values[n]);
  383. if c<>0 then
  384. begin
  385. FixErrorMsg(SInvalidDateFormat,s);
  386. Exit;
  387. end;
  388. s1 := '';
  389. end
  390. else if not (s[i] in ['0'..'9']) then
  391. begin
  392. FixErrorMsg(SInvalidDateFormat,s);
  393. Exit;
  394. end;
  395. end ;
  396. if (Which<3) and (N>Which) then
  397. begin
  398. FixErrorMsg(SInvalidDateFormat,s);
  399. Exit;
  400. end;
  401. // Fill in values.
  402. getLocalTime(LocalTime);
  403. ly := LocalTime.Year;
  404. for I:=1 to 3 do
  405. if values[i]>high(Word) then
  406. begin
  407. errormsg:='Invalid date';
  408. exit;
  409. end;
  410. If N=3 then
  411. begin
  412. y:=values[yp];
  413. m:=values[mp];
  414. d:=values[dp];
  415. end
  416. Else
  417. begin
  418. Y:=ly;
  419. If n<2 then
  420. begin
  421. d:=values[1];
  422. m := LocalTime.Month;
  423. end
  424. else
  425. If dp<mp then
  426. begin
  427. d:=values[1];
  428. m:=values[2];
  429. end
  430. else
  431. begin
  432. d:=values[2];
  433. m:=values[1];
  434. end;
  435. end;
  436. if (y >= 0) and (y < 100) and not YearMoreThenTwoDigits then
  437. begin
  438. ly := ly - defs.TwoDigitYearCenturyWindow;
  439. Inc(Y, ly div 100 * 100);
  440. if (defs.TwoDigitYearCenturyWindow > 0) and (Y < ly) then
  441. Inc(Y, 100);
  442. end;
  443. if not TryEncodeDate(y, m, d, result) then
  444. errormsg:='Invalid date';
  445. end;
  446. function StrToDate(const S: PChar; Len : integer; const useformat : string; separator : char = #0): TDateTime;
  447. Var
  448. MSg : AnsiString;
  449. begin
  450. Result:=IntStrToDate(Msg,S,Len,useFormat,DefaultFormatSettings,Separator);
  451. If (Msg<>'') then
  452. Raise EConvertError.Create(Msg);
  453. end;
  454. function StrToDate(const S: string; FormatSettings: TFormatSettings): TDateTime;
  455. var
  456. Msg: AnsiString;
  457. begin
  458. Result:=IntStrToDate(Msg,PChar(S),Length(S),FormatSettings.ShortDateFormat,FormatSettings);
  459. if Msg<>'' then
  460. raise EConvertError.Create(Msg);
  461. end;
  462. function StrToDate(const S: ShortString; const useformat : string; separator : char = #0): TDateTime;
  463. begin
  464. // S[1] always exists for shortstring. Length 0 will trigger an error.
  465. result := StrToDate(@S[1],Length(s),UseFormat,separator);
  466. end;
  467. function StrToDate(const S: AnsiString; const useformat : string; separator : char = #0): TDateTime;
  468. begin
  469. result := StrToDate(PChar(S),Length(s),UseFormat,separator);
  470. end;
  471. function StrToDate(const S: ShortString; separator : char): TDateTime;
  472. begin
  473. // S[1] always exists for shortstring. Length 0 will trigger an error.
  474. result := StrToDate(@S[1],Length(s),DefaultFormatSettings.ShortDateFormat,separator)
  475. end;
  476. function StrToDate(const S: ShortString): TDateTime;
  477. begin
  478. // S[1] always exists for shortstring. Length 0 will trigger an error.
  479. result := StrToDate(@S[1],Length(s),DefaultFormatSettings.ShortDateFormat,#0);
  480. end;
  481. function StrToDate(const S: AnsiString; separator : char): TDateTime;
  482. begin
  483. result := StrToDate(Pchar(S),Length(s),DefaultFormatSettings.ShortDateFormat,separator)
  484. end;
  485. function StrToDate(const S: AnsiString): TDateTime;
  486. begin
  487. result := StrToDate(Pchar(S),Length(s),DefaultFormatSettings.ShortDateFormat,#0);
  488. end;
  489. { StrToTime converts the string S to a TDateTime value
  490. if S does not represent a valid time value an
  491. EConvertError will be raised }
  492. function IntStrToTime(Out ErrorMsg : AnsiString; const S: PChar; Len : integer;const defs:TFormatSettings; separator : char = #0): TDateTime;
  493. const
  494. AMPM_None = 0;
  495. AMPM_AM = 1;
  496. AMPM_PM = 2;
  497. tiHour = 0;
  498. tiMin = 1;
  499. tiSec = 2;
  500. tiMSec = 3;
  501. type
  502. TTimeValues = array[tiHour..tiMSec] of Word;
  503. var
  504. AmPm: integer;
  505. TimeValues: TTimeValues;
  506. function StrPas(Src : PChar; len: integer = 0) : ShortString;
  507. begin
  508. //this is unsafe for len > 255, it will trash memory (I tested this)
  509. //reducing it is safe, since whenever we use this a string > 255 is invalid anyway
  510. if len > 255 then len := 255;
  511. SetLength(Result, len);
  512. move(src[0],result[1],len);
  513. end;
  514. function SplitElements(out TimeValues: TTimeValues; out AmPm: Integer): Boolean;
  515. //Strict version. It does not allow #32 as Separator, it will treat it as whitespace always
  516. const
  517. Digits = ['0'..'9'];
  518. var
  519. Cur, Offset, ElemLen, Err, TimeIndex, FirstSignificantDigit: Integer;
  520. Value: Word;
  521. DigitPending, MSecPending: Boolean;
  522. AmPmStr: ShortString;
  523. CurChar: Char;
  524. begin
  525. Result := False;
  526. AmPm := AMPM_None; //No Am or PM in string found yet
  527. MSecPending := False;
  528. TimeIndex := 0; //indicating which TTimeValue must be filled next
  529. FillChar(TimeValues, SizeOf(TTimeValues), 0);
  530. Cur := 0;
  531. //skip leading blanks
  532. While (Cur < Len) and (S[Cur] =#32) do Inc(Cur);
  533. Offset := Cur;
  534. //First non-blank cannot be Separator or DecimalSeparator
  535. if (Cur > Len - 1) or (S[Cur] = Separator) or (S[Cur] = defs.Decimalseparator) then Exit;
  536. DigitPending := (S[Cur] in Digits);
  537. While (Cur < Len) do
  538. begin
  539. //writeln;
  540. //writeln('Main While loop: Cur = ',Cur,' S[Cur] = "',S[Cur],'" Len = ',Len);
  541. CurChar := S[Cur];
  542. if CurChar in Digits then
  543. begin//Digits
  544. //HH, MM, SS, or Msec?
  545. //writeln('Digit');
  546. //Digits are only allowed after starting Am/PM or at beginning of string or after Separator
  547. //and TimeIndex must be <= tiMSec
  548. //Uncomment "or (#32 = Separator)" and it will allllow #32 as separator
  549. if (not (DigitPending {or (#32 = Separator)})) or (TimeIndex > tiMSec) then Exit;
  550. OffSet := Cur;
  551. if (CurChar <> '0') then FirstSignificantDigit := OffSet else FirstSignificantDigit := -1;
  552. while (Cur < Len -1) and (S[Cur + 1] in Digits) do
  553. begin
  554. //Mark first Digit that is not '0'
  555. if (FirstSignificantDigit = -1) and (S[Cur] <> '0') then FirstSignificantDigit := Cur;
  556. Inc(Cur);
  557. end;
  558. if (FirstSignificantDigit = -1) then FirstSignificantDigit := Cur;
  559. ElemLen := 1 + Cur - FirstSignificantDigit;
  560. //writeln(' S[FirstSignificantDigit] = ',S[FirstSignificantDigit], ' S[Cur] = ',S[Cur],' ElemLen = ',ElemLen,' -> ', StrPas(S + Offset, ElemLen));
  561. //writeln(' Cur = ',Cur);
  562. //this way we know that Val() will never overflow Value !
  563. if (ElemLen <= 2) or ((ElemLen <= 3) and (TimeIndex = tiMSec) ) then
  564. begin
  565. Val(StrPas(S + FirstSignificantDigit, ElemLen), Value, Err);
  566. //writeln(' Value = ',Value,' HH = ',TimeValues[0],' MM = ',TimeValues[1],' SS = ',TimeValues[2],' MSec = ',Timevalues[3]);
  567. //This is safe now, because we know Value < High(Word)
  568. TimeValues[TimeIndex] := Value;
  569. Inc(TimeIndex);
  570. DigitPending := False;
  571. end
  572. else Exit; //Value to big, so it must be a wrong timestring
  573. end//Digits
  574. else if (CurChar = #32) then
  575. begin
  576. //writeln('#32');
  577. //just skip, but we must adress this, or it will be parsed by either AM/PM or Separator
  578. end
  579. else if (CurChar = Separator) then
  580. begin
  581. //writeln('Separator');
  582. if DigitPending or (TimeIndex > tiSec) then Exit;
  583. DigitPending := True;
  584. MSecPending := False;
  585. end
  586. else if (CurChar = defs.DecimalSeparator) then
  587. begin
  588. //writeln('DecimalSeparator');
  589. if DigitPending or MSecPending or (TimeIndex <> tiMSec) then Exit;
  590. DigitPending := True;
  591. MSecPending := True;
  592. end
  593. else
  594. begin//AM/PM?
  595. //None of the above, so this char _must_ be the start of AM/PM string
  596. //If we already have found AM/PM or we expect a digit then then timestring must be wrong at this point
  597. //writeln('AM/PM?');
  598. if (AmPm <> AMPM_None) or DigitPending then Exit;
  599. OffSet := Cur;
  600. while (Cur < Len -1) and (not (S[Cur + 1] in [Separator, #32, defs.DecimalSeparator]))
  601. and not (S[Cur + 1] in Digits) do Inc(Cur);
  602. ElemLen := 1 + Cur - OffSet;
  603. //writeln(' S[Offset] = ',S[Offset], ' S[Cur] = ',S[Cur],' ElemLen = ',ElemLen,' -> ', StrPas(S + Offset, ElemLen));
  604. //writeln(' Cur = ',Cur);
  605. AmPmStr := StrPas(S + OffSet, ElemLen);
  606. //writeln('AmPmStr = ',ampmstr,' (',length(ampmstr),')');
  607. //We must compare to TimeAMString before hardcoded 'AM' for delphi compatibility
  608. //Also it is perfectly legal, though insane to have TimeAMString = 'PM' and vice versa
  609. if (AnsiCompareText(AmPmStr, defs.TimeAMString) = 0) then AmPm := AMPM_AM
  610. else if (AnsiCompareText(AmPmStr, defs.TimePMString) = 0) then AmPm := AMPM_PM
  611. else if (CompareText(AmPmStr, 'AM') = 0) then AmPm := AMPM_AM
  612. else if (CompareText(AmPmStr, 'PM') = 0) then AmPm := AMPM_PM
  613. else Exit; //If text does not match any of these, timestring must be wrong;
  614. //if AM/PM is at beginning of string, then a digit is mandatory after it
  615. if (TimeIndex = tiHour) then
  616. begin
  617. DigitPending := True;
  618. end
  619. //otherwise, no more TimeValues allowed after this
  620. else
  621. begin
  622. TimeIndex := tiMSec + 1;
  623. DigitPending := False;
  624. end;
  625. end;//AM/PM
  626. Inc(Cur)
  627. end;//while
  628. //If we arrive here, parsing the elements has been successfull
  629. //if not at least Hours specified then input is not valid
  630. //when am/pm is specified Hour must be <= 12 and not 0
  631. if (TimeIndex = tiHour) or ((AmPm <> AMPM_None) and ((TimeValues[tiHour] > 12) or (TimeValues[tiHour] = 0))) or DigitPending then Exit;
  632. Result := True;
  633. end;
  634. begin
  635. if separator = #0 then
  636. separator := defs.TimeSeparator;
  637. AmPm := AMPM_None;
  638. if not SplitElements(TimeValues, AmPm) then
  639. begin
  640. ErrorMsg:=Format(SErrInvalidTimeFormat,[StrPas(S, Len)]);
  641. Exit;
  642. end;
  643. if (AmPm=AMPM_PM) and (TimeValues[tiHour]<>12) then Inc(TimeValues[tiHour], 12)
  644. else if (AmPm=AMPM_AM) and (TimeValues[tiHour]=12) then TimeValues[tiHour]:=0;
  645. if not TryEncodeTime(TimeValues[tiHour], TimeValues[tiMin], TimeValues[tiSec], TimeValues[tiMSec], result) Then
  646. //errormsg:='Invalid time.';
  647. ErrorMsg:=Format(SErrInvalidTimeFormat,[StrPas(S, Len)]);
  648. end ;
  649. function StrToTime(const S: PChar; Len : integer; separator : char = #0): TDateTime;
  650. Var
  651. Msg : AnsiString;
  652. begin
  653. Result:=IntStrToTime(Msg,S,Len,DefaultFormatSettings,Separator);
  654. If (Msg<>'') then
  655. Raise EConvertError.Create(Msg);
  656. end;
  657. function StrToTime(const S: string; FormatSettings : TFormatSettings): TDateTime;
  658. Var
  659. Msg : AnsiString;
  660. begin
  661. Result:=IntStrToTime(Msg, PChar(S), length(S), FormatSettings, #0);
  662. If (Msg<>'') then
  663. Raise EConvertError.Create(Msg);
  664. end;
  665. function StrToTime(const s: ShortString; separator : char): TDateTime;
  666. begin
  667. // S[1] always exists for shortstring. Length 0 will trigger an error.
  668. result := StrToTime(@s[1], length(s), separator);
  669. end;
  670. function StrToTime(const s: AnsiString; separator : char): TDateTime;
  671. begin
  672. result := StrToTime(PChar(S), length(s), separator);
  673. end;
  674. function StrToTime(const s: ShortString): TDateTime;
  675. begin
  676. // S[1] always exists for shortstring. Length 0 will trigger an error.
  677. result := StrToTime(@s[1], length(s), #0);
  678. end;
  679. function StrToTime(const s: AnsiString): TDateTime;
  680. begin
  681. result:= StrToTime(PChar(s), length(s), #0);
  682. end;
  683. { StrToDateTime converts the string S to a TDateTime value
  684. if S does not represent a valid date and/or time value
  685. an EConvertError will be raised }
  686. function SplitDateTimeStr(DateTimeStr: AnsiString; const FS: TFormatSettings; out DateStr, TimeStr: AnsiString): Integer;
  687. { Helper function for StrToDateTime
  688. Pre-condition
  689. Date is before Time
  690. If either Date or Time is omitted then see what fits best, a time or a date (issue #0020522)
  691. Date and Time are separated by whitespace (space Tab, Linefeed or carriage return)
  692. FS.DateSeparator can be the same as FS.TimeSeparator (issue #0020522)
  693. If they are both #32 and TrimWhite(DateTimeStr) contains a #32 a date is assumed.
  694. Post-condition
  695. DateStr holds date as string or is empty
  696. TimeStr holds time as string or is empty
  697. Result = number of strings returned, 0 = error
  698. }
  699. const
  700. WhiteSpace = [#9,#10,#13,#32];
  701. Space : String = #32; // String, to avoid error 'Cannot decide what overload to call'
  702. var
  703. p: Integer;
  704. DummyDT: TDateTime;
  705. begin
  706. Result := 0;
  707. DateStr := '';
  708. TimeStr := '';
  709. DateTimeStr := Trim(DateTimeStr);
  710. if Length(DateTimeStr) = 0 then exit;
  711. if (FS.DateSeparator = #32) and (FS.TimeSeparator = #32) and (Pos(#32, DateTimeStr) > 0) then
  712. begin
  713. DateStr:=DateTimeStr;
  714. {
  715. Assume a date: dd [mm [yy]].
  716. Really fancy would be counting the number of whitespace occurrences and decide
  717. and split accordingly
  718. }
  719. Exit(1);
  720. end;
  721. p:=1;
  722. //find separator
  723. if Pos(Space,FS.DateSeparator)=0 then
  724. begin
  725. while (p<Length(DateTimeStr)) and (not (DateTimeStr[p+1] in WhiteSpace)) do
  726. Inc(p);
  727. end
  728. else
  729. begin
  730. p:=Pos(FS.TimeSeparator, DateTimeStr);
  731. if (p<>0) then
  732. repeat
  733. Dec(p);
  734. until (p=0) or (DateTimeStr[p] in WhiteSpace);
  735. end;
  736. //Always fill DateStr, it eases the algorithm later
  737. if (p=0) then
  738. p:=Length(DateTimeStr);
  739. DateStr:=Copy(DateTimeStr,1,p);
  740. TimeStr:=Trim(Copy(DateTimeStr,p+1,MaxInt));
  741. if (Length(TimeStr)<>0) then
  742. Result:=2
  743. else
  744. begin
  745. Result:=1; //found 1 string
  746. // 2 cases when DateTimeStr only contains a time:
  747. // Date/time separator differ, and string contains a timeseparator
  748. // Date/time separators are equal, but transformation to date fails.
  749. if ((FS.DateSeparator<>FS.TimeSeparator) and (Pos(FS.TimeSeparator,DateStr) > 0))
  750. or ((FS.DateSeparator=FS.TimeSeparator) and (not TryStrToDate(DateStr, DummyDT, FS))) then
  751. begin
  752. TimeStr := DateStr;
  753. DateStr := '';
  754. end;
  755. end;
  756. end;
  757. function StrToDateTime(const s: AnsiString; const FormatSettings : TFormatSettings): TDateTime;
  758. var
  759. TimeStr, DateStr: AnsiString;
  760. PartsFound: Integer;
  761. begin
  762. PartsFound := SplitDateTimeStr(S, FormatSettings, DateStr, TimeStr);
  763. case PartsFound of
  764. 0: Result:=StrToDate('');
  765. 1: if (Length(DateStr) > 0) then
  766. Result := StrToDate(DateStr, FormatSettings.ShortDateFormat,FormatSettings.DateSeparator)
  767. else
  768. Result := StrToTime(TimeStr, FormatSettings);
  769. 2: Result := ComposeDateTime(StrTodate(DateStr,FormatSettings.ShortDateFormat,FormatSettings.DateSeparator),
  770. StrToTime(TimeStr,FormatSettings));
  771. end;
  772. end;
  773. function StrToDateTime(const s: AnsiString): TDateTime;
  774. begin
  775. Result:=StrToDateTime(S,DefaultFormatSettings);
  776. end;
  777. function StrToDateTime(const s: ShortString; const FormatSettings : TFormatSettings): TDateTime;
  778. var
  779. A : AnsiString;
  780. begin
  781. A:=S;
  782. Result:=StrToDateTime(A,FormatSettings);
  783. end;
  784. { FormatDateTime formats DateTime to the given format string FormatStr }
  785. function FormatDateTime(const FormatStr: string; DateTime: TDateTime; Options : TFormatDateTimeOptions = []): string;
  786. begin
  787. DateTimeToString(Result, FormatStr, DateTime, DefaultFormatSettings,Options);
  788. end;
  789. function FormatDateTime(const FormatStr: string; DateTime: TDateTime; const FormatSettings: TFormatSettings; Options : TFormatDateTimeOptions = []): string;
  790. begin
  791. DateTimeToString(Result, FormatStr, DateTime, FormatSettings,Options);
  792. end;
  793. { DateTimeToString formats DateTime to the given format in FormatStr }
  794. procedure DateTimeToString(out Result: string; const FormatStr: string;
  795. const DateTime: TDateTime; Options : TFormatDateTimeOptions = []);
  796. begin
  797. DateTimeToString(Result, FormatStr, DateTime, DefaultFormatSettings, Options);
  798. end;
  799. procedure DateTimeToString(out Result: string; const FormatStr: string; const DateTime: TDateTime;
  800. const FormatSettings: TFormatSettings; Options : TFormatDateTimeOptions = []);
  801. var
  802. ResultLen: integer;
  803. ResultBuffer: array[0..255] of char;
  804. ResultCurrent: pchar;
  805. {$if defined(win32) or defined(win64)}
  806. isEnable_E_Format : Boolean;
  807. isEnable_G_Format : Boolean;
  808. eastasiainited : boolean;
  809. procedure InitEastAsia;
  810. var ALCID : LCID;
  811. PriLangID , SubLangID : Word;
  812. begin
  813. ALCID := GetThreadLocale;
  814. PriLangID := ALCID and $3FF;
  815. if (PriLangID>0) then
  816. SubLangID := (ALCID and $FFFF) shr 10
  817. else
  818. begin
  819. PriLangID := SysLocale.PriLangID;
  820. SubLangID := SysLocale.SubLangID;
  821. end;
  822. isEnable_E_Format := (PriLangID = LANG_JAPANESE)
  823. or
  824. (PriLangID = LANG_KOREAN)
  825. or
  826. ((PriLangID = LANG_CHINESE)
  827. and
  828. (SubLangID = SUBLANG_CHINESE_TRADITIONAL)
  829. );
  830. isEnable_G_Format := (PriLangID = LANG_JAPANESE)
  831. or
  832. ((PriLangID = LANG_CHINESE)
  833. and
  834. (SubLangID = SUBLANG_CHINESE_TRADITIONAL)
  835. );
  836. eastasiainited :=true;
  837. end;
  838. {$endif win32 or win64}
  839. procedure StoreStr(Str: PChar; Len: Integer);
  840. begin
  841. if ResultLen + Len < SizeOf(ResultBuffer) then
  842. begin
  843. StrMove(ResultCurrent, Str, Len);
  844. ResultCurrent := ResultCurrent + Len;
  845. ResultLen := ResultLen + Len;
  846. end;
  847. end;
  848. procedure StoreString(const Str: string);
  849. var Len: integer;
  850. begin
  851. Len := Length(Str);
  852. if ResultLen + Len < SizeOf(ResultBuffer) then
  853. begin
  854. StrMove(ResultCurrent, pchar(Str), Len);
  855. ResultCurrent := ResultCurrent + Len;
  856. ResultLen := ResultLen + Len;
  857. end;
  858. end;
  859. procedure StoreInt(Value, Digits: Integer);
  860. var
  861. S: string[16];
  862. Len: integer;
  863. begin
  864. System.Str(Value:Digits, S);
  865. for Len := 1 to Length(S) do
  866. begin
  867. if S[Len] = ' ' then
  868. S[Len] := '0'
  869. else
  870. Break;
  871. end;
  872. StoreStr(pchar(@S[1]), Length(S));
  873. end ;
  874. var
  875. Year, Month, Day, DayOfWeek, Hour, Minute, Second, MilliSecond: word;
  876. procedure StoreFormat(const FormatStr: string; Nesting: Integer; TimeFlag: Boolean);
  877. var
  878. Token, lastformattoken, prevlasttoken: char;
  879. FormatCurrent: pchar;
  880. FormatEnd: pchar;
  881. Count: integer;
  882. Clock12: boolean;
  883. P: pchar;
  884. tmp: integer;
  885. isInterval: Boolean;
  886. begin
  887. if Nesting > 1 then // 0 is original string, 1 is included FormatString
  888. Exit;
  889. FormatCurrent := PChar(FormatStr);
  890. FormatEnd := FormatCurrent + Length(FormatStr);
  891. Clock12 := false;
  892. isInterval := false;
  893. P := FormatCurrent;
  894. // look for unquoted 12-hour clock token
  895. while P < FormatEnd do
  896. begin
  897. Token := P^;
  898. case Token of
  899. '''', '"':
  900. begin
  901. Inc(P);
  902. while (P < FormatEnd) and (P^ <> Token) do
  903. Inc(P);
  904. end;
  905. 'A', 'a':
  906. begin
  907. if (StrLIComp(P, 'A/P', 3) = 0) or
  908. (StrLIComp(P, 'AMPM', 4) = 0) or
  909. (StrLIComp(P, 'AM/PM', 5) = 0) then
  910. begin
  911. Clock12 := true;
  912. break;
  913. end;
  914. end;
  915. end; // case
  916. Inc(P);
  917. end ;
  918. token := #255;
  919. lastformattoken := ' ';
  920. prevlasttoken := 'H';
  921. while FormatCurrent < FormatEnd do
  922. begin
  923. Token := UpCase(FormatCurrent^);
  924. Count := 1;
  925. P := FormatCurrent + 1;
  926. case Token of
  927. '''', '"':
  928. begin
  929. while (P < FormatEnd) and (p^ <> Token) do
  930. Inc(P);
  931. Inc(P);
  932. Count := P - FormatCurrent;
  933. StoreStr(FormatCurrent + 1, Count - 2);
  934. end ;
  935. 'A':
  936. begin
  937. if StrLIComp(FormatCurrent, 'AMPM', 4) = 0 then
  938. begin
  939. Count := 4;
  940. if Hour < 12 then
  941. StoreString(FormatSettings.TimeAMString)
  942. else
  943. StoreString(FormatSettings.TimePMString);
  944. end
  945. else if StrLIComp(FormatCurrent, 'AM/PM', 5) = 0 then
  946. begin
  947. Count := 5;
  948. if Hour < 12 then StoreStr(FormatCurrent, 2)
  949. else StoreStr(FormatCurrent+3, 2);
  950. end
  951. else if StrLIComp(FormatCurrent, 'A/P', 3) = 0 then
  952. begin
  953. Count := 3;
  954. if Hour < 12 then StoreStr(FormatCurrent, 1)
  955. else StoreStr(FormatCurrent+2, 1);
  956. end
  957. else
  958. raise EConvertError.Create('Illegal character in format string');
  959. end ;
  960. '/': StoreStr(@FormatSettings.DateSeparator, 1);
  961. ':': StoreStr(@FormatSettings.TimeSeparator, 1);
  962. '[': if (fdoInterval in Options) then isInterval := true else StoreStr(FormatCurrent, 1);
  963. ']': if (fdoInterval in Options) then isInterval := false else StoreStr(FormatCurrent, 1);
  964. ' ', 'C', 'D', 'H', 'M', 'N', 'S', 'T', 'Y', 'Z', 'F' {$IFDEF MSWindows}, 'G', 'E'{$ENDIF MSWindows} :
  965. begin
  966. while (P < FormatEnd) and (UpCase(P^) = Token) do
  967. Inc(P);
  968. Count := P - FormatCurrent;
  969. case Token of
  970. ' ': StoreStr(FormatCurrent, Count);
  971. 'Y': begin
  972. if Count > 2 then
  973. StoreInt(Year, 4)
  974. else
  975. StoreInt(Year mod 100, 2);
  976. end;
  977. 'M': begin
  978. if isInterval and ((prevlasttoken = 'H') or TimeFlag) then
  979. StoreInt(Minute + (Hour + trunc(abs(DateTime))*24)*60, 0)
  980. else
  981. if (lastformattoken = 'H') or TimeFlag then
  982. begin
  983. if Count = 1 then
  984. StoreInt(Minute, 0)
  985. else
  986. StoreInt(Minute, 2);
  987. end
  988. else
  989. begin
  990. case Count of
  991. 1: StoreInt(Month, 0);
  992. 2: StoreInt(Month, 2);
  993. 3: StoreString(FormatSettings.ShortMonthNames[Month]);
  994. else
  995. StoreString(FormatSettings.LongMonthNames[Month]);
  996. end;
  997. end;
  998. end;
  999. 'D': begin
  1000. case Count of
  1001. 1: StoreInt(Day, 0);
  1002. 2: StoreInt(Day, 2);
  1003. 3: StoreString(FormatSettings.ShortDayNames[DayOfWeek]);
  1004. 4: StoreString(FormatSettings.LongDayNames[DayOfWeek]);
  1005. 5: StoreFormat(FormatSettings.ShortDateFormat, Nesting+1, False);
  1006. else
  1007. StoreFormat(FormatSettings.LongDateFormat, Nesting+1, False);
  1008. end ;
  1009. end ;
  1010. 'H':
  1011. if isInterval then
  1012. StoreInt(Hour + trunc(abs(DateTime))*24, 0)
  1013. else
  1014. if Clock12 then
  1015. begin
  1016. tmp := hour mod 12;
  1017. if tmp=0 then tmp:=12;
  1018. if Count = 1 then
  1019. StoreInt(tmp, 0)
  1020. else
  1021. StoreInt(tmp, 2);
  1022. end
  1023. else begin
  1024. if Count = 1 then
  1025. StoreInt(Hour, 0)
  1026. else
  1027. StoreInt(Hour, 2);
  1028. end;
  1029. 'N': if isInterval then
  1030. StoreInt(Minute + (Hour + trunc(abs(DateTime))*24)*60, 0)
  1031. else
  1032. if Count = 1 then
  1033. StoreInt(Minute, 0)
  1034. else
  1035. StoreInt(Minute, 2);
  1036. 'S': if isInterval then
  1037. StoreInt(Second + (Minute + (Hour + trunc(abs(DateTime))*24)*60)*60, 0)
  1038. else
  1039. if Count = 1 then
  1040. StoreInt(Second, 0)
  1041. else
  1042. StoreInt(Second, 2);
  1043. 'Z': if Count = 1 then
  1044. StoreInt(MilliSecond, 0)
  1045. else
  1046. StoreInt(MilliSecond, 3);
  1047. 'T': if Count = 1 then
  1048. StoreFormat(FormatSettings.ShortTimeFormat, Nesting+1, True)
  1049. else
  1050. StoreFormat(FormatSettings.LongTimeFormat, Nesting+1, True);
  1051. 'C': begin
  1052. StoreFormat(FormatSettings.ShortDateFormat, Nesting+1, False);
  1053. if (Hour<>0) or (Minute<>0) or (Second<>0) then
  1054. begin
  1055. StoreString(' ');
  1056. StoreFormat(FormatSettings.LongTimeFormat, Nesting+1, True);
  1057. end;
  1058. end;
  1059. 'F': begin
  1060. StoreFormat(FormatSettings.ShortDateFormat, Nesting+1, False);
  1061. StoreString(' ');
  1062. StoreFormat(FormatSettings.LongTimeFormat, Nesting+1, True);
  1063. end;
  1064. {$if defined(win32) or defined(win64)}
  1065. 'E':
  1066. begin
  1067. if not Eastasiainited then InitEastAsia;
  1068. if Not(isEnable_E_Format) then StoreStr(FormatCurrent, 1)
  1069. else
  1070. begin
  1071. while (P < FormatEnd) and (UpCase(P^) = Token) do
  1072. P := P + 1;
  1073. Count := P - FormatCurrent;
  1074. StoreString(ConvertEraYearString(Count,Year,Month,Day));
  1075. end;
  1076. prevlasttoken := lastformattoken;
  1077. lastformattoken:=token;
  1078. end;
  1079. 'G':
  1080. begin
  1081. if not Eastasiainited then InitEastAsia;
  1082. if Not(isEnable_G_Format) then StoreStr(FormatCurrent, 1)
  1083. else
  1084. begin
  1085. while (P < FormatEnd) and (UpCase(P^) = Token) do
  1086. P := P + 1;
  1087. Count := P - FormatCurrent;
  1088. StoreString(ConvertEraString(Count,Year,Month,Day));
  1089. end;
  1090. prevlasttoken := lastformattoken;
  1091. lastformattoken:=token;
  1092. end;
  1093. {$endif win32 or win64}
  1094. end;
  1095. prevlasttoken := lastformattoken;
  1096. lastformattoken := token;
  1097. end;
  1098. else
  1099. StoreStr(@Token, 1);
  1100. end ;
  1101. Inc(FormatCurrent, Count);
  1102. end;
  1103. end;
  1104. begin
  1105. {$if defined(win32) or defined(win64)}
  1106. eastasiainited:=false;
  1107. {$endif win32 or win64}
  1108. DecodeDateFully(DateTime, Year, Month, Day, DayOfWeek);
  1109. DecodeTime(DateTime, Hour, Minute, Second, MilliSecond);
  1110. ResultLen := 0;
  1111. ResultCurrent := @ResultBuffer[0];
  1112. if FormatStr <> '' then
  1113. StoreFormat(FormatStr, 0, False)
  1114. else
  1115. StoreFormat('C', 0, False);
  1116. ResultBuffer[ResultLen] := #0;
  1117. result := StrPas(@ResultBuffer[0]);
  1118. end ;
  1119. Function DateTimeToFileDate(DateTime : TDateTime) : Int64;
  1120. Var YY,MM,DD,H,m,s,msec : Word;
  1121. begin
  1122. Decodedate (DateTime,YY,MM,DD);
  1123. DecodeTime (DateTime,h,m,s,msec);
  1124. {$ifndef unix}
  1125. If (YY<1980) or (YY>2099) then
  1126. Result:=0
  1127. else
  1128. begin
  1129. Result:=(s shr 1) or (m shl 5) or (h shl 11);
  1130. Result:=Result or longint(DD shl 16 or (MM shl 21) or (word(YY-1980) shl 25));
  1131. end;
  1132. {$else unix}
  1133. Result:=LocalToEpoch(yy,mm,dd,h,m,s);
  1134. {$endif unix}
  1135. end;
  1136. Function UniversalToFileDate(DateTime : TDateTime) : int64;
  1137. {$ifndef unix}
  1138. begin
  1139. Result := DateTimeToFileDate(UniversalTimeToLocal(DateTime));
  1140. end;
  1141. {$else unix}
  1142. Var YY,MM,DD,H,m,s,msec : Word;
  1143. begin
  1144. Decodedate (DateTime,YY,MM,DD);
  1145. DecodeTime (DateTime,h,m,s,msec);
  1146. Result:=UniversalToEpoch(yy,mm,dd,h,m,s);
  1147. end;
  1148. {$endif unix}
  1149. function CurrentYear: Word;
  1150. var
  1151. SysTime: TSystemTime;
  1152. begin
  1153. GetLocalTime(SysTime);
  1154. Result := SysTime.Year;
  1155. end;
  1156. Function FileDateToDateTime (Filedate : Int64) : TDateTime;
  1157. {$ifndef unix}
  1158. Var Date,Time : Word;
  1159. begin
  1160. Date:=FileDate shr 16;
  1161. Time:=FileDate and $ffff;
  1162. Result:=ComposeDateTime(EncodeDate((Date shr 9) + 1980,(Date shr 5) and 15, Date and 31),
  1163. EncodeTime(Time shr 11, (Time shr 5) and 63, (Time and 31) shl 1,0));
  1164. end;
  1165. {$else unix}
  1166. var
  1167. y, mon, d, h, min, s: word;
  1168. begin
  1169. EpochToLocal(FileDate,y,mon,d,h,min,s);
  1170. Result:=ComposeDateTime(EncodeDate(y,mon,d),EncodeTime(h,min,s,0));
  1171. end;
  1172. {$endif unix}
  1173. Function FileDateToUniversal (Filedate : Int64) : TDateTime;
  1174. {$ifndef unix}
  1175. begin
  1176. Result := LocalTimeToUniversal(FileDateToDateTime(Filedate));
  1177. end;
  1178. {$else unix}
  1179. var
  1180. y, mon, d, h, min, s: word;
  1181. begin
  1182. EpochToUniversal(FileDate,y,mon,d,h,min,s);
  1183. Result:=ComposeDateTime(EncodeDate(y,mon,d),EncodeTime(h,min,s,0));
  1184. end;
  1185. {$endif unix}
  1186. function TryStrToDate(const S: ShortString; out Value: TDateTime): Boolean;
  1187. begin
  1188. result := TryStrToDate(S, Value, #0);
  1189. end;
  1190. function TryStrToDate(const S: ShortString; out Value: TDateTime;
  1191. const useformat : string; separator : char = #0): Boolean;
  1192. Var
  1193. Msg : Ansistring;
  1194. begin
  1195. // S[1] always exists for shortstring. Length 0 will trigger an error.
  1196. Value:=IntStrToDate(Msg,@S[1],Length(S),useformat,defaultformatsettings,separator);
  1197. Result:=(Msg='');
  1198. end;
  1199. function TryStrToDate(const S: AnsiString; out Value: TDateTime;
  1200. const useformat : string; separator : char = #0): Boolean;
  1201. Var
  1202. Msg : Ansistring;
  1203. begin
  1204. Result:=Length(S)<>0;
  1205. If Result then
  1206. begin
  1207. Value:=IntStrToDate(Msg,PChar(S),Length(S),useformat,DefaultFormatSettings,Separator);
  1208. Result:=(Msg='');
  1209. end;
  1210. end;
  1211. function TryStrToDate(const S: ShortString; out Value: TDateTime; separator : char): Boolean;
  1212. begin
  1213. Result:=TryStrToDate(S,Value,DefaultFormatSettings.ShortDateFormat,Separator);
  1214. end;
  1215. function TryStrToDate(const S: AnsiString; out Value: TDateTime): Boolean;
  1216. begin
  1217. Result:=TryStrToDate(S,Value,DefaultFormatSettings.ShortDateFormat,#0);
  1218. end;
  1219. function TryStrToDate(const S: AnsiString; out Value: TDateTime; separator : char): Boolean;
  1220. begin
  1221. Result:=TryStrToDate(S,Value,DefaultFormatSettings.ShortDateFormat,Separator);
  1222. end;
  1223. function TryStrToDate(const S: string; out Value: TDateTime; const FormatSettings: TFormatSettings): Boolean;
  1224. Var
  1225. Msg : Ansistring;
  1226. begin
  1227. Result:=Length(S)<>0;
  1228. If Result then
  1229. begin
  1230. Value:=IntStrToDate(Msg,PChar(S),Length(S),FormatSettings.ShortDateFormat,FormatSettings,#0);
  1231. Result:=(Msg='');
  1232. end;
  1233. end;
  1234. function TryStrToTime(const S: ShortString; out Value: TDateTime; separator : char): Boolean;
  1235. Var
  1236. Msg : AnsiString;
  1237. begin
  1238. // S[1] always exists for shortstring. Length 0 will trigger an error.
  1239. Value:=IntStrToTime(Msg,@S[1],Length(S),DefaultFormatSettings,Separator);
  1240. result:=(Msg='');
  1241. end;
  1242. function TryStrToTime(const S: ShortString; out Value: TDateTime): Boolean;
  1243. begin
  1244. Result := TryStrToTime(S,Value,#0);
  1245. end;
  1246. function TryStrToTime(const S: AnsiString; out Value: TDateTime; separator : char): Boolean;
  1247. Var
  1248. Msg : AnsiString;
  1249. begin
  1250. Result:=Length(S)<>0;
  1251. If Result then
  1252. begin
  1253. Value:=IntStrToTime(Msg,PChar(S),Length(S),DefaultFormatSettings,Separator);
  1254. Result:=(Msg='');
  1255. end;
  1256. end;
  1257. function TryStrToTime(const S: AnsiString; out Value: TDateTime): Boolean;
  1258. begin
  1259. result := TryStrToTime(S,Value,#0);
  1260. end;
  1261. function TryStrToTime(const S: string; out Value: TDateTime; const FormatSettings: TFormatSettings): Boolean;
  1262. Var msg : AnsiString;
  1263. begin
  1264. Result:=Length(S)<>0;
  1265. If Result then
  1266. begin
  1267. Value:=IntStrToTime(Msg,PChar(S),Length(S),FormatSettings,#0);
  1268. Result:=(Msg='');
  1269. end;
  1270. end;
  1271. function TryStrToDateTime(const S: ShortString; out Value: TDateTime): Boolean;
  1272. begin
  1273. result := TryStrToDateTime(S, Value, DefaultFormatSettings);
  1274. end;
  1275. function TryStrToDateTime(const S: AnsiString; out Value: TDateTime): Boolean;
  1276. begin
  1277. result := TryStrToDateTime(S, Value, DefaultFormatSettings);
  1278. end;
  1279. function TryStrToDateTime(const S: string; out Value: TDateTime; const FormatSettings: TFormatSettings): Boolean;
  1280. var
  1281. I: integer;
  1282. dtdate, dttime :TDateTime;
  1283. begin
  1284. result:=false;
  1285. I:=Pos(FormatSettings.TimeSeparator,S);
  1286. If (I>0) then
  1287. begin
  1288. While (I>0) and (S[I]<>' ') do
  1289. Dec(I);
  1290. If I>0 then
  1291. begin
  1292. if not TryStrToDate(Copy(S,1,I-1),dtdate,Formatsettings) then
  1293. exit;
  1294. if not TryStrToTime(Copy(S,i+1, Length(S)-i),dttime,Formatsettings) then
  1295. exit;
  1296. Value:=ComposeDateTime(dtdate,dttime);
  1297. result:=true;
  1298. end
  1299. else
  1300. result:=TryStrToTime(s,Value,Formatsettings);
  1301. end
  1302. else
  1303. result:=TryStrToDate(s,Value,Formatsettings);
  1304. end;
  1305. function StrToDateDef(const S: ShortString; const Defvalue : TDateTime): TDateTime;
  1306. begin
  1307. result := StrToDateDef(S,DefValue,#0);
  1308. end;
  1309. function StrToTimeDef(const S: ShortString; const Defvalue : TDateTime): TDateTime;
  1310. begin
  1311. result := StrToTimeDef(S,DefValue,#0);
  1312. end;
  1313. function StrToDateTimeDef(const S: ShortString; const Defvalue : TDateTime): TDateTime;
  1314. begin
  1315. Result:=StrToDateTimeDef(S,DefValue,DefaultFormatSettings);
  1316. end;
  1317. function StrToDateTimeDef(const S: AnsiString; const Defvalue : TDateTime; const FormatSettings: TFormatSettings): TDateTime;
  1318. begin
  1319. if not TryStrToDateTime(s,Result,FormatSettings) Then
  1320. result:=defvalue;
  1321. end;
  1322. function StrToDateDef(const S: ShortString; const Defvalue : TDateTime; separator : char): TDateTime;
  1323. begin
  1324. if not TryStrToDate(s,Result, separator) Then
  1325. result:=defvalue;
  1326. end;
  1327. function StrToTimeDef(const S: ShortString; const Defvalue : TDateTime; separator : char): TDateTime;
  1328. begin
  1329. if not TryStrToTime(s,Result, separator) Then
  1330. result:=defvalue;
  1331. end;
  1332. function StrToDateDef(const S: AnsiString; const Defvalue : TDateTime): TDateTime;
  1333. begin
  1334. result := StrToDateDef(S,DefValue,#0);
  1335. end;
  1336. function StrToTimeDef(const S: AnsiString; const Defvalue : TDateTime): TDateTime;
  1337. begin
  1338. result := StrToTimeDef(S,DefValue,#0);
  1339. end;
  1340. function StrToDateTimeDef(const S: AnsiString; const Defvalue : TDateTime): TDateTime;
  1341. begin
  1342. if not TryStrToDateTime(s,Result) Then
  1343. result:=defvalue;
  1344. end;
  1345. function StrToDateDef(const S: AnsiString; const Defvalue : TDateTime; separator : char): TDateTime;
  1346. begin
  1347. if not TryStrToDate(s,Result, separator) Then
  1348. result:=defvalue;
  1349. end;
  1350. function StrToTimeDef(const S: AnsiString; const Defvalue : TDateTime; separator : char): TDateTime;
  1351. begin
  1352. if not TryStrToTime(s,Result, separator) Then
  1353. result:=defvalue;
  1354. end;
  1355. procedure ReplaceTime(var dati:TDateTime; NewTime : TDateTime);inline;
  1356. begin
  1357. dati:= ComposeDateTime(dati, newtime);
  1358. end;
  1359. procedure ReplaceDate(var DateTime: TDateTime; const NewDate: TDateTime); inline;
  1360. var
  1361. tmp : TDateTime;
  1362. begin
  1363. tmp:=NewDate;
  1364. ReplaceTime(tmp,DateTime);
  1365. DateTime:=tmp;
  1366. end;
  1367. {$IFNDEF HAS_LOCALTIMEZONEOFFSET}
  1368. Function GetLocalTimeOffset : Integer;
  1369. begin
  1370. Result:=0;
  1371. end;
  1372. function GetLocalTimeOffset(const DateTime: TDateTime; const InputIsUTC: Boolean; out Offset: Integer): Boolean;
  1373. begin
  1374. Result:=False;
  1375. end;
  1376. function GetUniversalTime(var SystemTime: TSystemTime): Boolean;
  1377. begin
  1378. Result:=False;
  1379. end;
  1380. {$ENDIF}
  1381. function GetLocalTimeOffset(const DateTime: TDateTime; const InputIsUTC: Boolean): Integer;
  1382. begin
  1383. if not GetLocalTimeOffset(DateTime, InputIsUTC, Result) then
  1384. Result:=GetLocalTimeOffset();
  1385. end;
  1386. { Conversion of UTC to local time and vice versa }
  1387. function UniversalTimeToLocal(UT: TDateTime): TDateTime;
  1388. begin
  1389. Result:=UniversalTimeToLocal(UT,-GetLocalTimeOffset(UT, True));
  1390. end;
  1391. function UniversalTimeToLocal(UT: TDateTime; TZOffset : Integer): TDateTime;
  1392. begin
  1393. if (TZOffset > 0) then
  1394. Result := UT + EncodeTime(TZOffset div 60, TZOffset mod 60, 0, 0)
  1395. else if (TZOffset < 0) then
  1396. Result := UT - EncodeTime(Abs(TZOffset) div 60, Abs(TZOffset) mod 60, 0, 0)
  1397. else
  1398. Result := UT;
  1399. end;
  1400. Function LocalTimeToUniversal(LT: TDateTime): TDateTime;
  1401. begin
  1402. Result:=LocalTimeToUniversal(LT,-GetLocalTimeOffset(LT, False));
  1403. end;
  1404. Function LocalTimeToUniversal(LT: TDateTime;TZOffset: Integer): TDateTime;
  1405. begin
  1406. if (TZOffset > 0) then
  1407. Result := LT - EncodeTime(TZOffset div 60, TZOffset mod 60, 0, 0)
  1408. else if (TZOffset < 0) then
  1409. Result := LT + EncodeTime(Abs(TZOffset) div 60, Abs(TZOffset) mod 60, 0, 0)
  1410. else
  1411. Result := LT;
  1412. end;