unit ABSD4Routines;

interface

{$I ABSVer.inc}       

uses Windows, Classes, Sysutils,
{$IFNDEF D5H}
     Db,
{$ENDIF}
     ABSExcept,
     ABSConst;


const
  kernel = 'kernel32.dll';
  oleaut = 'oleaut32.dll';

var
  ClearAnyProc: Pointer;  { Handler clearing a varAny }

type

{$IFNDEF D5H}
{ TMasterDataLink }

  TMasterDataLink = class(TDetailDataLink)
  private
    FDataSet: TDataSet;
    FFieldNames: AnsiString;
    FFields: TList;
    FOnMasterChange: TNotifyEvent;
    FOnMasterDisable: TNotifyEvent;
    procedure SetFieldNames(const Value: AnsiString);
  protected
    procedure ActiveChanged; override;
    procedure CheckBrowseMode; override;
    function GetDetailDataSet: TDataSet; override;
    procedure LayoutChanged; override;
    procedure RecordChanged(Field: TField); override;
  public
    constructor Create(DataSet: TDataSet);
    destructor Destroy; override;
    property FieldNames: AnsiString read FFieldNames write SetFieldNames;
    property Fields: TList read FFields;
    property OnMasterChange: TNotifyEvent read FOnMasterChange write FOnMasterChange;
    property OnMasterDisable: TNotifyEvent read FOnMasterDisable write FOnMasterDisable;
  end;
{$ENDIF}

  StrRec = packed record
    allocSiz: Longint;
    refCnt: Longint;
    length: Longint;
  end;
{ FloatToText, FloatToTextFmt, TextToFloat, and FloatToDecimal type codes }

//  TFloatValue = (fvExtended, fvCurrency);

{ FloatToText format codes }

//  TFloatFormat = (ffGeneral, ffExponent, ffFixed, ffNumber, ffCurrency);

{ FloatToDecimal result record }

  TFloatRec = packed record
    Exponent: Smallint;
    Negative: Boolean;
    Digits: array[0..20] of AnsiChar;
  end;


  PMemoryManager = ^TMemoryManager;
  TMemoryManager = record
    GetMem: function(Size: Integer): Pointer;
    FreeMem: function(P: Pointer): Integer;
    ReallocMem: function(P: Pointer; Size: Integer): Pointer;
  end;
  TFormatSettings = record
    CurrencyFormat: Byte;
    NegCurrFormat: Byte;
    ThousandSeparator: AnsiChar;
    DecimalSeparator: AnsiChar;
    CurrencyDecimals: Byte;
    DateSeparator: AnsiChar;
    TimeSeparator: AnsiChar;
    ListSeparator: AnsiChar;
    CurrencyString: AnsiString;
    ShortDateFormat: AnsiString;
    LongDateFormat: AnsiString;
    TimeAMString: AnsiString;
    TimePMString: AnsiString;
    ShortTimeFormat: AnsiString;
    LongTimeFormat: AnsiString;
    ShortMonthNames: array[1..12] of AnsiString;
    LongMonthNames: array[1..12] of AnsiString;
    ShortDayNames: array[1..7] of AnsiString;
    LongDayNames: array[1..7] of AnsiString;
    TwoDigitYearCenturyWindow: Word;
  end;

const
        skew = sizeof(StrRec);
        rOff = sizeof(StrRec) - sizeof(Longint); { refCnt offset }
        overHead = sizeof(StrRec) + 1;

const
  MinCurrency: Currency = -922337203685477.5807 {$IFDEF LINUX} + 1 {$ENDIF};  //!! overflow?
  MaxCurrency: Currency =  922337203685477.5807 {$IFDEF LINUX} - 1 {$ENDIF};  //!! overflow?

const


  reInvalidPtr        = 2;
  reVarInvalidOp      = 16;
