PAStrToDate: Erweiterte StrToDate-Funktion

[PeterPanino]

Problem: Strings, die mit DateToString auf einem anderen Computer, mit anderen Regional-Einstellungen, unter einer anderen Landessprache gespeichert wurden, erzeugen beim Einlesen mit StrToDate meistens Fehler (EConvertError-Exception, s. error.gif).

Lösung: PAStrToDate setzt auf die SysUtils-Funktion StrToDate auf und erweitert diese, indem versucht wird, allen möglichen Datum-String-Formatierungen gerecht zu werden. Dabei werden Monatsnamen (kurz und lang) in deutscher und englischer Sprache unterstützt, sowie die jeweils lokalen Spracheinstellungen.
Das heißt:
a) Strings, die auf einem deutschen oder englischen Computer mit DateToStr gespeichert wurden, werden auf einem beliebig-sprachigen Computer mit PAStrToDate korrekt eingelesen.
b) Strings, die auf einem gleichsprachigen Computer mit DateToStr gespeichert wurden, werden unter anderen Regionaleinstellungen mit PAStrToDate korrekt eingelesen.

Delphi-Quellcode:

function TForm1.PAStrToDate(s: string): TDate;
  var
    ShortDateFormatShortStr, doublesep: string;
    Replaced, MonthNameStrFound: Boolean;
  const
    NumStr = '0123456789';
    AlphaStr = 'abcdefghijklmnopqrstuvwxyzäöüß';
  function GetShortDateFormatShortStr: string;
  var
    i: integer;
    f: string;
  begin
    Result := '';
    f := Trim(AnsiLowerCase(SysUtils.ShortDateFormat));
    for i := 1 to Length(f) do
    begin
      if (Pos(f[i], Result) = 0) and (f[i] <> DateSeparator) then
        Result := Result + f[i];
    end; 
  end;
  function ReplaceDateSeparator(const seps: array of Char): string;
  var
    c: integer;
  begin
    for c := Low(seps) to High(seps) do
    begin
      if Pos(seps[c], s) > 0 then
        s := StringReplace(s, seps[c], DateSeparator, [rfReplaceAll]);
    end;
    while Pos(doublesep, s) > 0 do
      s := StringReplace(s, doublesep, DateSeparator, [rfReplaceAll]);
    while s[Length(s)] = DateSeparator do
      s := Copy(s, 1, Length(s) - 1);
    Result := s;
  end;
  function CheckYearOrder(const so: string): string;
  var
    s1, s2: integer;
    function IsYearAtStart: Boolean;
      function ContainsMonthNameStr: Boolean;
      var
        z, a: integer;
      begin
        Result := False;
        for z := 1 to Length(so) do
        begin
          if PosEx(so[z], AlphaStr, 3) > 0 then
            Inc(a)
          else
            a := 0;
          if a > 2 then // month-name found
          begin
            Result := True;
            BREAK;
          end;
        end;
      end;
    begin
      Result := False;
      if Length(so) < 4 then EXIT;
      if ((Pos(so[1], NumStr) > 0) and (Pos(so[2], NumStr) > 0)) then
      begin
        if StrToInt(Copy(so, 1, 2)) > 31 then
          Result := True
        else if ((Pos(so[3], NumStr) > 0) and (Pos(so[4], NumStr) > 0)) then
          Result := True
        else
          if ContainsMonthNameStr then
            Result := True;
      end;
    end;
    function IsYearAtEnd: Boolean;
    begin
      Result := False;
      if s1 = 2 then
        Result := True
      else if (Length(so) - s2) = 4 then
        Result := True
      else if Pos(AnsiLowerCase(so[1]), AlphaStr) > 0 then
        Result := True
      else if (Length(so) - s2) = 2 then
      begin
        if ((Pos(so[s2 + 1], NumStr) > 0) and (Pos(so[s2 + 2], NumStr) > 0)) then
        begin
          if StrToInt(Copy(so, s2 + 1, 2)) > 31 then
            Result := True;
        end;
      end;
    end;
  begin
    Result := so;
    s1 := Pos(DateSeparator, so);
    s2 := PosEx(DateSeparator, so, s1 + 1);
    if (IsYearAtStart and (ShortDateFormatShortStr <> 'ymd')) then
    begin
      if (ShortDateFormatShortStr = 'mdy') then
        Result := Copy(so, s1 + 1, Length(so) - s1) + DateSeparator +
                  Copy(so, 1, s1 - 1)
      else if (ShortDateFormatShortStr = 'dmy') then
        Result := Copy(so, s2 + 1, Length(so) - s2) + DateSeparator +
                  Copy(so, s1 + 1, s2 - s1 - 1) + DateSeparator +
                  Copy(so, 1, s1 - 1);
    end
    else if (IsYearAtEnd and (ShortDateFormatShortStr = 'ymd')) then
    begin
      Result := Copy(so, s2 + 1, Length(so) - s2) + DateSeparator +
                Copy(so, 1, s2 - 1);
    end;
  end;
  function CheckMonthDayOrder(const so: string; const mss: string): string;
  var
    s1, s2: integer;
  begin
    Result := so;
    s1 := Pos(DateSeparator, so);
    s2 := PosEx(DateSeparator, so, s1 + 1);
    if (((Pos(mss, so) = 1) and (ShortDateFormatShortStr = 'dmy')) or
       ((Pos(mss, so) > 1) and (ShortDateFormatShortStr = 'mdy'))) then
    begin
      Result := Copy(so, s1 + 1, s2 - s1 - 1) + DateSeparator +
                Copy(so, 1, s1 - 1) + DateSeparator +
                Copy(so, s2 + 1, Length(so) - s2);
    end
    else if (Pos(mss, so) > s2) and // month at end
            (ShortDateFormatShortStr = 'ymd') then
    begin
      Result := Copy(so, 1, s1) +
                Copy(so, s2 + 1, Length(so) - s2) + DateSeparator +
                Copy(so, s1 + 1, s2 - s1 - 1);
    end;
  end;
  function IsWholeName(const MName: string; const MPos: integer): Boolean;
  begin
    Result := False;
    if (MPos = 1) then // at start
    begin
      if s[Length(MName) + 1] = DateSeparator then
        Result := True;
    end
    else if ((Length(s) = (MPos + Length(MName) - 1))) then // at end (very unlikely)
    begin
      if s[MPos - 1] = DateSeparator then
        Result := True;
    end
    else // in the middle
      if ((s[MPos - 1] = DateSeparator) and (s[MPos + Length(MName)] = DateSeparator)) then
        Result := True;
  end;
  function ReplaceMonthForeignStr(const ms: array of string): string;
  var
    m, mp: integer;
  begin
    for m := Low(ms) to High(ms) do
    begin
      mp := Pos(ms[m], s);
      if mp > 0 then
      begin
        if IsWholeName(ms[m], mp) then
        begin
          s := CheckMonthDayOrder(s, ms[m]);
          s := StringReplace(s, ms[m], IntToStr(m + 1), []);
          Replaced := True;
          BREAK;
        end;
      end;
    end;
    Result := s;
  end;
  function ReplaceMonthLocalStr: string;
  var
    m, mpl, mps: integer;
  begin
    for m := 1 to 12 do
    begin
      mpl := Pos(SysUtils.LongMonthNames[m], s);
      mps := Pos(SysUtils.ShortMonthNames[m], s);
      if mpl > 0 then
      begin
        if IsWholeName(SysUtils.LongMonthNames[m], mpl) then
        begin
          s := CheckMonthDayOrder(s, LongMonthNames[m]);
          s := StringReplace(s, LongMonthNames[m], IntToStr(m), []);
          Replaced := True;
          BREAK;
        end;
      end
      else if mps > 0 then
      begin
        if IsWholeName(SysUtils.ShortMonthNames[m], mps) then
        begin
          s := CheckMonthDayOrder(s, ShortMonthNames[m]);
          s := StringReplace(s, ShortMonthNames[m], IntToStr(m), []);
          Replaced := True;
          BREAK;
        end;
      end;
    end;
    Result := s;
  end;
  function GetMonthDayOrderFromNumbers: string;
  var
    s1, s2, g: integer;
    DayAtStart, ThisYearAtStart: Boolean;
  begin
    Result := s;
    s1 := Pos(DateSeparator, s);
    s2 := PosEx(DateSeparator, s, s1 + 1);
    if (s1 = 0) or (s2 = 0) then EXIT;
    if (Length(s) - s2) = 4 then // 4-digit-year at end
    begin
      DayAtStart := False;
      if s1 = 3 then
      begin
        if ((Pos(s[1], NumStr) > 0) and (Pos(s[2], NumStr) > 0)) then
        begin
          g := StrToInt(Copy(s, 1, 2));
          if (g > 12) and (g < 32) then // dmy
          begin
            DayAtStart := True;
            if ShortDateFormatShortStr = 'mdy' then
            begin
              s := Copy(s, 4, s2 - s1 - 1) + DateSeparator +
                   Copy(s, 1, 2) + DateSeparator +
                   Copy(s, s2 + 1, 4); 
            end;
          end;
        end;
      end;
      if not DayAtStart then
      begin
        if (s2 - s1) = 3 then
        begin
          if ((Pos(s[s1 + 1], NumStr) > 0) and (Pos(s[s1 + 2], NumStr) > 0)) then
          begin
            g := StrToInt(Copy(s, s1 + 1, 2));
            if (g > 12) and (g < 32) then // mdy
            begin
              if ShortDateFormatShortStr = 'dmy' then
              begin
                s := Copy(s, s1 + 1, 2) + DateSeparator +
                     Copy(s, 1, s1 - 1) + DateSeparator +
                     Copy(s, s2 + 1, 4);
              end;
            end;
          end;
        end;
      end;
    end
    else if ShortDateFormatShortStr = 'ymd' then
    begin
      ThisYearAtStart := False;
      if ((Pos(s[1], NumStr) > 0) and (Pos(s[2], NumStr) > 0)) then
      begin
        if StrToInt(Copy(s, 1, 2)) > 31 then
          ThisYearAtStart := True
        else if ((Pos(s[3], NumStr) > 0) and (Pos(s[4], NumStr) > 0)) then
          ThisYearAtStart := True
        else if (Length(s) - s2) = 1 then
          ThisYearAtStart := True;   
      end;
      if ThisYearAtStart then
      begin
        if ((Pos(s[s1 + 1], NumStr) > 0) and (Pos(s[s1 + 2], NumStr) > 0)) then
        begin
          if StrToInt(Copy(s, s1 + 1, 2)) > 12 then
          begin
            s := Copy(s, 1, s1) +
                 Copy(s, s2 + 1, Length(s) - s2) + DateSeparator +
                 Copy(s, s1 + 1, s2 - s1 - 1);
          end;
        end;
      end;
    end;
    Result := s;
  end;
  function HandleTwoValues: string;
  var
    i, cc, ss: integer;
  begin
    for i := 1 to Length(s) do
    begin
      if s[i] = DateSeparator then
        Inc(cc);
    end;
    if cc = 1 then // only month and day
    begin
      ss := Pos(DateSeparator, s);
      s := Copy(s, ss + 1, Length(s) - ss) + DateSeparator +
           Copy(s, 1, ss - 1);
    end;
    Result := s;
  end;
