Function FormatStrToDateTime(Format : string; strDate : string) : TDateTime;
// throws EConvertError()
type
TTokenType = (fmtUndef, fmtC, fmtD, fmtD2, fmtD3, fmtD4, fmtD5, fmtD6,
fmtM, fmtM2, fmtM3, fmtM4, fmtY2, fmtY4, fmtH, fmtH2,
fmtN, fmtN2, fmtS, fmtS2, fmtZ, fmtZ3, fmtT, fmtT2,
fmtAM_PM, fmtA_P, fmtAMPM, fmtDateSep, fmtTimeSep, fmtUserStr
);
var
// Текущие позиции в строках с форматом и датой.
pFormat, pDate : PChar;
// Текущая лексема формата.
formatToken : string;
// Текущая выделенная дата.
date : TSystemTime;
isPilotAnal : boolean;
//
// Выделяет очередную лексему строки форматирования.
//
Function GetFormatToken : TTokenType;
begin
if pFormat^ = #0 then
Result := fmtUndef
else if Pos(pFormat^, #9#10#13' .,`~!@#$%^&*()_-=+\|]}[{?;') > 0 then begin
Result := fmtUserStr;
formatToken := pFormat^;
inc(pFormat);
end else if pFormat^ = 'C' then begin
Result := fmtC;
formatToken := 'C';
inc(pFormat);
end else if (pFormat^ = 'D') and ((pFormat + 1)^ <> 'D') then begin
Result := fmtD;
formatToken := 'D';
inc(pFormat);
end else if (pFormat^ = 'D') and ((pFormat + 1)^ = 'D') and ((pFormat + 2)^ <> 'D') then begin
Result := fmtD2;
formatToken := 'DD';
inc(pFormat, 2);
end else if (pFormat^ = 'D') and ((pFormat + 1)^ = 'D') and ((pFormat + 2)^ = 'D') and ((pFormat + 3)^ <> 'D') then begin
Result := fmtD3;
formatToken := 'DDD';
inc(pFormat, 3);
end else if (pFormat^ = 'D') and ((pFormat + 1)^ = 'D') and ((pFormat + 2)^ = 'D') and ((pFormat + 3)^ = 'D') and ((pFormat + 4)^ <> 'D') then begin
Result := fmtD4;
formatToken := 'DDDD';
inc(pFormat, 4);
end else if (pFormat^ = 'D') and ((pFormat + 1)^ = 'D') and ((pFormat + 2)^ = 'D') and ((pFormat + 3)^ = 'D') and ((pFormat + 4)^ = 'D') and ((pFormat + 5)^ <> 'D') then begin
Result := fmtD5;
formatToken := 'DDDDD';
inc(pFormat, 5);
end else if (pFormat^ = 'D') and ((pFormat + 1)^ = 'D') and ((pFormat + 2)^ = 'D') and ((pFormat + 3)^ = 'D') and ((pFormat + 4)^ = 'D') and ((pFormat + 5)^ = 'D') then begin
Result := fmtD6;
formatToken := 'DDDDDD';
inc(pFormat, 6);
end else if (pFormat^ = 'M') and ((pFormat + 1)^ <> 'M') then begin
Result := fmtM;
formatToken := 'M';
inc(pFormat);
end else if (pFormat^ = 'M') and ((pFormat + 1)^ = 'M') and ((pFormat + 2)^ <> 'M') then begin
Result := fmtM2;
formatToken := 'MM';
inc(pFormat, 2);
end else if (pFormat^ = 'M') and ((pFormat + 1)^ = 'M') and ((pFormat + 2)^ = 'M') and ((pFormat + 3)^ <> 'M') then begin
Result := fmtM3;
formatToken := 'MMM';
inc(pFormat, 3);
end else if (pFormat^ = 'M') and ((pFormat + 1)^ = 'M') and ((pFormat + 2)^ = 'M') and ((pFormat + 3)^ = 'M') and ((pFormat + 4)^ <> 'M') then begin
Result := fmtM4;
formatToken := 'MMMM';
inc(pFormat, 4);
end else if (pFormat^ = 'Y') and ((pFormat + 1)^ = 'Y') and ((pFormat + 2)^ <> 'Y') then begin
Result := fmtY2;
formatToken := 'YY';
inc(pFormat, 2);
end else if (pFormat^ = 'Y') and ((pFormat + 1)^ = 'Y') and ((pFormat + 2)^ = 'Y') and ((pFormat + 3)^ = 'Y') then begin
Result := fmtY4;
formatToken := 'YYYY';
inc(pFormat, 4);
end else if (pFormat^ = 'H') and ((pFormat + 1)^ <> 'H') then begin
Result := fmtH;
formatToken := 'H';
inc(pFormat);
end else if (pFormat^ = 'H') and ((pFormat + 1)^ = 'H') then begin
Result := fmtH2;
formatToken := 'HH';
inc(pFormat, 2);
end else if (pFormat^ = 'N') and ((pFormat + 1)^ <> 'N') then begin
Result := fmtN;
formatToken := 'N';
inc(pFormat);
end else if (pFormat^ = 'N') and ((pFormat + 1)^ = 'N') then begin
Result := fmtN2;
formatToken := 'NN';
inc(pFormat, 2);
end else if (pFormat^ = 'S') and ((pFormat + 1)^ <> 'S') then begin
Result := fmtS;
formatToken := 'S';
inc(pFormat);
end else if (pFormat^ = 'S') and ((pFormat + 1)^ = 'S') then begin
Result := fmtS2;
formatToken := 'SS';
inc(pFormat, 2);
end else if (pFormat^ = 'Z') and ((pFormat + 1)^ <> 'Z') then begin
Result := fmtZ;
formatToken := 'Z';
inc(pFormat);
end else if (pFormat^ = 'Z') and ((pFormat + 1)^ = 'Z') and ((pFormat + 2)^ = 'Z') then begin
Result := fmtZ3;
formatToken := 'ZZZ';
inc(pFormat, 3);
end else if (pFormat^ = 'T') and ((pFormat + 1)^ <> 'T') then begin
Result := fmtT;
formatToken := 'T';
inc(pFormat);
end else if (pFormat^ = 'T') and ((pFormat + 1)^ = 'T') then begin
Result := fmtT2;
formatToken := 'TT';
inc(pFormat, 2);
end else if (pFormat^ = 'A') and ((pFormat + 1)^ = 'M') and ((pFormat + 2)^ = '/') and ((pFormat + 3)^ = 'P') and ((pFormat + 4)^ = 'M') then begin
Result := fmtAM_PM;
formatToken := 'AM/PM';
inc(pFormat, 5);
end else if (pFormat^ = 'A') and ((pFormat + 1)^ = '/') and ((pFormat + 2)^ = 'P') then begin
Result := fmtA_P;
formatToken := 'A/P';
inc(pFormat, 3);
end else if (pFormat^ = 'A') and ((pFormat + 1)^ = 'M') and ((pFormat + 2)^ = 'P') and ((pFormat + 3)^ = 'M') then begin
Result := fmtAMPM;
formatToken := 'AMPM';
inc(pFormat, 4);
end else if (pFormat^ = '''') or (pFormat^ = '"') then begin
Result := fmtUserStr;
formatToken := ExtractQuoteLexem(pFormat, isPilotAnal);
end else if (pFormat^ = '/') then begin
Result := fmtDateSep;
formatToken := '/';
inc(pFormat);
end else if (pFormat^ = ':') then begin
Result := fmtTimeSep;
formatToken := ':';
inc(pFormat);
end else
Result := fmtUndef;
end;
Procedure ReportError;
begin
raise EConvertError.Create('On format: ' + pFormat + ' string: ' + pDate);
end;
//
// Пытается извлечь число вплоть до указанной длины, передвигая указатель.
//
Function ScanNumber(numLen : integer) : integer;
var
str : string;
i : integer;
begin
str := '';
for i := 0 to numLen - 1 do
if (pDate[i] >= '0') and (pDate[i] <= '9') then
str := str + pDate[i]
else
break;
inc(pDate, i);
Result := StrToInt(str);
end;
//
// Возвращает истину, если дата соответствует заданному шаблону и
// передвигает позицию.
//
Function ScanStr(template : string) : boolean;
begin
Result := AnsiSameText(Copy(pDate, 1, Length(template)), template);
if Result then
inc(pDate, Length(template));
end;
//
// Ищем Sun-Sat, возвращая 1 - 7
//
Function ScanArray(strArray : array of string) : integer;
begin
for Result := 0 to High(strArray) do
if ScanStr(strArray[Result]) then
break;
if Result > High(strArray) then
ReportError
else
inc(Result);
end;
begin
DateTimeToSystemTime(0, date);
if Format = '' then pFormat := 'C'
else pFormat := PChar(AnsiUpperCase(Format));
pDate := PChar(AnsiUpperCase(strDate));
isPilotAnal := true;
//
// Сначала заменим все подстановочные спецификаторы,
// а именно fmtC, fmtD5, fmtD6, fmtT, fmtT2.
//
Format := '';
while true do begin
case GetFormatToken of
fmtUndef : break;
fmtC : Format := Format + ShortDateFormat + ' ' + LongTimeFormat;
fmtD5 : Format := Format + ShortDateFormat;
fmtD6 : Format := Format + LongDateFormat;
fmtT : Format := Format + ShortTimeFormat;
fmtT2 : Format := Format + LongTimeFormat;
else
Format := Format + formatToken;
end;
end;
pFormat := PChar(AnsiUpperCase(Format));
isPilotAnal := false;
//
// Разбираем строку.
//
repeat
// Очередная лексема.
case GetFormatToken of
fmtUndef : ReportError;
fmtD,
fmtD2 : date.wDay := ScanNumber(2);
fmtD3 : date.wDayOfWeek := ScanArray(ShortDayNames);
fmtD4 : date.wDayOfWeek := ScanArray(LongDayNames);
fmtM,
fmtM2 : date.wMonth := ScanNumber(2);
fmtM3 : date.wMonth := ScanArray(ShortMonthNames);
fmtM4 : date.wMonth := ScanArray(LongMonthNames);
fmtY2 : begin date.wYear := ScanNumber(2); if date.wYear >= 50 then inc(date.wYear, 1900) else inc(date.wYear, 2000) end;
fmtY4 : date.wYear := ScanNumber(4);
fmtH,
fmtH2 : date.wHour := ScanNumber(2);
fmtN,
fmtN2 : date.wMinute := ScanNumber(2);
fmtS,
fmtS2 : date.wSecond := ScanNumber(2);
fmtZ,
fmtZ3 : date.wMilliseconds := ScanNumber(3);
fmtAM_PM : begin if ScanStr('PM') then inc(date.wHour, 12) else if not ScanStr('AM') then ReportError; end;
fmtA_P : begin if ScanStr('P') then inc(date.wHour, 12) else if not ScanStr('A') then ReportError; end;
fmtAMPM : begin if ScanStr(TimePMString) then inc(date.wHour, 12) else if not ScanStr(TimeAMString) then ReportError; end;
fmtDateSep : if not ScanStr(DateSeparator) then ReportError;
fmtTimeSep : if not ScanStr(TimeSeparator) then ReportError;
fmtUserStr : if not ScanStr(formatToken) then ReportError;
end;
until (pFormat^ = #0) or (pDate^ = #0);
Result := SystemTimeToDateTime(date);
end;