(*
  reOutOfMemory       = 1;
  reDivByZero         = 3;
  reRangeError        = 4;
  reIntOverflow       = 5;
  reInvalidOp         = 6;
  reZeroDivide        = 7;
  reOverflow          = 8;
  reUnderflow         = 9;
  reInvalidCast       = 10;
  reAccessViolation   = 11;
  reStackOverflow     = 12;
  reControlBreak      = 13;
  rePrivInstruction   = 14;
  reVarTypeCast       = 15;
  reVarDispatch       = 17;
  reVarArrayCreate    = 18;
  reVarNotArray       = 19;
  reVarArrayBounds    = 20;
  reAssertionFailed   = 21;
  reExternalException = 22;     { not used here; in SysUtils }
  reIntfCastError     = 23;
  reSafeCallError     = 24;
*)
function ABS_VarArrayGet(var A: Variant; IndexCount: Integer;
  Indices: Integer): Variant; cdecl;
function VarArrayGet(const A: Variant; const Indices: array of Integer): Variant;

{ Memory manager support }

procedure GetMemoryManager(var MemMgr: TMemoryManager);
procedure SetMemoryManager(const MemMgr: TMemoryManager);
function IsMemoryManagerSet: Boolean;
procedure Error(errorCode: Byte);

{ FloatToCurr will range validate a value to make sure it falls
  within the acceptable currency range }
{ FloatToCurr will range validate a value to make sure it falls
  within the acceptable currency range }

function FloatToCurr(const Value: Extended): Currency;
function TryFloatToCurr(const Value: Extended; out AResult: Currency): Boolean;

function TryStrToFloat(const S: AnsiString; out Value: Extended): Boolean; overload;

function TryStrToFloat(const S: AnsiString; out Value: Double): Boolean; overload;

function TryStrToFloat(const S: AnsiString; out Value: Single): Boolean; overload;


(*
function FloatToStr(Value: Extended): AnsiString; overload;
function FloatToStr(Value: Extended;
  const FormatSettings: TFormatSettings): AnsiString; overload;
  
{ StrToFloat converts the given string to a floating-point value. The string
  must consist of an optional sign (+ or -), a string of digits with an
  optional decimal point, and an optional 'E' or 'e' followed by a signed
  integer. Leading and trailing blanks in the string are ignored. The
  DecimalSeparator global variable defines the character that must be used
  as a decimal point. Thousand separators and currency symbols are not
  allowed in the string. If the string doesn't contain a valid value, an
  EConvertError exception is raised. }

function StrToFloat(const S: AnsiString): Extended; overload;
function StrToFloat(const S: AnsiString;
  const FormatSettings: TFormatSettings): Extended; overload;

function StrToFloatDef(const S: AnsiString;
  const Default: Extended): Extended; overload;
function StrToFloatDef(const S: AnsiString; const Default: Extended;
  const FormatSettings: TFormatSettings): Extended; overload;


{ FloatToText converts the given floating-point value to its decimal
  representation using the specified format, precision, and digits. The
  Value parameter must be a variable of type Extended or Currency, as
  indicated by the ValueType parameter. The resulting string of characters
  is stored in the given buffer, and the returned value is the number of
  characters stored. The resulting string is not null-terminated. For
  further details, see the description of the FloatToStrF function. }

function FloatToText(BufferArg: PAnsiChar; const Value; ValueType: TFloatValue;
  Format: TFloatFormat; Precision, Digits: Integer): Integer; overload;
function FloatToText(BufferArg: PAnsiChar; const Value; ValueType: TFloatValue;
  Format: TFloatFormat; Precision, Digits: Integer;
  const FormatSettings: TFormatSettings): Integer; overload;

function FloatToCurr(const Value: Extended): Currency;
function TryFloatToCurr(const Value: Extended; out AResult: Currency): Boolean;


*)

{ StrToBool converts the given string to a boolean value.  If the string
  doesn't contain a valid value, an EConvertError exception is raised.
  BoolToStr converts boolean to a string value that in turn can be converted
  back into a boolean.  BoolToStr will always pick the first element of
  the TrueStrs/FalseStrs arrays. }

