pbvariantutils.pas

Delphi snippet to convert variants values to xml

Procedure TPBVariantToXMLConverter.WriteBinary(size: Cardinal; pvalue: Pointer);
  Begin
    FGenerator.StartTag( cBinary );
    FGenerator.SetAttribute( cSize, IntToStr( size ));
    FGenerator.SetAttribute( cEncoding, cEncodingHex );
    WriteHexData( size, PByte( pvalue ));
    FGenerator.StopTag;
  End;

Procedure TPBVariantToXMLConverter.WriteBStr(value: PWidechar);
  Begin
    FGenerator.AddData( value );
  End;

Procedure TPBVariantToXMLConverter.WriteBoolean(value: Boolean );
  Const
    BoolStr: Array [Boolean] of String = ('false','true');
  Begin
    WriteString( BoolStr[ value ] );
  End;

Procedure TPBVariantToXMLConverter.WriteCurrency(const value: Currency );
  {$IFNDEF DELPHI7_UP}
  Var
    oldsep1, oldsep2: Char;
 {$ENDIF}
  Begin
    {$IFDEF DELPHI7_UP}
    Writestring( FormatCurr('0.00', value, FFmt ));
    {$ELSE}
    { THIS IS NOT THREAD-SAFE! }
    oldsep1 := DecimalSeparator;
    oldsep2 := ThousandSeparator;
    DecimalSeparator := '.';
    ThousandSeparator:= ',';
    try
      Writestring( FormatCurr('0.00', value ));
    finally
      DecimalSeparator := oldsep1;
      ThousandSeparator:= oldsep2;
    end;
    {$ENDIF}
  End;

Procedure TPBVariantToXMLConverter.WriteDate(const value: TDatetime );
  Begin
    Writestring( FormatDatetime('yyyy-mm-dd hh:nn:ss', value ));
  End;

Function MakeLangID( p, s: Word ): Word;
Begin
  Result := (s shl 10) or p
End;

Function MakeLCID( lgID: Word; srtid: Word ): DWORD;
Begin
  Result := MakeLong( lgid, srtid );
End;

Procedure TPBVariantToXMLConverter.WriteDecimal(const value: TDecimal );
  Var
    ws: Widestring;
  Begin
    If Succeeded( VarBstrFromDec( @value,
                    MakeLCID(
                      MakeLangID( LANG_ENGLISH, SUBLANG_NEUTRAL ),
                      SORT_DEFAULT ),
                    0,
                    ws ))
    Then
      FGenerator.AddData( ws )
    Else
      FGenerator.AddData( 'Error: VarBstrFromDec failed' );
  End;

Procedure TPBVariantToXMLConverter.WriteElementData(pData: Pointer;
    vt: TVarType);
  Begin
    Case vt Of
      varSmallint : WriteInteger( pSmallInt( pData )^ );
      varInteger  : WriteInteger( PInteger( pData )^ );
      varSingle   : WriteFloat( PSingle( pData )^ );
      varDouble   : WriteFloat( PDouble( pData )^ );
      varCurrency : WriteCurrency( PCurrency( pData )^ );
      varDate     : WriteDate( PDateTime( pData )^ );
      varOleStr   : WriteBStr( PWideChar( pData^ ) );
      varDispatch : WriteAddress( PPointer( pData )^ );
      varError    : WriteHex( PCardinal( pData )^, 8 );
      varBoolean  : WriteBoolean( PWordBool( pData )^ );

      // varVariant should never happen without varbyRef or varArray
      varVariant  : WriteVariant( PVariant( pData )^ );

      varUnknown  : WriteAddress( PPointer( pData )^ );
      VT_DECIMAL  : WriteDecimal( PDecimal( pData )^ );
      varShortInt : WriteInteger( PShortInt( pData )^ );
      varByte     : WriteInteger( PByte( pData )^ );
      varWord     : WriteInteger( PWord( pData )^ );
      varLongWord : WriteInt64( PLongWord( pData )^ );
      varInt64    : WriteInt64( PInt64( pData )^ );
      VT_UI8      : WriteHex64( PInt64( pData )^ );

      // machine-specific int, may be int64 on future platforms
      VT_INT      : WriteInteger( PInteger( pData )^ );
      // machine-specific uint, may be uint64 on future platforms
      VT_UINT     : WriteInt64( PLongWord( pData )^ );

      VT_FILETIME : WriteFiletime( PInt64( pData )^ );
      VT_BLOB     : WriteBinary( PBlob( pData )^.cbSize,
                                 PBlob( pData )^.pBlobData );
    Else
      WriteString('Error: ByRef type not implemented');
    End; { Case }
  End;

Procedure TPBVariantToXMLConverter.WriteFiletime(const value: int64);
  Var
    st: TSystemTime;
  Begin
    FileTimeToSystemTime( TFiletime( value ), st );
    WriteDate(  SystemTimeToDateTime( st ));
  End;

Procedure TPBVariantToXMLConverter.WriteFloat(const value: Double);
  {$IFNDEF DELPHI7_UP}
  Var
    oldsep: Char;
 {$ENDIF}
  Begin
    {$IFDEF DELPHI7_UP}
    Writestring( FloatToStr( value, FFmt ));
    {$ELSE}
    oldsep := DecimalSeparator;
    DecimalSeparator := '.';
    try
      Writestring( FloatToStr( value ));
    finally
      DecimalSeparator := oldsep;
    end;
    {$ENDIF}
  End;

Procedure TPBVariantToXMLConverter.WriteHex(value: Cardinal;
  width: integer);
  Begin
    WriteString( '0x'+IntToHex( value, width ));
  End;

Procedure TPBVariantToXMLConverter.WriteHex64(value: int64 );
  Begin
    WriteString( '0x'+IntToHex( value, 16 ));
  End;

