pbvariantutils.pas

Delphi snippet to convert variants values to xml

    buffer: Array [0..MAX_PATH] of Char;
  Begin
    Try
      S:= VariantToXML( V );
      GetTempPath( sizeof( buffer ), buffer );
      filename := IncludeTrailingPathDelimiter( buffer )+'variant.xml';
      SavestringToFile( S, filename );
      Sleep( 250 );
      If 32 < ShellExecute( 0, 'open', Pchar(filename), nil, nil, SW_SHOWNORMAL )
      Then
        Result := 'OK'
      Else
        Result := 'ShellExecute failed';
    Except
      On E: Exception Do
        Result := Format( 'Exception %s, %s', [E.classname, E.message] );
    End; { Except }
  End;

{: Helper routine to treat a variant as an array of 4 integers. D7 has that
  build in, but the lower versions do not.
@precondition 0 <= index < 4 }
Function RawData( const V: Variant; index: Integer ): Longint;
  Type
    TConv= Record
      Case Boolean of
        false: (V: TVarData);
        true : (rawdata: Array [0..3] of Longint );
    end;
  Begin
    Assert( (index >= 0) and (index < 4));
    Result := Tconv(V).Rawdata[index];
  End;

{棗 TPBVariantToXMLConverter 棗棗棗棗棗棗棗棗棗棗棗棗棗棗棗棗棗棗棗棗棗}

Constructor TPBVariantToXMLConverter.Create(generator: TXMLGenerator);
  Begin
    inherited Create;
    If Assigned( generator ) Then
      FGenerator := generator
    Else Begin
      FGenerator := TXMLGenerator.CreateWithEncoding( $10000, encISO_8859_1 );
      FOwnsGenerator := true;
    End;
    {$IFDEF DELPHI7_UP}
    GetLocaleFormatSettings( GetThreadLocale(), FFmt );
    FFmt.ThousandSeparator := ',';
    FFmt.DecimalSeparator  := '.';
    {$ENDIF}
  End;

Destructor TPBVariantToXMLConverter.Destroy;
  Begin
    If FOwnsGenerator Then
      FGenerator.Free;
    inherited;
  End;

Function TPBVariantToXMLConverter.AsAnsiString: String;
  Begin
    Result := FGenerator.AsLatin1;
  End;

Function TPBVariantToXMLConverter.AsUTF16: WideString;
  Begin
    Result := FGenerator.AsString;
  End;

Function TPBVariantToXMLConverter.AsUTF8: String;
  Begin
    Result := FGenerator.AsUTF8;
  End;

Procedure TPBVariantToXMLConverter.Convert(const V: Variant);
  Begin
    WriteVariant( V );
  End;

Procedure TPBVariantToXMLConverter.ConvertArrayVariantData(
    const V: Variant; vt: TVarType);
  Begin
    WriteSafeArray( TVarData( V ).VArray, vt and varTypeMask );
  End;

Procedure TPBVariantToXMLConverter.ConvertByRefVariantData(
    const V: Variant; vt: TVarType);
  Var
    pData: Pointer;
  Begin
    pData := TvarData( V ).VPointer;
    If pData = nil Then
      WriteString('Error: nil pointer for varByRef data')
    Else If (vt and VT_VECTOR) <> 0 Then
      WriteVectorData( PVector( pData )^.numElements,
                       PVector( pData )^.pData,
                       vt and varTypeMask )
    Else If (vt and varArray) <> 0 Then
      WriteSafeArray( PVarArray( ppointer( pData )^), vt and varTypeMask )
    Else
      WriteElementData( pData, vt and varTypeMask);
  End;