var
  TrueBoolStrs: array of AnsiString;
  FalseBoolStrs: array of AnsiString;

const
  DefaultTrueBoolStr = 'True';   // DO NOT LOCALIZE
  DefaultFalseBoolStr = 'False'; // DO NOT LOCALIZE

function StrToBool(const S: AnsiString): Boolean;
function StrToBoolDef(const S: AnsiString; const Default: Boolean): Boolean;
function TryStrToBool(const S: AnsiString; out Value: Boolean): Boolean;
function BoolToStr(B: Boolean; UseBoolStrs: Boolean = False): AnsiString;
{$IFNDEF D5H}
{ AnsiSameText compares S1 to S2, without case-sensitivity. The compare
  operation is controlled by the current Windows locale. The return value
  is True if AnsiCompareText would have returned 0. }

function AnsiSameText(const S1, S2: AnsiString): Boolean;
{$ENDIF}

procedure FreeAndNil(var Obj);

type
  TValueSign = -1..1;
const
  NegativeValue = Low(TValueSign);
  ZeroValue = 0;
  PositiveValue = High(TValueSign);

function Sign(const AValue: Integer): TValueSign; overload;
function Sign(const AValue: Int64): TValueSign; overload;
function Sign(const AValue: Double): TValueSign; overload;

const
{ Units of time }

  HoursPerDay   = 24;
  MinsPerHour   = 60;
  SecsPerMin    = 60;
  MSecsPerSec   = 1000;
  MinsPerDay    = HoursPerDay * MinsPerHour;
  SecsPerDay    = MinsPerDay * SecsPerMin;
  MSecsPerDay   = SecsPerDay * MSecsPerSec;

  SMissingDateTimeField = '?';
  SInvalidDateTime = '''''%s'''' is not a valid date and time';

  { Used in RecodeDate, RecodeTime and RecodeDateTime for those datetime }
  {  fields you want to leave alone }
  RecodeLeaveFieldAsIs = High(Word);

function EncodeDateTime(const AYear, AMonth, ADay, AHour, AMinute, ASecond,
  AMilliSecond: Word): TDateTime;
function TryEncodeDateTime(const AYear, AMonth, ADay, AHour, AMinute, ASecond,
  AMilliSecond: Word; out AValue: TDateTime): Boolean;
function TryEncodeDate(Year, Month, Day: Word; out Date: TDateTime): Boolean;
function TryEncodeTime(Hour, Min, Sec, MSec: Word; out Time: TDateTime): Boolean;
procedure InvalidDateTimeError(const AYear, AMonth, ADay, AHour, AMinute,
  ASecond, AMilliSecond: Word; const ABaseDate: TDateTime = 0);

implementation


var
  MemoryManager: TMemoryManager = (
    GetMem: SysGetMem;
    FreeMem: SysFreeMem;
    ReallocMem: SysReallocMem);

{$I ABSGETMEM.INC }

function VariantClear(var V: Variant): Integer; stdcall;
  external oleaut name 'VariantClear';

function SafeArrayPtrOfIndex(VarArray: PVarArray; Indices: Pointer;
  var pvData: Pointer): HResult; stdcall;
  external oleaut name 'SafeArrayPtrOfIndex';

function SafeArrayGetElement(VarArray: PVarArray; Indices,
  Data: Pointer): Integer; stdcall;
  external oleaut name 'SafeArrayGetElement';

function GetVarArray(const A: Variant): PVarArray;
begin
  if TVarData(A).VType and varArray = 0 then
   raise EABSException.Create(10434,ErrorLVarNotArray);
  if TVarData(A).VType and varByRef <> 0 then
    Result := PVarArray(TVarData(A).VPointer^) else
    Result := TVarData(A).VArray;
end;

procedure _FreeMem;
asm
        TEST    EAX,EAX
        JE      @@1
        CALL    MemoryManager.FreeMem
        OR      EAX,EAX
        JNE     @@2
@@1:    RET
@@2:    MOV     AL,reInvalidPtr
        JMP     Error