Procedure TPBVariantToXMLConverter.WriteHexData( size: Cardinal; pData: PByte );
  Const
    sectionsize = 70;
    hexchars = '0123456789ABCDEF';
  Var
    pBuffer, pDest: PChar;
    i: Cardinal;
  Begin
    If (size = 0) or not assigned( pData ) Then
      Exit;
    pBuffer := AllocMem( size*2  // for the data, 2 chars per byte
                         + (size div sectionsize + 1)*2  // linebreaks
                         + 1     // #0 terminator
                         );
    Try
      pDest := pBuffer;
      For i:= 1 To size Do Begin
        pDest^ := hexchars[ ((pData^ shr 4) and $F) + 1 ];
        Inc( pDest );
        pDest^ := hexchars[ (pData^ and $F) + 1 ];
        Inc( pDest );
        Inc( pData );
        If (i MOD sectionsize) = 0 Then Begin
          pDest^ := #13;
          Inc( pDest );
          pDest^ := #10;
          Inc( pDest );
        End;
      End; { For }
      WriteString( pBuffer );
    Finally
      FreeMem( pBuffer );
    End; { Finally }
  End;

Procedure TPBVariantToXMLConverter.WriteInt64(value: int64);
  Begin
    WriteString( IntToStr( value ));
  End;

Procedure TPBVariantToXMLConverter.WriteInteger(value: Integer);
  Begin
    WriteString( IntToStr( value ));
  End;

Procedure TPBVariantToXMLConverter.WriteSafeArray(value: PVarArray; vt: TVarType );
  Var
    indices: array of Integer;

  { Construct the index for the first array element, then subtract 1
    from the rightmost index. This way Next will get us to the first
    element and at the same time allow us to check for an empty array.
    Empty safearray are not exactly legal, but they happen. }
  Procedure InitIndices;
    Var
      i: Integer;
    Begin
      SetLength( indices, SafearrayGetDim( value ));
      For i:= 0 to SafearrayGetDim( value )-1 Do
        indices[i] := GetSafeArrayLBound( value, i );
      Dec( indices[ High( indices )]);
    End;  { First }

  { Construct the index for the next array element, returns
    false if we are at the end of array. }
  Function Next: Boolean;
    Var
      i: Integer;
    Begin
      Result := true;
      For i:= SafearrayGetDim( value )-1 Downto 0 Do Begin
        Inc( indices[i] );
        If indices[i] > GetSafeArrayUBound( value, i ) Then
          If i = 0 Then
            result := false  // was at last element
          Else
            indices[i] := GetSafeArrayLBound( value, i )
        Else
          Break;
      End; { For }
    End; { Next }

  Function IndexString: WideString;
    Var
      i: Integer;
      sl: TStringlist;
    Begin
      sl:= Tstringlist.Create;
      Try
        For i:= 0 to High( indices ) Do
          sl.Add( IntToStr( indices[i] ));
        Result := Format( '[%s]', [ sl.commatext ] );
      Finally
        sl.Free;
      End; { Finally }
    End; {  }

  Var
    pData: Pointer;
  Begin { WriteSafeArray }
    FGenerator.StartTag( cArray );
    Try
      If not Assigned( value ) Then Begin
        WriteString('Error: safearray address is nil');
        Exit;
      End; { If }

      If vt = VT_ILLEGAL Then // VT_SAFEARRAY got us here
        GetSafearrayVType( value, vt );

      FGenerator.SetAttribute( cBounds,
                               GetBoundsString( value ));

      InitIndices;
      SafeArrayLock( value );
      Try
        While Next Do Begin
          FGenerator.StartTag( cElement );
          FGenerator.SetAttribute( ctype,
                                   VarTypeToString( vt ));
          FGenerator.SetAttribute( cIndices, IndexString );
          pData := GetSafearrayDataPointer( value, indices );
          If IsSupportedElementType( vt ) Then
            WriteElementData( pData, vt)
          Else
            WriteBinary( SafeArrayGetElemSize( value ), pData );
          FGenerator.StopTag;
        End;
      Finally
        SafeArrayUnlock( value );
      End; { Finally }
    Finally
      FGenerator.StopTag;
    End; { Finally }
  End; { TPBVariantToXMLConverter.WriteSafeArray }

Procedure TPBVariantToXMLConverter.WriteString(value: String);
  Begin
    FGenerator.AddData( value );
  End;

Procedure TPBVariantToXMLConverter.WriteVariant(const value: Variant);
  Begin
    FGenerator.StartTag( cVariant );
    FGenerator.SetAttribute( cType,
                             VarTypeToString(VarType( value )));
    ConvertVariantData( value );
    FGenerator.StopTag;
  End;

Procedure TPBVariantToXMLConverter.WriteVectorData(
    numElements: Cardinal; pData: Pointer; vt: TVarType );
  Var
    i: Cardinal;
    elementsize: Integer;
  Begin
    Assert( Assigned( pData ));
    FGenerator.StartTag( cArray );
    If numElements > 0 Then Begin
      FGenerator.SetAttribute( cBounds,
                               Format('[0..%d]', [numElements-1]));
      If IsSupportedElementType( vt ) Then Begin
        elementsize:= GetElementSize( vt );
        For i := 0 To numElements-1 Do Begin
          FGenerator.StartTag( cElement );
          FGenerator.SetAttribute( cIndices,
                                   Format('[%d]',[i] ));
          WriteElementData( pData, vt );
          Inc( PChar( pData ), elementsize );
          FGenerator.StopTag;
        End; { For }
      End; { If }
    End { If }
    Else
      FGenerator.SetAttribute( cBounds, '[]' );
    FGenerator.StopTag;
  End;

End.