varutils.pas

这是不可多得的源代码

              Dest.VInteger := StrToInt(WideString(LSource.VOleStr));
            varSingle:
              Dest.VSingle := StrToFloat(WideString(LSource.VOleStr));
            varDouble:
              Dest.VDouble := StrToFloat(WideString(LSource.VOleStr));
            varCurrency:
              Dest.VCurrency := StrToCurr(WideString(LSource.VOleStr));
            varDate:
              Dest.VDate := StrToDateTime(WideString(LSource.VOleStr));
            varOleStr:
              WideString(Pointer(Dest.VOleStr)) := Copy(LSource.VOleStr, 1, MaxInt);
            varBoolean:
              Dest.VBoolean := StrToBool(WideString(LSource.VOleStr));
            varShortInt:
              Dest.VShortInt := StrToInt(WideString(LSource.VOleStr));
            varByte:
              Dest.VByte := StrToInt(WideString(LSource.VOleStr));
            varWord:
              Dest.VWord := StrToInt(WideString(LSource.VOleStr));
            varLongWord:
              Dest.VLongWord := StrToInt64(WideString(LSource.VOleStr));
          else
            Result := VAR_TYPEMISMATCH;
          end;
        varDispatch:
          Result := VAR_TYPEMISMATCH;
        varError:
          Result := VAR_TYPEMISMATCH;
        varBoolean:
          case VarType of
            varEmpty, varNull:;
            varSmallInt:
              Dest.VSmallInt := SmallInt(LSource.VBoolean);
            varInteger:
              Dest.VInteger := Integer(LSource.VBoolean);
            varSingle:
              Dest.VSingle := Integer(LSource.VBoolean);
            varDouble:
              Dest.VDouble := Integer(LSource.VBoolean);
            varCurrency:
              Dest.VCurrency := Integer(LSource.VBoolean);
            varDate:
              Dest.VDate := Integer(LSource.VBoolean);
            varOleStr:
              WideString(Pointer(Dest.VOleStr)) := BoolToStr(LSource.VBoolean);
            varBoolean:
              Dest.VBoolean := LSource.VBoolean;
            varShortInt:
              Dest.VShortInt := ShortInt(LSource.VBoolean);
            varByte:
              Dest.VByte := Byte(LSource.VBoolean);
            varWord:
              Dest.VWord := Word(LSource.VBoolean);
            varLongWord:
              Dest.VLongWord := LongWord(LSource.VBoolean);
          else
            Result := VAR_TYPEMISMATCH;
          end;
        varVariant:
          case VarType of
            varEmpty, varNull:;
            varSmallInt:
              Dest.VSmallInt := PVariant(LSource.VPointer)^;
            varInteger:
              Dest.VInteger := PVariant(LSource.VPointer)^;
            varSingle:
              Dest.VSingle := PVariant(LSource.VPointer)^;
            varDouble:
              Dest.VDouble := PVariant(LSource.VPointer)^;
            varCurrency:
              Dest.VCurrency := PVariant(LSource.VPointer)^;
            varDate:
              Dest.VDate := PVariant(LSource.VPointer)^;
            varOleStr:
              WideString(Pointer(Dest.VOleStr)) := PVariant(LSource.VPointer)^;
            varBoolean:
              Dest.VBoolean := PVariant(LSource.VPointer)^;
            varShortInt:
              Dest.VShortInt := PVariant(LSource.VPointer)^;
            varByte:
              Dest.VByte := PVariant(LSource.VPointer)^;
            varWord:
              Dest.VWord := PVariant(LSource.VPointer)^;
            varLongWord:
              Dest.VLongWord := PVariant(LSource.VPointer)^;
          else
            Result := VAR_TYPEMISMATCH;
          end;
        varUnknown:
          case VarType of
            varEmpty, varNull:;
          else
            Result := VAR_TYPEMISMATCH;
          end;
        varShortInt:
          case VarType of
            varEmpty, varNull:;
            varSmallInt:
              Dest.VSmallInt := LSource.VSmallInt;
            varInteger:
              Dest.VInteger := LSource.VSmallInt;
            varSingle:
              Dest.VSingle := LSource.VSmallInt;
            varDouble:
              Dest.VDouble := LSource.VSmallInt;
            varCurrency:
              Dest.VCurrency := LSource.VSmallInt;
            varDate:
              Dest.VDate := LSource.VSmallInt;
            varOleStr:
              WideString(Pointer(Dest.VOleStr)) := IntToStr(LSource.VSmallInt);
            varBoolean:
              Dest.VBoolean := LSource.VSmallInt <> 0;
            varShortInt:
              Dest.VShortInt := LSource.VSmallInt;
            varByte:
              Dest.VByte := LSource.VSmallInt;
            varWord:
              Dest.VWord := LSource.VSmallInt;
            varLongWord:
              Dest.VLongWord := LSource.VSmallInt;
          else
            Result := VAR_TYPEMISMATCH;
          end;
        varByte:
          case VarType of
            varEmpty, varNull:;
            varSmallInt:
              Dest.VSmallInt := LSource.VByte;
            varInteger:
              Dest.VInteger := LSource.VByte;
            varSingle:
              Dest.VSingle := LSource.VByte;
            varDouble:
              Dest.VDouble := LSource.VByte;
            varCurrency:
              Dest.VCurrency := LSource.VByte;
            varDate:
              Dest.VDate := LSource.VByte;
            varOleStr:
              WideString(Pointer(Dest.VOleStr)) := IntToStr(LSource.VByte);
            varBoolean:
              Dest.VBoolean := LSource.VByte <> 0;
            varShortInt:
              Dest.VShortInt := LSource.VByte;
            varByte:
              Dest.VByte := LSource.VByte;
            varWord:
              Dest.VWord := LSource.VByte;
            varLongWord:
              Dest.VLongWord := LSource.VByte;
          else
            Result := VAR_TYPEMISMATCH;
          end;
        varWord:
          case VarType of
            varEmpty, varNull:;
            varSmallInt:
              Dest.VSmallInt := LSource.VWord;
            varInteger:
              Dest.VInteger := LSource.VWord;
            varSingle:
              Dest.VSingle := LSource.VWord;
            varDouble:
              Dest.VDouble := LSource.VWord;
            varCurrency:
              Dest.VCurrency := LSource.VWord;
            varDate:
              Dest.VDate := LSource.VWord;
            varOleStr:
              WideString(Pointer(Dest.VOleStr)) := IntToStr(LSource.VWord);
            varBoolean:
              Dest.VBoolean := LSource.VWord <> 0;
            varShortInt:
              Dest.VShortInt := LSource.VWord;
            varByte:
              Dest.VByte := LSource.VWord;
            varWord:
              Dest.VWord := LSource.VWord;
            varLongWord:
              Dest.VLongWord := LSource.VWord;
          else
            Result := VAR_TYPEMISMATCH;
          end;
        varLongWord:
          case VarType of
            varEmpty, varNull:;
            varSmallInt:
              Dest.VSmallInt := LSource.VLongWord;
            varInteger:
              Dest.VInteger := LSource.VLongWord;
            varSingle:
              Dest.VSingle := LSource.VLongWord;
            varDouble:
              Dest.VDouble := LSource.VLongWord;
            varCurrency:
              Dest.VCurrency := LSource.VLongWord;
            varDate:
              Dest.VDate := LSource.VLongWord;
            varOleStr:
              WideString(Pointer(Dest.VOleStr)) := IntToStr(LSource.VLongWord);
            varBoolean:
              Dest.VBoolean := LSource.VLongWord <> 0;
            varShortInt:
              Dest.VShortInt := LSource.VLongWord;
            varByte:
              Dest.VByte := LSource.VLongWord;
            varWord:
              Dest.VWord := LSource.VLongWord;
            varLongWord:
              Dest.VLongWord := LSource.VLongWord;
          else
            Result := VAR_TYPEMISMATCH;
          end;
      else
        Result := VAR_BADVARTYPE;
      end;

      if Result = VAR_OK then
        Dest.VType := VarType;
    except
      on E: Exception do
        Result := VarExceptionToResult(E);
    end;
    
    // Only turn range checking off if it was off to begin with
    {$IFDEF RANGECHECKINGOFF}
      {$RANGECHECKS OFF}
    {$ENDIF}
  finally
    VariantClear(LSource);
  end;