end;

procedure Error(errorCode: Byte);
begin
 raise EABSException.Create(10437,ErrorLSystemError,[errorCode]);
end;

procedure _LStrClr(var S: AnsiString);
asm
        { ->    EAX pointer to str      }

        MOV     EDX,[EAX]                       { fetch str                     }
        TEST    EDX,EDX                         { if nil, nothing to do         }
        JE      @@done
        MOV     dword ptr [EAX],0               { clear str                     }
        MOV     ECX,[EDX-skew].StrRec.refCnt    { fetch refCnt                  }
        DEC     ECX                             { if < 0: literal str           }
        JL      @@done
   LOCK DEC     [EDX-skew].StrRec.refCnt        { threadsafe dec refCount       }
        JNE     @@done
        PUSH    EAX
        LEA     EAX,[EDX-skew].StrRec.refCnt    { if refCnt now zero, deallocate}
        CALL    _FreeMem
        POP     EAX
@@done:
end;

procedure VarInvalidOp;
asm
        MOV     AL,reVarInvalidOp
        JMP     Error
end;


procedure _VarClear(var V : Variant);
asm
        XOR     EDX,EDX
        MOV     DX,[EAX].TVarData.VType
        TEST    EDX,varByRef
        JNE     @@2
        CMP     EDX,varOleStr
        JB      @@2
        CMP     EDX,varString
        JE      @@1
        CMP     EDX,varAny
        JNE     @@3
        JMP     [ClearAnyProc]
@@1:    MOV     [EAX].TVarData.VType,varEmpty
        ADD     EAX,OFFSET TVarData.VString
        JMP     _LStrClr
@@2:    MOV     [EAX].TVarData.VType,varEmpty
        RET
@@3:    PUSH    EAX
        CALL    VariantClear
end;


function ABS_VarArrayGet(var A: Variant; IndexCount: Integer;
  Indices: Integer): Variant; cdecl;
var
  VarArrayPtr: PVarArray;
  VarType: Integer;
  P: Pointer;
begin
  if TVarData(A).VType and varArray = 0 then
   raise EABSException.Create(10433,ErrorLVarNotArray);
  VarArrayPtr := GetVarArray(A);
  if VarArrayPtr^.DimCount <> IndexCount then
   raise EABSException.Create(10435,ErrorLVarArrayBounds,
    [VarArrayPtr^.DimCount,IndexCount]);
  VarType := TVarData(A).VType and varTypeMask;
  _VarClear(Result);
  if VarType = varVariant then
  begin
    if SafeArrayPtrOfIndex(VarArrayPtr, @Indices, P) <> 0 then
     raise EABSException.Create(10436,ErrorLVarArrayBounds,
      [-1,-1]);

    Result := PVariant(P)^;
  end else
  begin
  if SafeArrayGetElement(VarArrayPtr, @Indices,
      @TVarData(Result).VPointer) <> 0 then
       raise EABSException.Create(10438,ErrorLVarArrayBounds,
        [-1,-1]);
    TVarData(Result).VType := VarType;
  end;
end; //ABS_VarArrayGet


function VarArrayGet(const A: Variant; const Indices: array of Integer): Variant;
asm
        {     ->EAX     Pointer to A            }
        {       EDX     Pointer to Indices      }
        {       ECX     High bound of Indices   }
        {       [EBP+8] Pointer to result       }

        PUSH    EBX

        MOV     EBX,ECX
        INC     EBX
        JLE     @@endLoop
@@loop:
        PUSH    [EDX+ECX*4].Integer
        DEC     ECX
        JNS     @@loop
@@endLoop:
        PUSH    EBX
        PUSH    EAX
        MOV     EAX,[EBP+8]
        PUSH    EAX
        CALL    ABS_VarArrayGet
        LEA     ESP,[ESP+EBX*4+3*4]

        POP     EBX
end; //VarArrayGet

procedure GetMemoryManager(var MemMgr: TMemoryManager);
begin
  MemMgr := MemoryManager;
end;

procedure SetMemoryManager(const MemMgr: TMemoryManager);
begin
  MemoryManager := MemMgr;
end;

function IsMemoryManagerSet: Boolean;
begin
  with MemoryManager do
    Result := (@GetMem <> @SysGetMem) or (@FreeMem <> @SysFreeMem) or
      (@ReallocMem <> @SysReallocMem);
end;

(*
function StrToFloat(const S: AnsiString): Extended;
begin
  if not TextToFloat(PAnsiChar(S), Result, fvExtended) then
    raise EABSException.Create(10441,ErrorLInvalidFloat,[S]);
end;

function StrToFloat(const S: AnsiString;
  const FormatSettings: TFormatSettings): Extended;
begin
  if not TextToFloat(PAnsiChar(S), Result, fvExtended, FormatSettings) then
    raise EABSException.Create(10442,ErrorLInvalidFloat,[S]);
end;

function StrToFloatDef(const S: AnsiString; const Default: Extended): Extended;
begin
  if not TextToFloat(PAnsiChar(S), Result, fvExtended) then
    Result := Default;
end;

function StrToFloatDef(const S: AnsiString; const Default: Extended;
  const FormatSettings: TFormatSettings): Extended;
begin
  if not TextToFloat(PAnsiChar(S), Result, fvExtended, FormatSettings) then
    Result := Default;
end;



function FloatToStr(Value: Extended): AnsiString;
var
  Buffer: array[0..63] of AnsiChar;
begin
  SetString(Result, Buffer, FloatToText(Buffer, Value, fvExtended,
    ffGeneral, 15, 0));
end;

function FloatToStr(Value: Extended;
  const FormatSettings: TFormatSettings): AnsiString;
var
  Buffer: array[0..63] of AnsiChar;
begin
  SetString(Result, Buffer, FloatToText(Buffer, Value, fvExtended,
    ffGeneral, 15, 0, FormatSettings));
end;

*)

function TryFloatToCurr(const Value: Extended; out AResult: Currency): Boolean;
begin
  Result := (Value >= MinCurrency) and (Value <= MaxCurrency);
  if Result then
    AResult := Value;
end;

function FloatToCurr(const Value: Extended): Currency;
begin
  if not TryFloatToCurr(Value, Result) then
    raise EABSException.Create(10439,ErrorLInvalidCurrency,[FloatToStr(Value)]);
end;

procedure VerifyBoolStrArray;
begin
  if Length(TrueBoolStrs) = 0 then
  begin
    SetLength(TrueBoolStrs, 1);
    TrueBoolStrs[0] := DefaultTrueBoolStr;
  end;
  if Length(FalseBoolStrs) = 0 then
  begin
    SetLength(FalseBoolStrs, 1);
    FalseBoolStrs[0] := DefaultFalseBoolStr;
  end;
end;

function StrToBool(const S: AnsiString): Boolean;
begin
  if not TryStrToBool(S, Result) then
    raise EABSException.Create(10440,ErrorLInvalidBoolean,[s]);
end;

function StrToBoolDef(const S: AnsiString; const Default: Boolean): Boolean;
begin
  if not TryStrToBool(S, Result) then
    Result := Default;
end;


function TryStrToBool(const S: AnsiString; out Value: Boolean): Boolean;
  function CompareWith(const aArray: array of AnsiString): Boolean;
  var
    I: Integer;
  begin
    Result := False;
    for I := Low(aArray) to High(aArray) do
      if AnsiSameText(S, aArray[I]) then
      begin
        Result := True;
        Break;
      end;
  end;
var
  LResult: Extended;
begin
  Result := TryStrToFloat(S, LResult);
  if Result then
    Value := LResult <> 0
  else
  begin
    VerifyBoolStrArray;
    Result := CompareWith(TrueBoolStrs);
    if Result then
      Value := True
    else
    begin
      Result := CompareWith(FalseBoolStrs);
      if Result then
        Value := False;
    end;
  end;
