cxvariants.pas

来自「胜天进销存源码,国产优秀的进销存」· PAS 代码 · 共 1,201 行 · 第 1/3 页

{********************************************************************}
{                                                                    }
{       Developer Express Visual Component Library                   }
{       ExpressDataController                                        }
{                                                                    }
{       Copyright (c) 1998-2008 Developer Express Inc.               }
{       ALL RIGHTS RESERVED                                          }
{                                                                    }
{   The entire contents of this file is protected by U.S. and        }
{   International Copyright Laws. Unauthorized reproduction,         }
{   reverse-engineering, and distribution of all or any portion of   }
{   the code contained in this file is strictly prohibited and may   }
{   result in severe civil and criminal penalties and will be        }
{   prosecuted to the maximum extent possible under the law.         }
{                                                                    }
{   RESTRICTIONS                                                     }
{                                                                    }
{   THIS SOURCE CODE AND ALL RESULTING INTERMEDIATE FILES            }
{   (DCU, OBJ, DLL, ETC.) ARE CONFIDENTIAL AND PROPRIETARY TRADE     }
{   SECRETS OF DEVELOPER EXPRESS INC. THE REGISTERED DEVELOPER IS    }
{   LICENSED TO DISTRIBUTE THE EXPRESSDATACONTROLLER AND ALL         }
{   ACCOMPANYING VCL CONTROLS AS PART OF AN EXECUTABLE PROGRAM ONLY. }
{                                                                    }
{   THE SOURCE CODE CONTAINED WITHIN THIS FILE AND ALL RELATED       }
{   FILES OR ANY PORTION OF ITS CONTENTS SHALL AT NO TIME BE         }
{   COPIED, TRANSFERRED, SOLD, DISTRIBUTED, OR OTHERWISE MADE        }
{   AVAILABLE TO OTHER INDIVIDUALS WITHOUT EXPRESS WRITTEN CONSENT   }
{   AND PERMISSION FROM DEVELOPER EXPRESS INC.                       }
{                                                                    }
{   CONSULT THE END USER LICENSE AGREEMENT FOR INFORMATION ON        }
{   ADDITIONAL RESTRICTIONS.                                         }
{                                                                    }
{********************************************************************}

unit cxVariants;

{$I cxVer.inc}

interface

uses
  SysUtils, Classes{$IFDEF DELPHI6}, Variants{$ENDIF};

type
  LargeInt = Int64;
  {$IFNDEF DELPHI6}
  TVarType = Word;
  {$ENDIF}
  TVariantArray = array of Variant;

  { Read/Write }

  TcxFiler = class
  private
    FStream: TStream;
  public
    constructor Create(AStream: TStream);
    property Stream: TStream read FStream;
  end;

  TcxReader = class(TcxFiler)
  public
    function ReadBoolean: Boolean;
    function ReadByte: Byte;
    function ReadCardinal: Cardinal;
    function ReadChar: Char;
    function ReadCurrency: Currency;
    function ReadDateTime: TDateTime;
    function ReadFloat: Extended;
    function ReadInteger: Integer;
    function ReadLargeInt: LargeInt;
    function ReadShortInt: ShortInt;
    function ReadSingle: Single;
    function ReadSmallInt: SmallInt;
    function ReadString: string;
    function ReadVariant: Variant;
    function ReadWideString: WideString;
    function ReadWord: Word;
  end;

  TcxWriter = class(TcxFiler)
  public
    procedure WriteBoolean(AValue: Boolean);
    procedure WriteByte(AValue: Byte);
    procedure WriteCardinal(AValue: Cardinal);
    procedure WriteChar(AValue: Char);
    procedure WriteCurrency(AValue: Currency);
    procedure WriteDateTime(AValue: TDateTime);
    procedure WriteFloat(AValue: Extended);
    procedure WriteInteger(AValue: Integer);
    procedure WriteLargeInt(AValue: LargeInt);
    procedure WriteShortInt(AValue: ShortInt);
    procedure WriteSingle(AValue: Single);
    procedure WriteSmallInt(AValue: SmallInt);
    procedure WriteString(const S: string);
    procedure WriteVariant(const AValue: Variant);
    procedure WriteWideString(const S: WideString);
    procedure WriteWord(AValue: Word);
  end;

function VarCompare(const V1, V2: Variant): Integer;
function VarEquals(const V1, V2: Variant): Boolean;
function VarEqualsExact(const V1, V2: Variant): Boolean;
function VarEqualsSoft(const V1, V2: Variant): Boolean;
function VarIndex(const AList: TVariantArray; const AValue: Variant): Integer;
function VarIsDate(const AValue: Variant): Boolean;
function VarIsNumericEx(const AValue: Variant): Boolean;
function VarIsSoftNull(const AValue: Variant): Boolean;
function VarToStrEx(const V: Variant): string;
function VarTypeIsCurrency(AVarType: TVarType): Boolean;
{$IFNDEF DELPHI6}
function FindVarData(const V: Variant): PVarData;
function VarIsFloat(const AValue: Variant): Boolean;
function VarIsNumeric(const AValue: Variant): Boolean;
function VarIsOrdinal(const AValue: Variant): Boolean;
function VarIsStr(const AValue: Variant): Boolean;
function VarIsType(const AValue: Variant; AVarType: TVarType): Boolean;
function VarSameValue(const V1, V2: Variant): Boolean;
{$ENDIF}
function VarBetweenArrayCreate(const AValue1, AValue2: Variant): Variant;
function VarListArrayCreate(const AValue: Variant): Variant;
procedure VarListArrayAddValue(var Value: Variant; const AValue: Variant);