end;

{ Known limitations in VariantChangeType
    Cannot convert from or to anything that is ByRef except for exact
      identity copies
    Cannot convert from or to arrays except for exact identity copies
      and the rather strange, and undocumented, Array of Byte <--> OleStr
    Can convert from a variant containing a reference to a variant but not back }
function VariantChangeType(var Dest: TVarData; const Source: TVarData;
  wFlags: Word; VarType: Word): HRESULT;
begin
  // source is an olestr and dest is..
  if Source.VType = varOleStr then

    // ..array of bytes, that is easy too
    if VarType = varArray + varByte then
      Result := VariantChangeOleStrIntoByteArray(Dest, Source)

    // ..anything else let simple try to handle it
    else
      Result := VariantChangeSimpleIntoSimple(Dest, Source, wFlags, VarType)

  // source is an array of bytes and dest is..
  else if Source.VType = varArray + varByte then

    // ..olestr, easy
    if VarType = varOleStr then
      Result := VariantChangeByteArrayIntoOleStr(Dest, Source)

    // ..anything else, fail
    else
      Result := VAR_INVALIDARG

  // anything into itself
  else if Source.VType = VarType then
    Result := VariantCopy(Dest, Source)

  // simple to anything else, let the simple case try to handle it
  else
    Result := VariantChangeSimpleIntoSimple(Dest, Source, wFlags, VarType);
