Mega Code Archive
Oracle like DateTime Convertor (to_char)
<![CDATA[
Title: Oracle-like Date/Time Convertor (to_char)
Question: This functions serves as an example of how to recursively parse a string for TOKENS and LITERALS and return a formated string of a given TDateTime. Whilst it does not add much more functionality than Delphi's FormatDateTime(), it does give you the ability to add custom tokens of your choice eg.
YEAR - return the year spelled out - 'NINETEEN-FORTY-SIX'
MR - return the month in Roman numerals - XII
DSFX - return day of month with suffix - 21st
The syntax is loosely based on Oracle's to_char() function and mainly serves as a tutor of how to implement a TOKEN parser.
statements such as
label1.caption := to_char(Now,'Date DSFX Month Year');
'Date 21st August Twenty-Zero-One' would be shown.
Valid format tokens areYEAR FORMATS
------------------------------------------------------------------
YY Last 2 digits of year : 01
YYYY Four-digit year : 2001
YEAR Year spelled out : TWENTY-ZERO-ONE
Year Same as YEAR, capitalised : Twenty-Zero-One
year Same as year, all lowercase : twenty-zero-one
YQ Quarter of year 1-4 : 3
MONTH FORMATS
------------------------------------------------------------------
M Number of month (no leading zero) : 3
MM Number of month (leading zero) : 03
MR Month in Roman : XII
MON Three-Letter month abbreviation : AUG
Mon Same as MON, but with initial capital : Aug
mon Same as MON, but all lowercase : aug
MONTH Month fully spelled out : AUGUST
Month Same as MONTH, initial capital : August
month Same as MONTH, but all lowercase : august
DAY FORMATS
-----------------------------------------------------------------
D Day of month (no leading zero) : 6
DD Day of month (leading zero) : 06
DSFX Day of month with suffix st,nd,rd th : 2nd
DY Three-letter day abbreviation : FRI
Dy Same as DY, capitalised : Fri
dy Same as DY, all lowercase : fri
DAY Day fully spelled out : FRIDAY
Day Same as DAY, capitalised : Friday
day Same as DAY, all lowercase : friday
DWK Day of week Sunday = 1 : 6
DYR Day of year : 321
HOUR FORMATS
-----------------------------------------------------------------
H Hour of day 1-12 (no leading zero) : 7
HH Hour of day 1-12 (leading zero) : 07
H24 Hour of day 24hr (no leading zero) : 7
HH24 Hour of day 24hr (leading zero) : 07
AMPM AM/PM depending on 12:00AmPm Same as AMPM, capitalised : Am
ampm Same as AMPM, all lowercase : am
MINUTES FORMATS
-----------------------------------------------------------------
MI Minute of hour (no leading zero) : 8
MMI Minute of hour (leading zero) : 08
SECONDS FORMATS
-----------------------------------------------------------------
S Seconds of minute (no leading zero) : 9
SS Seconds of minute (leading zero) : 09
SM Seconds since midnite 0-86399 : 43000
Z MSeconds of second (no leading zero) : 5
ZZZ MSeconds of second (leading zero) : 005
NUMERIC RAW FORMATS
-----------------------------------------------------------------
RD Numeric raw date (int part) days since 30/12/1899 : 56432
RT Numeric raw time (frac part of 24h) : 0.9876
RDT Numeric raw date/time (float) : 67543.98765
Answer:
function to_char(DT : TDateTime; const FormatStr : string) : string;
var RetVar,FmtStr,Token : string;
Y,M,D,H,N,S,Z : word;
// Return year spelled out - Valid 1600 - 2200
function GetYearName(Mode : integer) : string;
var Retvar,T : string;
begin
case Y div 100 of
0..15 : RetVar := 'Pretime()-';
16 : RetVar := 'Sixteen-';
17 : RetVar := 'Seventeen-';
18 : RetVar := 'Eighteen-';
19 : RetVar := 'Nineteen-';
20 : RetVar := 'Twenty-';
21 : RetVar := 'Twentyone-';
22 : RetVar := 'Twentytwo-';
23..99 : Retvar := 'Posttime()-';
end;
T := copy(FormatFloat('0000',Y),3,1);
case T[1] of
'0' : Retvar := RetVar + 'Zero-';
'1' : Retvar := RetVar + 'Ten-';
'2' : Retvar := RetVar + 'Twenty-';
'3' : Retvar := RetVar + 'Thirty-';
'4' : Retvar := RetVar + 'Forty-';
'5' : Retvar := RetVar + 'Fifty-';
'6' : Retvar := RetVar + 'Sixty-';
'7' : Retvar := RetVar + 'Seventy-';
'8' : Retvar := RetVar + 'Eighty-';
'9' : Retvar := RetVar + 'Ninety-';
end;
case Y mod 10 of
0 : Retvar := RetVar + 'Zero';
1 : Retvar := RetVar + 'One';
2 : Retvar := RetVar + 'Two';
3 : Retvar := RetVar + 'Three';
4 : Retvar := RetVar + 'Four';
5 : Retvar := RetVar + 'Five';
6 : Retvar := RetVar + 'Six';
7 : Retvar := RetVar + 'Seven';
8 : Retvar := RetVar + 'Eight';
9 : Retvar := RetVar + 'Nine';
end;
if Mode = 0 then RetVar := Uppercase(RetVar);
if Mode = 2 then Retvar := LowerCase(RetVar);
Result := Retvar;
end;
// Evaluate Token
procedure EvalToken;
var TokenStr : string;
begin
TokenStr := Token;
// Year formats
if UpperCase(Token) = 'YYYY' then TokenStr := FormatFloat('0000',Y);
if UpperCase(Token) = 'YY' then TokenStr :=
copy(FormatFloat('0000',Y),3,2);
if Token = 'YEAR' then TokenStr := GetYearName(0);
if Token = 'Year' then TokenStr := GetYearName(1);
if Token = 'year' then TokenStr := GetYearName(2);
if UpperCase(Token) = 'YQ' then begin
case M of
1..3 : TokenStr := '1';
4..6 : TokenStr := '2';
7..9 : TokenStr := '3';
10..12 : TokenStr := '4';
end;
end;
// Month formats
if UpperCase(Token) = 'MM' then TokenStr := FormatFloat('00',M);
if UpperCase(Token) = 'M' then TokenStr := FormatFloat('#0',M);
if Token = 'MON' then TokenStr := UpperCase(FormatDateTime('mmm',DT));
if Token = 'Mon' then begin
TokenStr := LowerCase(FormatDateTime('mmm',DT));
TokenStr[1] := UpCase(TokenStr[1]);
end;
if Token = 'mon' then TokenStr := LowerCase(FormatDateTime('mmm',DT));
if Token = 'MONTH' then TokenStr := UpperCase(FormatDateTime('mmmm',DT));
if Token = 'Month' then begin
TokenStr := LowerCase(FormatDateTime('mmmm',DT));
TokenStr[1] := UpCase(TokenStr[1]);
end;
if Token = 'month' then TokenStr := LowerCase(FormatDateTime('mmmm',DT));
if UpperCase(Token) = 'MR' then begin
case M of
1 : TokenStr := 'I';
2 : TokenStr := 'II';
3 : TokenStr := 'III';
4 : TokenStr := 'IV';
5 : TokenStr := 'V';
6 : TokenStr := 'VI';
7 : TokenStr := 'VII';
8 : TokenStr := 'VIII';
9 : TokenStr := 'IX';
10: TokenStr := 'X';
11: TokenStr := 'XI';
12: TokenStr := 'XII';
end;
end;
// Day formats
if UpperCase(Token) = 'DD' then TokenStr := FormatFloat('00',D);
if UpperCase(Token) = 'D' then TokenStr := FormatFloat('#0',D);
if Token = 'DY' then TokenStr := UpperCase(FormatDateTime('ddd',DT));
if Token = 'Dy' then begin
TokenStr := LowerCase(FormatDateTime('ddd',DT));
TokenStr[1] := UpCase(TokenStr[1]);
end;
if Token = 'dy' then TokenStr := LowerCase(FormatDateTime('ddd',DT));
if Token = 'DAY' then TokenStr := UpperCase(FormatDateTime('dddd',DT));
if Token = 'Day' then begin
TokenStr := LowerCase(FormatDateTime('dddd',DT));
TokenStr[1] := UpCase(TokenStr[1]);
end;
if Token = 'day' then TokenStr := LowerCase(FormatDateTime('dddd',DT));
if UpperCase(Token) = 'DWK' then
TokenStr := FormatFloat('0',DayOfWeek(DT));
if UpperCase(Token) = 'DYR' then
TokenStr := FormatFloat('##0',trunc(DT) -
trunc(EncodeDate(Y,1,1)) + 1);
if UpperCase(Token) = 'DSFX' then begin
TokenStr := FormatFloat('#0',D);
case D of
1,21,31 : TokenStr := TokenStr + 'st';
2,22 : TokenStr := TokenStr + 'nd';
3,23 : TokenStr := TokenStr + 'rd';
else
TokenStr := TokenStr + 'th';
end;
end;
// Hour formats
if UpperCase(Token) = 'HH' then begin
if H 12 then
TokenStr := FormatFloat('00',H - 12)
else
TokenStr := FormatFloat('00',H);
end;
if UpperCase(Token) = 'H' then begin
if H 12 then
TokenStr := FormatFloat('#0',H - 12)
else
TokenStr := FormatFloat('#0',H);
end;
if UpperCase(Token) = 'HH24' then TokenStr := FormatFloat('00',H);
if UpperCase(Token) = 'H24' then TokenStr := FormatFloat('#0',H);
if Token = 'AMPM' then if H if Token = 'AmPm' then if H if Token = 'ampm' then if H
// Minutes format
if UpperCase(Token) = 'MMI' then TokenStr := FormatFloat('00',N);
if UpperCase(Token) = 'MI' then TokenStr := FormatFloat('#0',N);
// Seconds format
if UpperCase(Token) = 'SS' then TokenStr := FormatFloat('00',S);
if UpperCase(Token) = 'S' then TokenStr := FormatFloat('#0',S);
if UpperCase(Token) = 'SM' then TokenStr :=
FormatFloat('#0',(H * 60 * 60) + (N * 60) + 60);
if UpperCase(Token) = 'ZZZ' then TokenStr := FormatFloat('000',Z);
if UpperCase(Token) = 'Z' then TokenStr := FormatFloat('#0',Z);
// Numeric Raw format
if UpperCase(Token) = 'RD' then TokenStr := FloatToStr(trunc(DT));
if UpperCase(Token) = 'RT' then TokenStr := FloatToStr(frac(DT));
if UpperCase(Token) = 'RDT' then TokenStr := FloatToStr(DT);
RetVar := RetVar + TokenStr;
end;
// Recursive routine to process format tokens
procedure ParseFormatStr;
var i : integer;
begin
if FmtStr '' then begin
i := 1;
// Get any literal chars and add to return value
while (i (not (FmtStr[i] in ['2','4','a'..'z','A'..'Z'])) do begin
RetVar := RetVar + FmtStr[i];
inc(i);
end;
FmtStr := copy(FmtStr,i,length(FmtStr));
i := 1;
Token := '';
// Get token
while (i (FmtStr[i] in ['2','4','a'..'z','A'..'Z']) do begin
Token := Token + FmtStr[i];
inc(i);
end;
EvalToken; // Format token into correct value
FmtStr := copy(FmtStr,i,length(FmtStr));
ParseFormatStr; // Call recursively until complete
end;
end;
begin
RetVar := '';
FmtStr := FormatStr;
DecodeDate(DT,Y,M,D);
DecodeTime(DT,H,N,S,Z);
ParseFormatStr;
Result := RetVar;
end;
]]>