function ReadStringFunc(AStream: TStream): string;
procedure ReadStringProc(AStream: TStream; var S: string);
procedure WriteStringProc(AStream: TStream; const S: string);

function ReadWideStringFunc(AStream: TStream): WideString;
procedure ReadWideStringProc(AStream: TStream; var S: WideString);
procedure WriteWideStringProc(AStream: TStream; const S: WideString);

function ReadVariantFunc(AStream: TStream): Variant;
procedure ReadVariantProc(AStream: TStream; var Value: Variant);
procedure WriteVariantProc(AStream: TStream; const AValue: Variant);

function ReadBooleanFunc(AStream: TStream): Boolean;
procedure ReadBooleanProc(AStream: TStream; var Value: Boolean);
procedure WriteBooleanProc(AStream: TStream; AValue: Boolean);

function ReadCharFunc(AStream: TStream): Char;
procedure ReadCharProc(AStream: TStream; var Value: Char);
procedure WriteCharProc(AStream: TStream; AValue: Char);

function ReadFloatFunc(AStream: TStream): Extended;
procedure ReadFloatProc(AStream: TStream; var Value: Extended);
procedure WriteFloatProc(AStream: TStream; AValue: Extended);

function ReadSingleFunc(AStream: TStream): Single;
procedure ReadSingleProc(AStream: TStream; var Value: Single);
procedure WriteSingleProc(AStream: TStream; AValue: Single);

function ReadCurrencyFunc(AStream: TStream): Currency;
procedure ReadCurrencyProc(AStream: TStream; var Value: Currency);
procedure WriteCurrencyProc(AStream: TStream; AValue: Currency);

function ReadDateTimeFunc(AStream: TStream): TDateTime;
procedure ReadDateTimeProc(AStream: TStream; var Value: TDateTime);
procedure WriteDateTimeProc(AStream: TStream; AValue: TDateTime);

function ReadIntegerFunc(AStream: TStream): Integer;
procedure ReadIntegerProc(AStream: TStream; var Value: Integer);
procedure WriteIntegerProc(AStream: TStream; AValue: Integer);

function ReadLargeIntFunc(AStream: TStream): LargeInt;
procedure ReadLargeIntProc(AStream: TStream; var Value: LargeInt);
procedure WriteLargeIntProc(AStream: TStream; AValue: LargeInt);

function ReadByteFunc(AStream: TStream): Byte;
procedure ReadByteProc(AStream: TStream; var Value: Byte);
procedure WriteByteProc(AStream: TStream; AValue: Byte);

function ReadSmallIntFunc(AStream: TStream): SmallInt;
procedure ReadSmallIntProc(AStream: TStream; var Value: SmallInt);
procedure WriteSmallIntProc(AStream: TStream; AValue: SmallInt);

function ReadCardinalFunc(AStream: TStream): Cardinal;
procedure ReadCardinalProc(AStream: TStream; var Value: Cardinal);
procedure WriteCardinalProc(AStream: TStream; AValue: Cardinal);

function ReadShortIntFunc(AStream: TStream): ShortInt;
procedure ReadShortIntProc(AStream: TStream; var Value: ShortInt);
procedure WriteShortIntProc(AStream: TStream; AValue: ShortInt);

function ReadWordFunc(AStream: TStream): Word;
procedure ReadWordProc(AStream: TStream; var Value: Word);
procedure WriteWordProc(AStream: TStream; AValue: Word);

implementation

uses
{$IFNDEF NONDB}
  {$IFDEF DELPHI6}
  FMTBcd, SqlTimSt,
  {$ENDIF}
{$ENDIF}
  Windows, cxDataConsts;

function VarArrayCompare(const V1, V2: Variant): Integer;
var
  I: Integer;
begin
  if VarIsArray(V1) and VarIsArray(V2) then
  begin
    Result := VarArrayHighBound(V1, 1) - VarArrayHighBound(V2, 1);
    if Result = 0 then
    begin
      for I := 0 to VarArrayHighBound(V1, 1) do
      begin
        Result := VarCompare(V1[I], V2[I]);
        if Result <> 0 then
          Break;
      end;
    end;
  end
  else
    if VarIsArray(V1) then
      Result := 1
    else
      if VarIsArray(V2) then
        Result := -1
      else
        Result := VarCompare(V1, V2);
end;