Procedure TPBVariantToXMLConverter.ConvertSimpleVariantData(
    const V: Variant);
  Var
    vt: TVarType;
  Begin
    vt := VarType( V );
    Assert( (vt and not vartypemask) = 0,
           'cannot handle byref, array, or vector variants here' );

    Case vt Of
      varEmpty    : ;  // no output for an empty variant
      varNull     : ;  // no output for a null variant
      varSmallint : WriteInteger( TVarData( V ).VSmallInt );
      varInteger  : WriteInteger( TVarData( V ).VInteger );
      varSingle   : WriteFloat( TVarData( V ).VSingle );
      varDouble   : WriteFloat( TVarData( V ).VDouble );
      varCurrency : WriteCurrency( TVarData( V ).VCurrency );
      varDate     : WriteDate( TVarData( V ).VDate );
      varOleStr   : WriteBStr( TVarData( V ).VOleStr );
      varDispatch : WriteAddress( TVarData( V ).VDispatch );
      varError    : WriteHex( TVarData( V ).VError, 8 );
      varBoolean  : WriteBoolean( TVarData( V ).VBoolean );

      // varVariant should never happen without varbyRef or varArray
      varVariant  : WriteVariant( PVariant(TVarData( V ).VPointer)^ );

      varUnknown  : WriteAddress( TVarData( V ).VUnknown );
      VT_DECIMAL  : WriteDecimal( TDecimal( V ));
      varShortInt : WriteInteger( TVarData( V ).VShortInt );
      varByte     : WriteInteger( TVarData( V ).VByte );
      varWord     : WriteInteger( TVarData( V ).VWord );
      varLongWord : WriteInt64( TVarData( V ).VLongWord );
      varInt64    : WriteInt64( TVarData( V ).VInt64 );
      VT_UI8      : WriteHex64( TVarData( V ).VInt64 );

      // machine-specific int, may be int64 on future platforms
      VT_INT      : WriteInteger( TVarData( V ).VInteger );
      // machine-specific uint, may be uint64 on future platforms
      VT_UINT     : WriteInt64( TVarData( V ).VLongWord );

      { The following vattypes will not be used in variants as a
        rule, they are for TYPEDESCs }
      VT_VOID     : WriteAddress( TVarData( V ).VPointer );
      // variants will use VT_ERROR instead of this
      VT_HRESULT  : WriteHex( TVarData( V ).VError, 8 );
      VT_PTR      : WriteAddress( TVarData( V ).VPointer );
      // variants will use varArray+type instead of this
      VT_SAFEARRAY: WriteSafeArray( TVarData( V ).VArray, VT_ILLEGAL );
      VT_CARRAY   : ; // not handled
      VT_USERDEFINED: ; // not handled

      { The following vartypes are used in PROPVARIANTs only }
      VT_LPSTR    : If Assigned( TvarData( V ).VPointer ) Then
                      WriteString( PChar( TvarData( V ).VPointer ));
      VT_LPWSTR   : If Assigned( TvarData( V ).VPointer ) Then
                      WriteBStr( TVarData( V ).VOleStr );
      VT_RECORD   : ; // not handled
      VT_INT_PTR  : If Assigned( TvarData( V ).VPointer ) Then
                      WriteInteger( PInteger(TvarData( V ).VPointer)^);
      VT_UINT_PTR : If Assigned( TvarData( V ).VPointer ) Then
                      WriteInt64( PCardinal(TvarData( V ).VPointer)^);
      VT_FILETIME : WriteFiletime( TvarData( V ).VInt64 );
      VT_BLOB     : WriteBinary( ULONG( Rawdata(V, 2) ),
                                 pointer( Rawdata( V, 3 )));
      VT_STREAM   : ; // not handled
      VT_STORAGE  : ; // not handled
      VT_STREAMED_OBJECT: ; // not handled
      VT_STORED_OBJECT: ; // not handled
      VT_BLOB_OBJECT: ; // not handled
      VT_CF       : ; // not handled
      varStrArg   : WriteString( GuidToString( PGUID( TvarData( V ).VPointer )^));
      VT_VERSIONED_STREAM: ;// not handled
      VT_BSTR_BLOB: ;// not handled

      // Pascal Ansistring, not COM-compatible
      varString   : WriteString( String(TvarData( V ).VString));
      varAny      : ;// not handled
    End; { Case }
  End;

Procedure TPBVariantToXMLConverter.ConvertVariantData(const V: Variant);
  Var
    vt: TVarType;
  Begin
    vt:= VarType( V );
    If (varByRef and vt) <> 0 Then
      ConvertByRefVariantData( V, vt and not varByRef )
    Else If (VT_VECTOR and vt) <> 0 Then
      ConvertVectorVariantData( V, vt and not VT_VECTOR )
    Else If (varArray and vt) <> 0 Then
      ConvertArrayVariantData( V, vt and not varArray )
    Else
      ConvertSimpleVariantData( V );
  End;

Procedure TPBVariantToXMLConverter.ConvertVectorVariantData(
    const V: Variant; vt: TVarType);
  Begin
    WriteVectorData( Cardinal( Rawdata(V, 2)),
                     Pointer(  Rawdata(V, 3)),
                     vt and varTypeMask );
  End;

