📄 varutils.pas
字号:
{ *********************************************************************** }
{ }
{ Delphi / Kylix Cross-Platform Runtime Library }
{ Variant Utilities Unit }
{ }
{ Copyright (c) 1995-2001 Borland Software Corporation }
{ }
{ *********************************************************************** }
unit VarUtils;
{$BOOLEVAL OFF}
interface
uses
SysUtils, Types, SysConst;
const
{$IFDEF MSWINDOWS}
GenericVarUtils = False;
{$ELSE}
GenericVarUtils = True;
{$ENDIF}
GenericVariants = GenericVarUtils;
GenericOperations = GenericVariants;
GenericSafeArrays = GenericVarUtils;
{$IFDEF MSWINDOWS}
// if we running in windows this should never be true
GenericSafeArrayUsesLibC = FALSE;
{$ELSE}
GenericSafeArrayUsesLibC = GenericSafeArrays;
{$ENDIF}
// These entry point(s) are used by Variants.pas. The generic versions
// of these routines (which are enabled if this unit is compiled under
// an operating system other than Windows) are as similar as possible to
// their Windows counter parts. Please note that there are differences
// but they have been kept to a minimum.
// error handling routines
function VarExceptionToResult(const E: Exception): HRESULT;
// variant management routines
procedure VariantInit(var V: TVarData); stdcall;
function VariantClear(var V: TVarData): HRESULT; stdcall;
function VariantCopy(var Dest: TVarData;
const Source: TVarData): HRESULT; stdcall;
function VariantCopyInd(var Dest: TVarData;
const Source: TVarData): HRESULT; stdcall;
function VariantChangeType(var Dest: TVarData; const Source: TVarData;
wFlags: Word; VarType: Word): HRESULT; stdcall;
// the following routines are late bound due to the fact they might not be implemented everywhere
var
// variant coercion routine
VariantChangeTypeEx: function(var Dest: TVarData; const Source: TVarData;
LCID: Integer; wFlags: Word; VarType: Word): HRESULT; stdcall;
// variant unioperation routines
VarNeg: function(const Source: TVarData; var Dest: TVarData): HRESULT; stdcall;
VarNot: function(const Source: TVarData; var Dest: TVarData): HRESULT; stdcall;
// variant bioperation routines
VarAdd: function(const Left, Right: TVarData; var AResult: TVarData): HRESULT; stdcall;
VarSub: function(const Left, Right: TVarData; var AResult: TVarData): HRESULT; stdcall;
VarMul: function(const Left, Right: TVarData; var AResult: TVarData): HRESULT; stdcall;
VarDiv: function(const Left, Right: TVarData; var AResult: TVarData): HRESULT; stdcall;
VarIDiv: function(const Left, Right: TVarData; var AResult: TVarData): HRESULT; stdcall;
VarMod: function(const Left, Right: TVarData; var AResult: TVarData): HRESULT; stdcall;
VarAnd: function(const Left, Right: TVarData; var AResult: TVarData): HRESULT; stdcall;
VarOr: function(const Left, Right: TVarData; var AResult: TVarData): HRESULT; stdcall;
VarXor: function(const Left, Right: TVarData; var AResult: TVarData): HRESULT; stdcall;
// variant compare routine
VarCmp: function(const Left, Right: TVarData; LCID: Integer; Flags: LongWord): HRESULT; stdcall;
// string conversion routines
VarI4FromStr: function(const strIn: WideString; LCID: Integer; dwFlags: Longint;
out lOut: Longint): HRESULT; stdcall;
VarR4FromStr: function(const strIn: WideString; LCID: Integer; dwFlags: Longint;
out fltOut: Single): HRESULT; stdcall;
VarR8FromStr: function(const strIn: WideString; LCID: Integer; dwFlags: Longint;
out dblOut: Double): HRESULT; stdcall;
VarDateFromStr: function(const strIn: WideString; LCID: DWORD; dwFlags: Longint;
out dateOut: TDateTime): HRESULT; stdcall;
VarCyFromStr: function(const strIn: WideString; LCID: DWORD; dwFlags: Longint;
out cyOut: Currency): HRESULT; stdcall;
VarBoolFromStr: function(const strIn: WideString; LCID: Integer; dwFlags: Longint;
out boolOut: WordBool): HRESULT; stdcall;
VarBstrFromCy: function(cyIn: Currency; LCID: Integer; dwFlags: Longint;
out bstrOut: WideString): HRESULT; stdcall;
VarBstrFromDate: function(dateIn: TDateTime; LCID: Integer; dwFlags: Longint;
out bstrOut: WideString): HRESULT; stdcall;
VarBstrFromBool: function(boolIn: WordBool; LCID: Integer; dwFlags: Longint;
out bstrOut: WideString): HRESULT; stdcall;
// safe array routines
function SafeArrayCreate(VarType, DimCount: Integer;
const Bounds: TVarArrayBoundArray): PVarArray; stdcall;
function SafeArrayAllocDescriptor(DimCount: Integer;
out VarArray: PVarArray): HRESULT; stdcall;
function SafeArrayAllocData(VarArray: PVarArray): HRESULT; stdcall;
function SafeArrayDestroy(VarArray: PVarArray): HRESULT; stdcall;
function SafeArrayDestroyDescriptor(VarArray: PVarArray): HRESULT; stdcall;
function SafeArrayDestroyData(VarArray: PVarArray): HRESULT; stdcall;
function SafeArrayRedim(VarArray: PVarArray; const NewBound: TVarArrayBound): HRESULT; stdcall;
function SafeArrayCopy(SourceArray: PVarArray; out TargetArray: PVarArray): HRESULT; stdcall;
function SafeArrayCopyData(SourceArray, TargetArray: PVarArray): HRESULT; stdcall;
function SafeArrayGetLBound(VarArray: PVarArray; Dim: Integer;
out LBound: Integer): HRESULT; stdcall;
function SafeArrayGetUBound(VarArray: PVarArray; Dim: Integer;
out UBound: Integer): HRESULT; stdcall;
function SafeArrayGetDim(VarArray: PVarArray): Integer; stdcall;
function SafeArrayAccessData(VarArray: PVarArray;
out Data: Pointer): HRESULT; stdcall;
function SafeArrayUnaccessData(VarArray: PVarArray): HRESULT; stdcall;
function SafeArrayLock(VarArray: PVarArray): HRESULT; stdcall;
function SafeArrayUnlock(VarArray: PVarArray): HRESULT; stdcall;
function SafeArrayGetElement(VarArray: PVarArray; Indices: PVarArrayCoorArray;
Data: Pointer): HRESULT; stdcall;
function SafeArrayPutElement(VarArray: PVarArray; Indices: PVarArrayCoorArray;
const Data: Pointer): HRESULT; stdcall;
function SafeArrayPtrOfIndex(VarArray: PVarArray; Indices: PVarArrayCoorArray;
var Address: Pointer): HRESULT; stdcall;
function SafeArrayGetElemSize(VarArray: PVarArray): LongWord; stdcall;
procedure SafeArrayCheck(AResult: HRESULT);
procedure SafeArrayError(AResult: HRESULT);
type
ESafeArrayError = class(Exception)
private
FErrorCode: HRESULT;
public
constructor CreateHResult(AResult: HRESULT; const AMessage: string = '');
property ErrorCode: HRESULT read FErrorCode write FErrorCode;
end;
ESafeArrayCreateError = class(ESafeArrayError);
ESafeArrayBoundsError = class(ESafeArrayError);
ESafeArrayLockedError = class(ESafeArrayError);
// These equate to Window's constants but are renamed to less OS dependent
const
VAR_OK = HRESULT($00000000); // = Windows.S_OK
VAR_PARAMNOTFOUND = HRESULT($80020004); // = Windows.DISP_E_PARAMNOTFOUND
VAR_TYPEMISMATCH = HRESULT($80020005); // = Windows.DISP_E_TYPEMISMATCH
VAR_BADVARTYPE = HRESULT($80020008); // = Windows.DISP_E_BADVARTYPE
VAR_EXCEPTION = HRESULT($80020009); // = Windows.DISP_E_EXCEPTION
VAR_OVERFLOW = HRESULT($8002000A); // = Windows.DISP_E_OVERFLOW
VAR_BADINDEX = HRESULT($8002000B); // = Windows.DISP_E_BADINDEX
VAR_ARRAYISLOCKED = HRESULT($8002000D); // = Windows.DISP_E_ARRAYISLOCKED
VAR_NOTIMPL = HRESULT($80004001); // = Windows.E_NOTIMPL
VAR_OUTOFMEMORY = HRESULT($8007000E); // = Windows.E_OUTOFMEMORY
VAR_INVALIDARG = HRESULT($80070057); // = Windows.E_INVALIDARG
VAR_UNEXPECTED = HRESULT($8000FFFF); // = Windows.E_UNEXPECTED
ARR_NONE = $0000; { no flags set }
ARR_FIXEDSIZE = $0010; { ActiveX.FADF_FIXEDSIZE, array may not be resized or reallocated }
ARR_OLESTR = $0100; { ActiveX.FADF_BSTR, an array of BSTRs }
ARR_UNKNOWN = $0200; { ActiveX.FADF_UNKNOWN, an array of IUnknown }
ARR_DISPATCH = $0400; { ActiveX.FADF_DISPATCH, an array of IDispatch }
ARR_VARIANT = $0800; { ActiveX.FADF_VARIANT, an array of VARIANTs }
VAR_CMP_LT = 0; { These are returned by VarCmp }
VAR_CMP_EQ = 1;
VAR_CMP_GT = 2;
VAR_CMP_NULL = 3;
VAR_LOCALE_USER_DEFAULT = $400; // = Windows.LOCALE_USER_DEFAULT
type
TVarTypeToElementInfo = record
ValidBase: Boolean;
ValidElement: Boolean;
Size: Integer;
Flags: Word;
end;
const
CMinArrayVarType = varEmpty;
CMaxArrayVarType = $0015; // varWord64 if that actually existed
CVarTypeToElementInfo: array [CMinArrayVarType..CMaxArrayVarType] of TVarTypeToElementInfo = (
{ * = unsupported as of VCLv6 }
{ varEmpty/vt_empty $00 }
(ValidBase: False; ValidElement: True; Size: 0; Flags: ARR_NONE),
{ varNull/vt_null $01 }
(ValidBase: False; ValidElement: True; Size: 0; Flags: ARR_NONE),
{ varSmallint/vt_i2 $02 }
(ValidBase: True; ValidElement: True; Size: 2; Flags: ARR_NONE),
{ varInteger/vt_i4 $03 }
(ValidBase: True; ValidElement: True; Size: 4; Flags: ARR_NONE),
{ varSingle/vt_r4 $04 }
(ValidBase: True; ValidElement: True; Size: 4; Flags: ARR_NONE),
{ varDouble/vt_r8 $05 }
(ValidBase: True; ValidElement: True; Size: 8; Flags: ARR_NONE),
{ varCurrency/vt_cy $06 }
(ValidBase: True; ValidElement: True; Size: 8; Flags: ARR_NONE),
{ varDate/vt_date $07 }
(ValidBase: True; ValidElement: True; Size: 8; Flags: ARR_NONE),
{ varOleStr/vt_bstr $08 }
(ValidBase: True; ValidElement: True; Size: 4; Flags: ARR_OLESTR),
{ varDispatch/vt_dispatch $09 }
(ValidBase: True; ValidElement: True; Size: 4; Flags: ARR_DISPATCH),
{ varError/vt_error $0A }
(ValidBase: True; ValidElement: True; Size: 4; Flags: ARR_NONE),
{ varBoolean/vt_bool $0B }
(ValidBase: True; ValidElement: True; Size: 2; Flags: ARR_NONE),
{ varVariant/vt_variant $0C }
(ValidBase: True; ValidElement: True; Size: 16; Flags: ARR_VARIANT),
{ varUnknown/vt_unknown $0D }
(ValidBase: True; ValidElement: True; Size: 4; Flags: ARR_UNKNOWN),
{*varDecimal/vt_decimal $0E }
(ValidBase: False; ValidElement: False; Size: 14; Flags: ARR_NONE),
{*unused/undefined $0F }
(ValidBase: False; ValidElement: False; Size: 0; Flags: ARR_NONE),
{ varShortInt/vt_i1 $10 }
(ValidBase: True; ValidElement: True; Size: 1; Flags: ARR_NONE),
{ varByte/vt_ui1 $11 }
(ValidBase: True; ValidElement: True; Size: 1; Flags: ARR_NONE),
{ varWord/vt_ui2 $12 }
(ValidBase: True; ValidElement: True; Size: 2; Flags: ARR_NONE),
{ varSmallWord/vt_ui4 $13 }
(ValidBase: True; ValidElement: True; Size: 4; Flags: ARR_NONE),
{ varInt64/vt_i8 $14 }
(ValidBase: False; ValidElement: True; Size: 8; Flags: ARR_NONE),
{*varWord64/vt_ui8 $15 }
(ValidBase: False; ValidElement: False; Size: 8; Flags: ARR_NONE));
implementation
// This defined is used to insure that rangechecking is handled correctly
{$IFOPT R-}
{$DEFINE RANGECHECKINGOFF}
{$ENDIF}
{$IFDEF MSWINDOWS}
uses Windows;
{$ELSE}
{$IF GenericSafeArrayUsesLibC}
uses Libc;
{$IFEND}
{$ENDIF}
{$IFDEF MSWINDOWS}
const
oleaut = 'oleaut32.dll';
{$ENDIF}
// has the jump table been initialized yet
var
VariantInited: Boolean = False;
{******************************************************************************}
{ Common Variant Functions }
{******************************************************************************}
function VarExceptionToResult(const E: Exception): HRESULT;
begin
// string to int conversion error
// string to float conversion error
// string to currency conversion error
// string to datetime conversion error
// float to currency conversion error
// float to datetime conversion error
if E is EConvertError then
Result := VAR_TYPEMISMATCH
// float range error
else if E is SysUtils.EOverflow then // Symbol collision with LibC
Result := VAR_OVERFLOW
else if E is EUnderflow then
Result := VAR_OVERFLOW
// int range error
else if E is ERangeError then
Result := VAR_OVERFLOW
// rounding overflow, possible during string conversion
else if E is EIntOverflow then
Result := VAR_OVERFLOW
// something really really bad happened
else if E is EOutOfMemory then
Result := VAR_OUTOFMEMORY
// unknown type of exception
else
Result := VAR_INVALIDARG;
end;
{******************************************************************************}
{ Variant Functions }
{******************************************************************************}
{$IF not GenericVariants}
procedure VariantInit; external oleaut name 'VariantInit';
function VariantClear; external oleaut name 'VariantClear';
function VariantCopy; external oleaut name 'VariantCopy';
function VariantCopyInd; external oleaut name 'VariantCopyInd';
function VariantChangeType; external oleaut name 'VariantChangeType';
{$ELSE}
procedure VariantInit(var V: TVarData);
begin
V.VType := varEmpty;
FillChar(V.VBytes, SizeOf(V.VBytes), 0);
end;
function VariantClear(var V: TVarData): HRESULT;
begin
Result := VAR_OK;
// var is an array
if (V.VType and varArray) <> 0 then
Result := SafeArrayDestroy(V.VArray)
else
begin
// var is not byref
if (V.VType and varByRef) = 0 then
case V.VType of
varEmpty, varNull, varSmallint, varInteger, varSingle, varDouble,
varCurrency, varDate, varError, varBoolean, varShortInt, varByte,
varWord, varLongWord:;
// the fill char later on will take care of these
varOleStr:
WideString(Pointer(V.VOleStr)) := '';
varDispatch:
IUnknown(V.VDispatch) := nil;
//varVariant:
// taken care of by the above ByRef code but we should error if not
varUnknown:
IUnknown(V.VUnknown) := nil;
else
Result := VAR_BADVARTYPE;
end;
end;
// all is swell so lets slick it
if Result = VAR_OK then
VariantInit(V);
end;
function VariantCopy(var Dest: TVarData; const Source: TVarData): HRESULT;
begin
// Dest is pointing to the source, nothing need be done
if @Source = @Dest then
Result := VAR_OK
else
begin
// wipe out the destination
Result := VariantClear(Dest);
if Result = VAR_OK then
begin
// var is an array!
if (Source.VType and varArray) <> 0 then
Result := SafeArrayCopy(Source.VArray, Dest.VArray)
else
begin
if (Source.VType and varByRef) <> 0 then // var is byref
Dest.VPointer := Source.VPointer
else
case (Source.VType and varTypeMask) of // strip off modifier flags
varEmpty, varNull:;
// nothing do!
varSmallint, varInteger, varSingle, varDouble, varCurrency, varDate,
varError, varBoolean, varShortInt, varByte, varWord, varLongWord:
Move(Source.VBytes, Dest.VBytes, SizeOf(Dest.VBytes));
varOleStr:
WideString(Pointer(Dest.VOleStr)) := Copy(Source.VOleStr, 1, MaxInt);
varDispatch:
IUnknown(Dest.VDispatch) := IUnknown(Source.VDispatch);
//varVariant:
// taken care of by the above ByRef code but we should error if not
varUnknown:
IUnknown(Dest.VUnknown) := IUnknown(Source.VUnknown);
else
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -