pbvariantutils.pas

Delphi snippet to convert variants values to xml

{== PBVariantUtils ====================================================}
{: This unit provides a number of helper routines to analyze variants.
@author Dr. Peter Below
@desc   Version 1.0 created 2003-06-07<BR>
        Last modified       2003-06-09<P>
The unit uses Berend de Boers xml_generator unit to generate XML, you
can download this unit from http://www.thedelphimagazine.com/disks.php
(code for issue 77 (2002) or contact the author via his web site at
http://www.pobox.com/~berend/delphi .   }
{======================================================================}
{$BOOLEVAL OFF}{Unit depends on shortcut boolean evaluation}
Unit PBVariantUtils;
{$I JEDI.INC} {version symbols from Jedi code library jcl.sourceforge.net }
Interface

Uses Windows, activex,
     {$IFDEF DELPHI6_UP} variants, {$ENDIF}
     sysutils, xml_generator;

{-- VariantToXML ------------------------------------------------------}
{: Convert a variant to an XML representation
@Param V is the variant to convert
@Returns a String containing a complete XML file, ISO 8859.1-encoded
@Desc The XML representation uses four level of tags: "variant",
  "array", "element", and "binary". The root is a "variant" node. The
  "variant" node has an attribute "type", which identifies the variants
  data type. The "array" node has an attribute "bounds", which gives the
  arrays low and high bounds for each dimension, using Delphi syntax.
  "element" has an attribute "type", which has the same meaning as for
  the "variant" node type, and an element "indices", which contains the
  array index for the element. "binary" has an attribute "size", holding
  the number of bytes, and an attribute "encoding", which can be either
  "hex" or "base64" to describe the way the binary data in the node is
  represented as text. We only use hex encoding here, however. <br/>
  A "variant" can contain literal values or an "array" or "binary" child
  node, or can be empty (in case of null and unassigned nodes, for
  instance). "array" contains "element" child nodes, "element" can
  contain literal data, "binary" or "variant" nodes, which makes the
  whole structure recursive.
}{ Created 2003-06-07 by P. Below
-----------------------------------------------------------------------}
Function VariantToXML( const V: Variant ): String;

{: Convert a variant type to a string representation }
Function VarTypeToString( vt: TVarType ): String;

{: Debug helper, will convert the passed variant to XML, save it to
 a file in the temp folder, then display that via ShellExecute. It
 will usually be shown in Internet Explorer if no other program is
 registered as server for XML.
 @returns "OK" in case of succes and an exception message in case of
   failure. }
Function DebugDisplayVariant( const V: Variant ): String;

Type
  IVariantToXML = Interface
  ['{98B9AA6C-AD47-4371-99B3-91F49EAF4554}']
    Procedure Convert( const V: Variant );
    Function AsAnsiString: String;
    Function AsUTF8: String;
    Function AsUTF16: WideString;
  End;

  TPBVariantToXMLConverter = class( TInterfacedObject, IVariantToXML )
  private
    FGenerator: TXMLGenerator;
    FOwnsGenerator: Boolean;
    {$IFDEF DELPHI7_UP}
    FFmt: TFormatSettings;
    {$ENDIF}

  protected
    Procedure ConvertArrayVariantData(const V: Variant; vt: TVarType);
    Procedure ConvertByRefVariantData(const V: Variant; vt: TVarType);
    Procedure ConvertSimpleVariantData(const V: Variant);
    Procedure ConvertVariantData(const V: Variant);
    Procedure ConvertVectorVariantData(const V: Variant; vt: TVarType);

    Function  GetBoundsString( value: PVarArray ): String;
    Function  GetElementSize( vt: TVarType ): Integer;
    Function  GetSafearrayDataPointer( value: PVarArray; const indices: Array of integer ): Pointer;
    Function  GetSafeArrayLBound( value: PVarArray; dim: Integer ): Integer;
    Function  GetSafeArrayUBound( value: PVarArray; dim: Integer ): Integer;
    Procedure GetSafearrayVType( value: PVarArray; Var vt: TVarType );
    Function  IsSupportedElementType( vt: TVarType ): Boolean;

    Procedure WriteAddress( value: Pointer );
    procedure WriteBinary(size: Cardinal; pvalue: Pointer);
    Procedure WriteBoolean(value: Boolean);
    Procedure WriteBStr( value: PWidechar );
    Procedure WriteCurrency(const value: Currency);
    Procedure WriteDate(const value: TDatetime);
    Procedure WriteDecimal(const value: TDecimal);
    Procedure WriteElementData( pData: Pointer; vt: TVarType );
    procedure WriteFiletime(const value: int64);
    Procedure WriteFloat(const value: Double);
    Procedure WriteHex( value: Cardinal; width: integer );
    Procedure WriteHex64( value: int64 );
    Procedure WriteHexData(size: Cardinal; pData: PByte);
    Procedure WriteInteger( value: Integer );
    Procedure WriteInt64( value: int64 );
    Procedure WriteSafeArray(value: PVarArray; vt: TVarType);
    Procedure WriteString( value: String );
    Procedure WriteVariant(const value: Variant);
    procedure WriteVectorData(numElements: Cardinal; pData: Pointer;
      vt: TVarType);

    { Methods of the IVariantToXML interface }
    Function AsAnsiString: String;
    Function AsUTF16: WideString;
    Function AsUTF8: String;
    Procedure Convert(const V: Variant);

  public
    Constructor Create( generator: TXMLGenerator );
    Destructor Destroy; override;
  End;

Implementation

Uses classes,
     {$IFDEF DELPHI6_UP}
     VarUtils,
     {$ENDIF}
     ComObj, ShellAPI;

Const
  cVariant = 'variant';
  cArray   = 'array';
  cElement = 'element';
  cType    = 'type';
  cBounds  = 'bounds';
  cIndices = 'indices';
  cBinary  = 'binary';
  cSize    = 'size';
  cEncoding= 'encoding';
  cEncodingHex = 'hex';
  cEncodingBase64 = 'base64';

  // some new VT types not declared in D7 ActiveX unit
  VT_RECORD   = 36;
  VT_INT_PTR  = 37;
  VT_UINT_PTR = 38;
  VT_VERSIONED_STREAM = 73;
  VT_BSTR_BLOB = $fff;
  VT_VECTOR    = $1000;

  // Other things not declared in D7s units
  FADF_HAVEVARTYPE = $80;

  {$IFNDEF DELPHI6_UP}
  varShortInt = $0010; { vt_i1          16 }
  varWord     = $0012; { vt_ui2         18 }
  varLongWord = $0013; { vt_ui4         19 }
  varInt64    = $0014; { vt_i8          20 }
  {$ENDIF}

Type
  TVector = packed record
    numElements: Cardinal;
    pData: Pointer;
  end;
  PVector = ^TVector;
  {$IFNDEF DELPHI6_UP}
  PPointer = ^Pointer;
  PCardinal= ^Cardinal;
  PVarData = ^TVarData;
  PWordBool= ^WordBool;
  TVarData = packed record  // this is the D7 declaration
    case Integer of
      0: (VType: TVarType;
          case Integer of
            0: (Reserved1: Word;
                case Integer of
                  0: (Reserved2, Reserved3: Word;
                      case Integer of
                        varSmallInt: (VSmallInt: SmallInt);
                        varInteger:  (VInteger: Integer);
                        varSingle:   (VSingle: Single);
                        varDouble:   (VDouble: Double);
                        varCurrency: (VCurrency: Currency);
                        varDate:     (VDate: TDateTime);
                        varOleStr:   (VOleStr: PWideChar);
                        varDispatch: (VDispatch: Pointer);
                        varError:    (VError: HRESULT);
                        varBoolean:  (VBoolean: WordBool);
                        varUnknown:  (VUnknown: Pointer);
                        varShortInt: (VShortInt: ShortInt);
                        varByte:     (VByte: Byte);
                        varWord:     (VWord: Word);
                        varLongWord: (VLongWord: LongWord);
                        varInt64:    (VInt64: Int64);
                        varString:   (VString: Pointer);
                        varAny:      (VAny: Pointer);
                        varArray:    (VArray: PVarArray);
                        varByRef:    (VPointer: Pointer);
                     );
                  1: (VLongs: array[0..2] of LongInt);
               );
            2: (VWords: array [0..6] of Word);
            3: (VBytes: array [0..13] of Byte);
          );
      1: (RawData: array [0..3] of LongInt);
  end;

  {$ENDIF}

Function VarTypeToString( vt: TVarType ): String;
  Var
    S: String;
  Begin
    Result := '';
    If (varByRef and vt) <> 0 then
      Result := 'Byref ';
    If (varArray and vt) <> 0 then
      Result := Result + 'array of ';
    If (VT_VECTOR and vt) <> 0 then
      Result := Result + 'vector of ';

    Case vt AND varTypemask Of
      varEmpty    : S:= 'varEmpty (VT_EMPTY)';
      varNull     : S:= 'varNull (VT_NULL)';
      varSmallint : S:= 'varSmallint (VT_I2)';
      varInteger  : S:= 'varInteger (VT_I4)';
      varSingle   : S:= 'varSingle (VT_R4)';
      varDouble   : S:= 'varDouble (VT_R8)';
      varCurrency : S:= 'varCurrency (VT_CY)';
      varDate     : S:= 'varDate (VT_DATE)';
      varOleStr   : S:= 'varOleStr (VT_BSTR)';
      varDispatch : S:= 'varDispatch (VT_DISPATCH)';
      varError    : S:= 'varError (VT_ERROR)';
      varBoolean  : S:= 'varBoolean (VT_BOOL)';
      varVariant  : S:= 'varVariant (VT_VARIANT)';
      varUnknown  : S:= 'varUnknown (VT_UNKNOWN)';
      VT_DECIMAL  : S:= 'VT_DECIMAL';
      varShortInt : S:= 'varShortInt (VT_I1)';
      varByte     : S:= 'varByte (VT_UI1)';
      varWord     : S:= 'varWord (VT_UI2)';
      varLongWord : S:= 'varLongWord (VT_UI4)';
      varInt64    : S:= 'varInt64 (VT_I8)';
      VT_UI8      : S:= 'VT_UI8';
      VT_INT      : S:= 'VT_INT';
      VT_UINT     : S:= 'VT_UINT';
      VT_VOID     : S:= 'VT_VOID';
      VT_HRESULT  : S:= 'VT_HRESULT';
      VT_PTR      : S:= 'VT_PTR';
      VT_SAFEARRAY: S:= 'VT_SAFEARRAY';
      VT_CARRAY   : S:= 'VT_CARRAY';
      VT_USERDEFINED: S:= 'VT_USERDEFINED';
      VT_LPSTR    : S:= 'VT_LPSTR';
      VT_LPWSTR   : S:= 'VT_LPWSTR';
      VT_RECORD   : S:= 'VT_RECORD';
      VT_INT_PTR  : S:= 'VT_INT_PTR';
      VT_UINT_PTR : S:= 'VT_UINT_PTR';
      VT_FILETIME : S:= 'VT_FILETIME';
      VT_BLOB     : S:= 'VT_BLOB';
      VT_STREAM   : S:= 'VT_STREAM';
      VT_STORAGE  : S:= 'VT_STORAGE';
      VT_STREAMED_OBJECT: S:= 'VT_STREAMED_OBJECT';
      VT_STORED_OBJECT: S:= 'VT_STORED_OBJECT';
      VT_BLOB_OBJECT: S:= 'VT_BLOB_OBJECT';
      VT_CF       : S:= 'VT_CF';
      varStrArg   : S:= 'varStrArg (VT_CLSID)';
      VT_VERSIONED_STREAM: S:= 'VT_VERSIONED_STREAM';
      VT_BSTR_BLOB: S:= 'VT_BSTR_BLOB';
      varString   : S:= 'varString';
      varAny      : S:= 'varAny';
      VT_ILLEGAL  : S:= 'unknown';
    else
      S:= Format('unknown typecode $%x', [vt and varTypemask]);
    End; { Case }
    Result := Result + S;
  End;

Function VariantToXML( const V: Variant ): String;
  Var
    generator: TXMLGenerator;
    converter: IVariantToXML;
  Begin { VariantToXML }
    generator := TXMLGenerator.CreateWithEncoding( $10000, encISO_8859_1 );
    Try
      converter:=  TPBVariantToXMLConverter.Create( generator );
      converter.Convert( V );
      Result := converter.AsAnsiString;
    Finally
      generator.Free;
    End; { Finally }
  End; { VariantToXML }

Procedure SaveStringToFile( const S, filename: String );
  Var
    fs: TFilestream;
  Begin
    fs:= TFileStream.Create( filename, fmCreate );
    try
      If Length( S ) > 0 Then 
        fs.WriteBuffer( S[ 1 ], Length( S ));
    finally
      fs.free
    end;
  End; { SaveStringToFile }

{$IFNDEF DELPHI6_UP}
Function IncludeTrailingPathDelimiter( const path: String ): String;
  Begin
    Result := IncludeTrailingBackslash( path );
  End;

const
  oleaut32 = 'oleaut32.dll';

function SafeArrayGetDim( pdata: PVarArray ): Integer; stdcall;
  external oleaut32 name 'SafeArrayGetDim';

function SafeArrayPtrOfIndex(psa: PVarArray; rgIndices: Pointer; out pvData: Pointer): HResult; stdcall;
  external oleaut32 name 'SafeArrayPtrOfIndex';

function SafeArrayGetLBound(psa: PVarArray; nDim: Integer; out lLbound: Longint): HResult; stdcall;
  external oleaut32 name 'SafeArrayGetLBound';

function SafeArrayGetUBound(psa: PVarArray; nDim: Integer; out lUbound: Longint): HResult; stdcall;
  external oleaut32 name 'SafeArrayGetUBound';

function SafeArrayLock(psa: PVarArray): HResult; stdcall;
  external oleaut32 name 'SafeArrayLock';
function SafeArrayUnlock(psa: PVarArray): HResult; stdcall;
  external oleaut32 name 'SafeArrayUnlock';
function SafeArrayGetElemsize(psa: PVarArray): Integer; stdcall;
  external oleaut32 name 'SafeArrayGetElemsize';
{$ENDIF}


Function DebugDisplayVariant( const V: Variant ): String;
  Var
    S: String;
    filename: String;