end;

function BoolToStr(B: Boolean; UseBoolStrs: Boolean = False): AnsiString;
const
  cSimpleBoolStrs: array [boolean] of AnsiString = ('0', '-1');
begin
  if UseBoolStrs then
  begin
    VerifyBoolStrArray;
    if B then
      Result := TrueBoolStrs[0]
    else
      Result := FalseBoolStrs[0];
  end
  else
    Result := cSimpleBoolStrs[B];
end;


function TryStrToFloat(const S: AnsiString; out Value: Extended): Boolean;
begin
  Result := TextToFloat(PAnsiChar(S), Value, fvExtended);
end;

function TryStrToFloat(const S: AnsiString; out Value: Double): Boolean;
var
  LValue: Extended;
begin
  Result := TextToFloat(PAnsiChar(S), LValue, fvExtended);
  if Result then
    Value := LValue;
end;


function TryStrToFloat(const S: AnsiString; out Value: Single): Boolean;
var
  LValue: Extended;
begin
  Result := TextToFloat(PAnsiChar(S), LValue, fvExtended);
  if Result then
    Value := LValue;
end;

{$IFNDEF D5H}
{ AnsiSameText compares S1 to S2, without case-sensitivity. The compare
  operation is controlled by the current Windows locale. The return value
  is True if AnsiCompareText would have returned 0. }

function AnsiSameText(const S1, S2: AnsiString): Boolean;
begin
  Result := CompareStringA(LOCALE_USER_DEFAULT, NORM_IGNORECASE, PAnsiChar(S1),
    Length(S1), PAnsiChar(S2), Length(S2)) = 2;
end;
{$ENDIF}

{$IFNDEF D5H}
{ TMasterDataLink }

constructor TMasterDataLink.Create(DataSet: TDataSet);
begin
  inherited Create;
  FDataSet := DataSet;
  FFields := TList.Create;
end;

destructor TMasterDataLink.Destroy;
begin
  FFields.Free;
  inherited Destroy;
end;

procedure TMasterDataLink.ActiveChanged;
begin
  FFields.Clear;
  if Active then
    try
      DataSet.GetFieldList(FFields, FFieldNames);
    except
      FFields.Clear;
      raise;
    end;
  if FDataSet.Active and not (csDestroying in FDataSet.ComponentState) then
    if Active and (FFields.Count > 0) then
    begin
      if Assigned(FOnMasterChange) then FOnMasterChange(Self);
    end else
      if Assigned(FOnMasterDisable) then FOnMasterDisable(Self);
end;

procedure TMasterDataLink.CheckBrowseMode;
begin
  if FDataSet.Active then FDataSet.CheckBrowseMode;
end;

function TMasterDataLink.GetDetailDataSet: TDataSet;
begin
  Result := FDataSet;
end;

procedure TMasterDataLink.LayoutChanged;
begin
  ActiveChanged;
end;

procedure TMasterDataLink.RecordChanged(Field: TField);
begin
  if (DataSource.State <> dsSetKey) and FDataSet.Active and
    (FFields.Count > 0) and ((Field = nil) or
    (FFields.IndexOf(Field) >= 0)) and
     Assigned(FOnMasterChange) then
    FOnMasterChange(Self);
end;

procedure TMasterDataLink.SetFieldNames(const Value: AnsiString);
begin
  if FFieldNames <> Value then
  begin
    FFieldNames := Value;
    ActiveChanged;
  end;
end;
{$ENDIF}

procedure FreeAndNil(var Obj);
var
  Temp: TObject;
begin
  Temp := TObject(Obj);
  Pointer(Obj) := nil;
  Temp.Free;
end;


function Sign(const AValue: Integer): TValueSign;
begin
  Result := ZeroValue;
  if AValue < 0 then
    Result := NegativeValue
  else if AValue > 0 then
    Result := PositiveValue;
end;

function Sign(const AValue: Int64): TValueSign;
begin
  Result := ZeroValue;
  if AValue < 0 then
    Result := NegativeValue
  else if AValue > 0 then
    Result := PositiveValue;