begin
  ShortDateFormatShortStr := GetShortDateFormatShortStr;
  doublesep := DateSeparator + DateSeparator;
  s := Trim(s);
  try
    Result := StrToDate(s);
  except
    on EConvertError do
    begin
      s := ReplaceDateSeparator(['.', ',', '/', '|', '-', ' ']);
      try
        Result := StrToDate(s);
      except
        on EConvertError do
        begin
          s := CheckYearOrder(s);
          try
            Result := StrToDate(s);
          except
            on EConvertError do
            begin
              //Long Month names: 
              Replaced := False;
              MonthNameStrFound := False;
              s := ReplaceMonthForeignStr(['Jänner', 'Februar', 'März', 'April', 'Mai', 'Juni',
                   'Juli', 'August', 'September', 'Oktober', 'November', 'Dezember']);
              if not Replaced then
                s := ReplaceMonthForeignStr(['January', 'February', 'March', 'April', 'May', 'June',
                     'July', 'August', 'September', 'October', 'November', 'December']);
              MonthNameStrFound := Replaced;
              try
                Result := StrToDate(s);
              except
                on EConvertError do
                begin
                  //Short Month names:
                  Replaced := False;
                  s := ReplaceMonthForeignStr(['Jän', 'Feb', 'Mär', 'Apr', 'Mai', 'Jun',
                                               'Jul', 'Aug', 'Sep', 'Okt', 'Nov', 'Dez']);
                  if not Replaced then
                    s := ReplaceMonthForeignStr(['Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun',
                                                 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec']);
                  if ((not MonthNameStrFound) and (not Replaced)) then
                    s := GetMonthDayOrderFromNumbers;
                  try
                    Result := StrToDate(s);
                  except
                    on EConvertError do
                    begin
                      s := ReplaceMonthLocalStr;
                      try
                        Result := StrToDate(s); 
                      except
                        on EConvertError do
                        begin
                          s := HandleTwoValues;
                          Result := StrToDate(s); //Last try
                        end;
                      end;
                    end;
                  end;
                end;
              end;
            end;
          end;
        end;
      end;
    end;
  end;
end;