Function TPBVariantToXMLConverter.GetBoundsString(
    value: PVarArray): String;
  Var
    sl: Tstringlist;
    i: Integer;
  Begin
    sl:= Tstringlist.Create;
    Try
      For i:= 0 To SafeArrayGetDim( value )-1 Do
        sl.Add( Format( '%d..%d',
                        [ GetSafeArrayLBound( value, i ),
                          GetSafeArrayUBound( value, i )
                        ] ));
      Result := sl.CommaText;
    Finally
      sl.Free;
    End; { Finally }
  End;

Function TPBVariantToXMLConverter.GetElementSize(vt: TVarType): Integer;
  Begin
    Result := -1;
    Case vt Of
      varSmallint : Result := Sizeof( SmallInt );
      varInteger  : Result := Sizeof( Integer );
      varSingle   : Result := Sizeof( Single );
      varDouble   : Result := Sizeof( Double );
      varCurrency : Result := Sizeof( Currency );
      varDate     : Result := Sizeof( TDateTime );
      varOleStr   : Result := Sizeof( Widestring );
      varDispatch : Result := Sizeof( Pointer );
      varError    : Result := Sizeof( Cardinal );
      varBoolean  : Result := Sizeof( WordBool );
      varVariant  : Result := Sizeof( Variant );
      varUnknown  : Result := Sizeof( Pointer );
      VT_DECIMAL  : Result := Sizeof( TDecimal );
      varShortInt : Result := Sizeof( ShortInt );
      varByte     : Result := Sizeof( Byte );
      varWord     : Result := Sizeof( Word );
      varLongWord : Result := Sizeof( LongWord );
      varInt64    : Result := Sizeof( Int64 );
      VT_UI8      : Result := Sizeof( Int64 );
      VT_INT      : Result := Sizeof( Integer );
      VT_UINT     : Result := Sizeof( LongWord );
      VT_FILETIME : Result := Sizeof( TFiletime );
      VT_BLOB     : Result := Sizeof( TBlob );
    End; { Case }
  End;

Function TPBVariantToXMLConverter.GetSafearrayDataPointer(value: PVarArray;
    const indices: array of integer): Pointer;
  Begin
    OleCheck( SafeArrayPtrOfIndex( value, @indices[0], result ));
  End;

Function TPBVariantToXMLConverter.GetSafeArrayLBound(value: PVarArray;
    dim: Integer): Integer;
  Begin
    { dim comes in zero-based, but the API uses 1-based numbering
      for dimensions! }
    OleCheck( SafeArrayGetLBound( value, dim+1, Result ));
  End;

Function TPBVariantToXMLConverter.GetSafeArrayUBound(value: PVarArray;
    dim: Integer): Integer;
  Begin
    { dim comes in zero-based, but the API uses 1-based numbering
      for dimensions! }
    OleCheck( SafeArrayGetUBound( value, dim+1, Result ));
  End;

Procedure TPBVariantToXMLConverter.GetSafearrayVType(value: PVarArray;
    var vt: TVarType);
  Begin
    If (value^.Flags and FADF_HAVEVARTYPE) <> 0 Then
      vt := PWord( Cardinal( value )-4 )^
    Else If (value^.Flags and FADF_BSTR ) <> 0 Then
      vt := varOleStr
    Else If (value^.Flags and FADF_UNKNOWN ) <> 0 Then
      vt := varUnknown
    Else If (value^.Flags and FADF_DISPATCH ) <> 0 Then
      vt := varDispatch
    Else If (value^.Flags and FADF_VARIANT ) <> 0 Then
      vt := varVariant
    Else // make a guess based on the element size
      Case value^.ElementSize Of
        1: vt:= varByte;
        2: vt:= varWord;
        4: vt:= varInteger;
        8: vt:= varDouble;
    // 16: vt:= varVariant;
        { This is risky, it may get us AVs if the element is not a variant}
      End;
  End;

Function TPBVariantToXMLConverter.IsSupportedElementType(
    vt: TVarType): Boolean;
  Begin
    Result := false;
    Case vt Of
      varSmallint ,
      varInteger  ,
      varSingle   ,
      varDouble   ,
      varCurrency ,
      varDate     ,
      varOleStr   ,
      varDispatch ,
      varError    ,
      varBoolean  ,
      varVariant  ,
      varUnknown  ,
      VT_DECIMAL  ,
      varShortInt ,
      varByte     ,
      varWord     ,
      varLongWord ,
      varInt64    ,
      VT_UI8      ,
      VT_INT      ,
      VT_UINT     ,
      VT_FILETIME ,
      VT_BLOB     : Result := true;
    End; { Case }
  End;

Procedure TPBVariantToXMLConverter.WriteAddress(value: Pointer);
  Begin
    WriteHex( Longword( value ), 8 );
  End;