Developing.ru

Код: Выделить всё

try
  Result:=StrToDateTime(str,"YYYY/MM/DD");
except
  try 
    Result:=StrToDateTime(str,"YYYY.MM.DD");
  except
    try 
      Result:=StrToDateTime(str,"DD.MM.YYYY");
    except
       ....... // И так далее по вкусу....
    end;
  end;
end;

Код: Выделить всё

function CWord(S: String; DefValue: Word): Word;
var
  C: Integer;
begin
  Val(S, Result, C);
  if C <> 0 then Result := defValue;
end;

function ParseDate(S: String; Format: String; y, m, d: Word; out ADate: TDateTime): Boolean;
var
  i: Integer;
  dd, mm, yy: String;
  b: Boolean;
begin
  Result := False;
  if Length(S) < Length(Format) then Exit;
  try
    dd := '';
    mm := '';
    yy := '';
    for i := 1 to Length(Format) do begin
      if Format[i] = 'd' then dd := dd + S[i]
      else if Format[i] = 'M' then mm := mm + S[i]
      else if Format[i] = 'y' then yy := yy + S[i]
      else if S[i] <> Format[i] then Exit;
    end;
    if d = 0 then d := CWord(dd, d);
    if m = 0 then m := CWord(mm, m);
    if y = 0 then begin
      if Length(yy) = 2 then
        y := CWord('20' + yy, y)
      else
        y := CWord(yy, y);
    end;

    Result := TryEncodeDate(y, m, d, ADate);
  except
    Result := False;
  end;
end;

// вызываемая функция. Например:
// var
//   d: TDateTime;
// begin
//   d := CDate('01/01/2003');
//   ... или
//   d := CDate('asdfasd', Date); так как ошибка то вернёт текущую дату
//   d := CDate('01/01', Date); если текущая дата 07/12/2006 вернёт '01/01/2006'
//   d := CDate('01', Date); если текущая дата 07/12/2006 вернёт '01/07/2006'
//   d := CDate('01/01/2003', Date); вернет дату 01/01/2003
//   d := CDate('01/01/2003'); аналогично
// end;
function CDate(Value: String; DefDate: TDateTime = 0): TDateTime;
const
  dd: array[0..1] of string = ('dd', 'd');
  mm: array[0..1] of string = ('MM', 'M');
  yy: array[0..1] of string = ('yyyy', 'yy');
var
  y, m, d: Word;

  function _Parse(Value: String; out ADate: TDateTime;
      Separator: String; DMY: String): Boolean;
  var
    S: String;
    i, l, _y, _m, _d: Integer;
    __y, __m, __d: Word;
  begin
    Result := True;
    S := '';
    while S <> Value do begin
      S := Value;
      Value := StringReplace(S, ' ' + Separator, Separator, [rfReplaceAll]);
    end;
    S := '';
    while S <> Value do begin
      S := Value;
      Value := StringReplace(S, Separator + ' ', Separator, [rfReplaceAll]);
    end;

    l := Length(DMY);

    for _d := 0 to 1 do
      for _m := 0 to 1 do
        for _y := 0 to 1 do begin
          S := '';
          __d := d; __m := m; __y := y;
          for i := 1 to l do begin
            if DMY[i] = 'd' then begin
              S := S + dd[_d];
              __d := 0;
            end;
            if DMY[i] = 'm' then begin
              S := S + mm[_m];
              __m := 0;
            end;
            if DMY[i] = 'y' then begin
              S := S + yy[_y];
              __y := 0;
            end;
            if i < l then S := S + Separator;
          end;
          if ParseDate(Value, S, __y, __m, __d, ADate) then Exit;
        end;
    Result := False;
  end;

var
  S: String;
begin
  if DefDate = 0 then
    DecodeDate(Date, y, m, d)
  else
    DecodeDate(DefDate, y, m, d);

  if _Parse(Value, Result, '.', 'dmy') then Exit;
  if _Parse(Value, Result, '/', 'dmy') then Exit;
  if _Parse(Value, Result, ' ', 'dmy') then Exit;
  if _Parse(Value, Result, '', 'dmy') then Exit;
  if _Parse(Value, Result, '.', 'dm') then Exit;
  if _Parse(Value, Result, '/', 'dm') then Exit;
  if _Parse(Value, Result, ' ', 'dm') then Exit;
  if _Parse(Value, Result, '', 'dm') then Exit;
  if _Parse(Value, Result, '', 'd') then Exit;
  Result := DefDate;
end;