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;