function VarCompare(const V1, V2: Variant): Integer;

  function CompareValues(const V1, V2: Variant): Integer;
  begin
    try
      if VarIsEmpty(V1) then
        if VarIsEmpty(V2) then
          Result := 0
        else
          Result := -1
      else
        if VarIsEmpty(V2) then
          Result := 1
        else
          if V1 = V2 then
            Result := 0
          else
            {$IFDEF DELPHI6}
            if VarIsNull(V1) then
              Result := -1
            else
              if VarIsNull(V2) then
                Result := 1
              else
            {$ENDIF}
                if V1 < V2 then
                  Result := -1
                else
                  Result := 1;
    except
      on EVariantError do
        Result := -1;
    end;
  end;

begin
{$IFDEF DELPHI6}
  {$IFNDEF DELPHI7}
  if (VarType(V1) = varString) and (VarType(V2) = varString) then
    Result := CompareStr(V1, V2)
  else
    if (VarType(V1) = varDate) and (VarType(V2) = varDate) then
      Result := CompareValues(Double(V1), Double(V2))
    else
  {$ENDIF}
{$ENDIF}
      if VarIsArray(V1) or VarIsArray(V2) then
        Result := VarArrayCompare(V1, V2)
      else
        Result := CompareValues(V1, V2);
end;

function VarEquals(const V1, V2: Variant): Boolean;
begin
  Result := VarCompare(V1, V2) = 0;
end;

function VarEqualsExact(const V1, V2: Variant): Boolean;
var
  AVarType1, AVarType2: Integer;
  AValue1, AValue2: Variant;
begin
  AVarType1 := VarType(V1);
  AVarType2 := VarType(V2);
  if (AVarType1 = varNull) or (AVarType2 = varNull) or
    ((AVarType1 <> varBoolean) and (AVarType2 <> varBoolean)) then
    Result := VarEquals(V1, V2)
  else
    try
      VarCast(AValue1, V1, varString);
      VarCast(AValue2, V2, varString);
      Result := AValue1 = AValue2;
    except
      on EVariantError do
        Result := False;
    end;
end;

function VarEqualsSoft(const V1, V2: Variant): Boolean;
begin
  Result := VarEquals(V1, V2) or (VarIsSoftNull(V1) and VarIsSoftNull(V2));
end;

function VarIndex(const AList: TVariantArray; const AValue: Variant): Integer;
begin
  for Result := 0 to Length(AList) - 1 do
    if VarEquals(AList[Result], AValue) then Exit;
  Result := -1;
end;

{$IFNDEF DELPHI6}
function FindVarData(const V: Variant): PVarData;
begin
  Result := @TVarData(V);
  while Result.VType = varByRef or varVariant do
    Result := PVarData(Result.VPointer);
end;
{$ENDIF}

function VarIsDate(const AValue: Variant): Boolean;

  function VarTypeIsDate(const AVarType: TVarType): Boolean;
  begin
    Result := (AVarType = varDate)
      {$IFNDEF NONDB}{$IFDEF DELPHI6} or (AVarType = VarSQLTimeStamp){$ENDIF}{$ENDIF};
  end;

begin
  Result := VarTypeIsDate(FindVarData(AValue)^.VType);
end;

function VarIsNumericEx(const AValue: Variant): Boolean;
begin
  Result := VarIsNumeric(AValue)
    {$IFNDEF NONDB}{$IFDEF DELPHI6} or
      (FindVarData(AValue)^.VType = VarFMTBcd)
    {$ENDIF}{$ENDIF};
end;

{$IFNDEF DELPHI6}

function VarIsType(const AValue: Variant; AVarType: TVarType): Boolean;
begin
  Result := FindVarData(AValue)^.VType = AVarType;
end;

function VarTypeIsOrdinal(const AVarType: TVarType): Boolean;
begin
  Result := AVarType in [varSmallInt, varInteger, varBoolean, varByte];
end;

function VarIsOrdinal(const AValue: Variant): Boolean;
begin
  Result := VarTypeIsOrdinal(FindVarData(AValue)^.VType);
end;

function VarTypeIsFloat(const AVarType: TVarType): Boolean;
begin
  Result := AVarType in [varSingle, varDouble, varCurrency];
end;

function VarIsFloat(const AValue: Variant): Boolean;
begin
  Result := VarTypeIsFloat(FindVarData(AValue)^.VType);
end;

function VarTypeIsNumeric(const AVarType: TVarType): Boolean;
begin
  Result := VarTypeIsOrdinal(AVarType) or VarTypeIsFloat(AVarType);
end;

function VarIsNumeric(const AValue: Variant): Boolean;
begin
  Result := VarTypeIsNumeric(FindVarData(AValue)^.VType);
end;

function VarTypeIsStr(const AVarType: TVarType): Boolean;
begin
  Result := (AVarType = varString) or (AVarType = varOleStr);
end;

function VarIsStr(const AValue: Variant): Boolean;
begin
  Result := VarTypeIsStr(FindVarData(AValue)^.VType);
end;

function VarSameValue(const V1, V2: Variant): Boolean;
var
  D1, D2: TVarData;
begin
  D1 := FindVarData(V1)^;
  D2 := FindVarData(V2)^;
  if D1.VType = varEmpty then
    Result := D2.VType = varEmpty
  else
    if D1.VType = varNull then