My use case was `TMSWebcore. I have isolated it, removed all traces of Web and removed dependencies on my libraries. So it is compilable.
In case its not obvious what’s happening. I had an article in Delphi magazine using Delphi-1, where we dubbed this interposing class.
For VCL, I subclass them as registered components. But for TMSWebcore I didn’t want that learning curve - there was enough on the plate.
Tricks
As long as this unit is after all other units referring to TDateTimeField, it replaces the original class. (Its a trick I learnt from Microsoft C which had rubbish libraries, in the 70s)
GetText and SetText are not virtual, but I can make them so by declaring a replacement property and defining new accessors.
The purpose of this class is to add UTC / Local Timezone support to TMSWebcore. Defining it here, I can use it on all forms, without worrying about it. The actual conversion procedures are actually in my THTML class that stands between the browser and me. I have declared dummy ones, the removal which would have destroyed the logic of the code.
Just uploading as text, in case someone doesn’t want to download the file.
unit PBS.WEB.Data;
interface
uses
System.SysUtils, System.Classes, Data.DB;
const
xds_Filter_Prefix = '$filter=';
xds_Filter_And = ' and ';
{ Caveats
1. Needs to be towards the end in the uses clause
2. Use TDateFields for no time component or it will go wrong
}
type
TDateTimeField = class(Data.DB.TDateTimeField)
private
class var GStore_As_UTC : Boolean;
var FStore_As_UTC : Boolean;
protected
function GetAsDateTime : TDateTime; override;
procedure SetAsDateTime (Value : TDateTime); override;
(*
function GetAsVariant : Variant; override;
procedure SetAsVariant (Value : Variant); override;
*)
function GetAsString : string; override;
procedure SetAsString (const Value : string); override;
{$WARNINGS OFF}
function GetText : string;
procedure SetText (Value : string);
{$WARNINGS ON}
public
constructor Create (AOwner : TComponent); override;
class property Default_Store_As_UTC : Boolean read GStore_As_UTC
write GStore_As_UTC;
property Store_As_UTC : Boolean read FStore_As_UTC
write FStore_As_UTC;
{ Helper methods for separate date/time handling }
function GetDatePart : TDateTime;
function GetTimePart : TDateTime;
function GetTimeAsString : string;
procedure SetDateAndTime (ADate : TDateTime; ATime : TDateTime);
procedure SetDateAndTimeStr (ADate : TDateTime; ATimeStr : string);
property Text : string read GetText write SetText;
end;
implementation
{ Dummy up for testing }
function UTC_To_Local (AArg : TDateTime) : TDateTime; begin Result := 0; end;
function Local_To_UTC (AArg : TDateTime) : TDateTime; begin Result := 0; end;
{ TDateTimeField }
constructor TDateTimeField.Create (AOwner : TComponent);
begin
inherited;
{ Initialize from class default }
FStore_As_UTC := GStore_As_UTC;
end;
function TDateTimeField.GetAsDateTime : TDateTime;
begin
if FStore_As_UTC and (not IsNull)
then Result := UTC_To_Local (inherited GetAsDateTime)
else Result := inherited GetAsDateTime;
end;
procedure TDateTimeField.SetAsDateTime (Value : TDateTime);
begin
if FStore_As_UTC
then inherited SetAsDateTime (Local_To_UTC (Value))
else inherited SetAsDateTime (Value);
end;
function TDateTimeField.GetAsString : string;
begin
if FStore_As_UTC and (not IsNull)
then Result := DateTimeToStr (UTC_To_Local(inherited GetAsDateTime))
else Result := inherited GetAsString;
end;
procedure TDateTimeField.SetAsString (const Value : string);
var
LDateTime: TDateTime;
begin
if FStore_As_UTC and (Value <> '')
then begin
LDateTime := StrToDateTime (Value);
inherited SetAsDateTime (Local_To_UTC(LDateTime));
end
else inherited SetAsString (Value);
end;
(*
function TDateTimeField.GetAsVariant : Variant;
begin
TConsole.Log ('Get-V', Name);
if FStore_As_UTC and (not IsNull)
then Result := THtml.UTC_To_Local (inherited GetAsVariant)
else Result := inherited GetAsVariant;
end;
procedure TDateTimeField.SetAsVariant (Value : Variant);
begin
if FStore_As_UTC and (not VarIsNull(Value))
then inherited SetAsVariant (THtml.Local_To_UTC(VarToDateTime(Value)))
else inherited SetAsVariant (Value);
end;
*)
function TDateTimeField.GetText : string;
begin
if FStore_As_UTC and (not IsNull)
then Result := DateTimeToStr (AsDateTime)
else Result := inherited Text;
end;
procedure TDateTimeField.SetText (Value : string);
begin
inherited Text := Value;
end;
function TDateTimeField.GetDatePart : TDateTime;
begin
Result := Trunc (AsDateTime);
end;
function TDateTimeField.GetTimePart : TDateTime;
begin
Result := Frac (AsDateTime);
end;
function TDateTimeField.GetTimeAsString : string;
begin
Result := FormatDateTime ('hh:nn', AsDateTime);
end;
procedure TDateTimeField.SetDateAndTime (ADate, ATime : TDateTime);
var
LCombined : TDateTime;
LMins : Integer;
begin
LCombined := Trunc(ADate) + Frac(ATime);
{ Round to nearest minute to avoid precision issues }
LMins := Round(LCombined * 24 * 60);
LCombined := LMins / (24 * 60);
AsDateTime := LCombined;
end;
procedure TDateTimeField.SetDateAndTimeStr (ADate : TDateTime; ATimeStr : string);
var
LTimePart : TDateTime;
begin
if Pos(':', ATimeStr) > 0
then begin
{ Add seconds if not present }
if Pos(':', Copy(ATimeStr, Pos(':', ATimeStr) + 1, Length(ATimeStr))) = 0
then ATimeStr := ATimeStr + ':00';
LTimePart := StrToTime (ATimeStr);
end
else LTimePart := 0;
SetDateAndTime (ADate, LTimePart);
end;
initialization
TDateTimeField.GStore_As_UTC := True;
end.