end;

function Sign(const AValue: Double): TValueSign;
begin
  if ((PInt64(@AValue)^ and $7FFFFFFFFFFFFFFF) = $0000000000000000) then
    Result := ZeroValue
  else if ((PInt64(@AValue)^ and $8000000000000000) = $8000000000000000) then
    Result := NegativeValue
  else
    Result := PositiveValue;
end;

function EncodeDateTime(const AYear, AMonth, ADay, AHour, AMinute, ASecond,
  AMilliSecond: Word): TDateTime;
begin
  if not TryEncodeDateTime(AYear, AMonth, ADay,
                           AHour, AMinute, ASecond, AMilliSecond, Result) then
    InvalidDateTimeError(AYear, AMonth, ADay,
                         AHour, AMinute, ASecond, AMilliSecond);
end;

function TryEncodeDateTime(const AYear, AMonth, ADay, AHour, AMinute, ASecond,
  AMilliSecond: Word; out AValue: TDateTime): Boolean;
var
  LTime: TDateTime;
begin
  Result := TryEncodeDate(AYear, AMonth, ADay, AValue);
  if Result then
  begin
    Result := TryEncodeTime(AHour, AMinute, ASecond, AMilliSecond, LTime);
    if Result then
      AValue := AValue + LTime;
  end;
end;

function TryEncodeDate(Year, Month, Day: Word; out Date: TDateTime): Boolean;
var
  I: Integer;
  DayTable: PDayTable;
begin
  Result := False;
  DayTable := @MonthDays[IsLeapYear(Year)];
  if (Year >= 1) and (Year <= 9999) and (Month >= 1) and (Month <= 12) and
    (Day >= 1) and (Day <= DayTable^[Month]) then
  begin
    for I := 1 to Month - 1 do Inc(Day, DayTable^[I]);
    I := Year - 1;
    Date := I * 365 + I div 4 - I div 100 + I div 400 + Day - DateDelta;
    Result := True;
  end;
end;

function TryEncodeTime(Hour, Min, Sec, MSec: Word; out Time: TDateTime): Boolean;
begin
  Result := False;
  if (Hour < HoursPerDay) and (Min < MinsPerHour) and (Sec < SecsPerMin) and (MSec < MSecsPerSec) then
  begin
    Time := (Hour * (MinsPerHour * SecsPerMin * MSecsPerSec) +
             Min * (SecsPerMin * MSecsPerSec) +
             Sec * MSecsPerSec +
             MSec) / MSecsPerDay;
    Result := True;
  end;
end;

procedure InvalidDateTimeError(const AYear, AMonth, ADay, AHour, AMinute,
  ASecond, AMilliSecond: Word; const ABaseDate: TDateTime);
  function Translate(AOrig, AValue: Word): AnsiString;
  begin
    if AValue = RecodeLeaveFieldAsIs then
      if ABaseDate = 0 then
        Result := SMissingDateTimeField
      else
        Result := IntToStr(AOrig)
    else
      Result := IntToStr(AValue);
  end;
var
  LYear, LMonth, LDay, LHour, LMinute, LSecond, LMilliSecond: Word;
begin
  DecodeDate(ABaseDate, LYear, LMonth, LDay);
  DecodeTime(ABaseDate, LHour, LMinute, LSecond, LMilliSecond);
  raise EConvertError.CreateFmt(SInvalidDateTime,
                                [Translate(LYear, AYear) + DateSeparator +
                                 Translate(LMonth, AMonth) + DateSeparator +
                                 Translate(LDay, ADay) + ' ' +
                                 Translate(LHour, AHour) + TimeSeparator +
                                 Translate(LMinute, AMinute) + TimeSeparator +
                                 Translate(LSecond, ASecond) + DecimalSeparator +
                                 Translate(LMilliSecond, AMilliSecond)]);
end;


initialization

  ClearAnyProc := @VarInvalidOp;

end.