end;
{$IFEND}

{******************************************************************************}
{ Backup Variant Functions/Operations                                          }
{******************************************************************************}
// Known limitations in the following functions
//   LCID is currently ignored but for future compatiblity you should always
//   pass VAR_LOCALE_USER_DEFAULT (which equals $400);

function BackupVariantChangeTypeEx(var Dest: TVarData; const Source: TVarData;
  LCID: Integer; wFlags: Word; VarType: Word): HRESULT; stdcall;
begin
  if LCID <> VAR_LOCALE_USER_DEFAULT then
    Result := VAR_NOTIMPL
  else
    Result := VariantChangeType(Dest, Source, wFlags, VarType);
end;

{ we don't attempt to implement any of the uni/bi/cmp operators}
function UniUnimplemented(const Source: TVarData; var Dest: TVarData): HRESULT; stdcall;
begin
  Result := VAR_NOTIMPL;
end;

function BiUnimplemented(const Left, Right: TVarData; var AResult: TVarData): HRESULT; stdcall;
begin
  Result := VAR_NOTIMPL;
end;

function CmpUnimplemented(const Left, Right: TVarData; LCID: Integer; Flags: LongWord): HRESULT; stdcall;
begin
  Result := VAR_NOTIMPL;
end;

// Known limitations in these conversion functions
//   Windows is much more tolerant of extra characters when converting
//   ints, floats, dates, currs and bools into strings.
const
  CResult: array [False..True] of HRESULT = (VAR_INVALIDARG, VAR_OK);

function BackupVarI4FromStr(const strIn: WideString; LCID: Integer; dwFlags: Longint;
  out lOut: Longint): HRESULT; stdcall;
begin
  if LCID <> VAR_LOCALE_USER_DEFAULT then
    Result := VAR_NOTIMPL
  else
    Result := CResult[TryStrToInt(strIn, lOut)];
end;

function BackupVarR4FromStr(const strIn: WideString; LCID: Integer; dwFlags: Longint;
  out fltOut: Single): HRESULT; stdcall;
begin
  if LCID <> VAR_LOCALE_USER_DEFAULT then
    Result := VAR_NOTIMPL
  else
    Result := CResult[TryStrToFloat(strIn, fltOut)];
end;

function BackupVarR8FromStr(const strIn: WideString; LCID: Integer; dwFlags: Longint;
  out dblOut: Double): HRESULT; stdcall;
begin
  if LCID <> VAR_LOCALE_USER_DEFAULT then
    Result := VAR_NOTIMPL
  else
    Result := CResult[TryStrToFloat(strIn, dblOut)];
end;

function BackupVarDateFromStr(const strIn: WideString; LCID: DWORD; dwFlags: Longint;
  out dateOut: TDateTime): HRESULT; stdcall;
begin
  if LCID <> VAR_LOCALE_USER_DEFAULT then
    Result := VAR_NOTIMPL
  else
    Result := CResult[TryStrToDateTime(strIn, dateOut)];
end;

function BackupVarCyFromStr(const strIn: WideString; LCID: DWORD; dwFlags: Longint;
  out cyOut: Currency): HRESULT; stdcall;
begin
  if LCID <> VAR_LOCALE_USER_DEFAULT then
    Result := VAR_NOTIMPL
  else
    Result := CResult[TryStrToCurr(strIn, cyOut)];
end;

function BackupVarBoolFromStr(const strIn: WideString; LCID: Integer; dwFlags: Longint;
  out boolOut: WordBool): HRESULT; stdcall;
var
  LBoolean: Boolean;
begin
  if LCID <> VAR_LOCALE_USER_DEFAULT then
    Result := VAR_NOTIMPL
  else
  begin
    Result := CResult[TryStrToBool(strIn, LBoolean)];
    boolOut := LBoolean;
  end;
end;


function BackupVarBStrFromCy(cyIn: Currency; LCID: Integer; dwFlags: Longint;
  out bstrOut: WideString): HRESULT; stdcall;
begin
  if LCID <> VAR_LOCALE_USER_DEFAULT then
    Result := VAR_NOTIMPL
  else
  begin
    bstrOut := CurrToStr(cyIn);
    Result := VAR_OK;
  end;
end;

function BackupVarBStrFromDate(dateIn: TDateTime; LCID: Integer; dwFlags: Longint;
  out bstrOut: WideString): HRESULT; stdcall;
begin
  if LCID <> VAR_LOCALE_USER_DEFAULT then
    Result := VAR_NOTIMPL
  else
  begin
    bstrOut := DateTimeToStr(dateIn);