unit QExport4XML;

{$I QExport4VerCtrl.inc}

interface

uses
  {$IFDEF VCL16}
    System.Classes,
    Winapi.Windows,
    System.DateUtils,
    Vcl.Graphics,
  {$ELSE}
    Classes,
    Windows,
    Graphics,
    {$IFDEF VCL6}
    DateUtils,
    {$ENDIF}
  {$ENDIF}
  QExport4, QExport4Types;



type

  TQExportXMLType = (xtDatapacket2, xtAccess);

  TQXMLWriter = class(TQExportWriter)
  public
    procedure StartTag(const TagName, Options: QEString);
    procedure EndTag(const TagName: QEString);
    procedure StartEndTag(const TagName, Options: QEString);
    procedure StartTagLn(const TagName, Options: QEString);
    procedure EndTagLn(const TagName: QEString);
    procedure StartEndTagLn(const TagName, Options: QEString);
  end;

  TXMLOptions = class(TPersistent)
  private
    FStandAlone: Boolean;
    FEncoding: string;
    FVersion: string;
    FDocumentType: TQExportXMLType;
    FExportXSDSchema: Boolean;
    FXMLMSAccessConvertImages: Boolean;
    FNeedBlobBase64: Boolean;                
  public
    constructor Create;
    procedure Assign(Source: TPersistent); override;
  published
    property Version: string read FVersion write FVersion;
    property Encoding: string read FEncoding write FEncoding;
    property StandAlone: boolean read FStandAlone write FStandAlone default true;
    property DocumentType: TQExportXMLType read FDocumentType write FDocumentType default xtDataPacket2;
    property ExportXSDSchema: boolean read FExportXSDSchema write FExportXSDSchema default true;
    property XMLMSAccessConvertImages: boolean read FXMLMSAccessConvertImages write FXMLMSAccessConvertImages default false;
    property NeedBlobBase64: Boolean read FNeedBlobBase64 write FNeedBlobBase64 default true;
  end;

  TQExport4XML = class(TQExport4Text)
  private
    FOptions: TXMLOptions;
    FCorrectNames: TStrings;
    FModifiedCaption: array of Boolean;

    procedure SetOptions(const Value: TXMLOptions);
    procedure CreateSchema;
    function GetTableName: QEString;
  protected
    procedure BeginExport; override;
    procedure BeforeExport; override;
    function GetColCaption(Index: integer): string; override;
    procedure WriteCaptionRow; override;
    function GetDataRow: QEString; override;
    procedure WriteDataRow; override;
    procedure AfterExport; override;
    {//mp - procedure for forming correct captions}
    procedure FormCorrectCaptions;
    function GetSpecialCharacters: TSpecialCharacters; override;

    function GetWriter: TQXMLWriter;
    function GetWriterClass: TQExportWriterClass; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function GetExportedValue(Col: TQExportCol): QEString; override;
    function NormalString(const S: QEString): QEString; override;
    function NormalStringByType(Col: TQExportCol; const S: QEString): QEString;
    function AddAccessOleWrap(ColData: String): String;
    function AccessDateString(ColData: Variant): QEString;
    function StrToBitmapStr(AString: string; var NoImage: Boolean): String;
  published
    property Options: TXMLOptions read FOptions write SetOptions;
    property Captions;
    property UserFormats;
  end;


  function PictureToBMP(AGraphic: TGraphic): String;

{$IFNDEF VCL6}
  function DecodeBase64(const CinLine: string): string;
  function EncodeBase64(const inStr: string): string;
{$ENDIF}



implementation

uses
  {$IFDEF VCL16}
    System.SysUtils,
    System.StrUtils,
    System.Variants,
    {$IFDEF VCL21}
    System.NetEncoding,
    {$ELSE}
    Soap.EncdDecd,
    {$ENDIF}
    Data.DB,
  {$ELSE}
    SysUtils,
    DB,
    {$IFDEF VCL6}
      EncdDecd,
      Variants,
      StrUtils,
    {$ENDIF}
  {$ENDIF}
  QExport4Common,
  QExport4EmsWideStrUtils;

const
  SYes = 'yes';
  SNo  = 'no';
  SEncoding  = 'encoding="%s" ';
  SStartXML  = '<?xml version="%s" %sstandalone="%s"?>';
  SStartData = '<DATAPACKET Version="2.0">';
  SEndData   = '</DATAPACKET>';
  SMetaData  = 'METADATA';
  SFields    = 'FIELDS';
  SRowData   = 'ROWDATA';

  SRow          = 'ROW';
  SRowField     = '%s="%s"';
  SField        = 'FIELD';
  SFieldName    = 'FieldName="%s"';
  SDisplayLabel = 'DisplayLabel="%s"';
  SFieldType    = 'FieldType="%s"';
  SFieldClass   = 'FieldClass="%s"';

  STagB = '<';
  STagE = '>';
//  STagBase64E = #32'datatype="binary.base64">';
  STagC = '/';
  SEqual = '=';
  SBlank = ' ';

  //xtAccess
  SAStartData = 'dataroot xmlns:od="urn:schemas-microsoft-com:officedata"';
  SAXSDSchema = 'xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" xsi:noNamespaceSchemaLocation'; 
  SAEndData = '</dataroot>';

  //XSD Schema
  SStartElementDataroot = '<xsd:schema xmlns:xsd="http://www.w3.org/2001/XMLSchema" xmlns:od="urn:schemas-microsoft-com:officedata">' +
    '<xsd:element name="dataroot">' +
    '<xsd:complexType>' +
    '<xsd:sequence>';
  SStartElementTable = '<xsd:element ref="';
  SEndElementTable = '" minOccurs="0" maxOccurs="unbounded"/>';
  SEndElementDataroot = '</xsd:sequence>' +
    '<xsd:attribute name="generated" type="xsd:dateTime"/>' +
    '</xsd:complexType>' +
    '</xsd:element>';

  SSimpleType = '<xsd:simpleType>' +
    '<xsd:restriction base="xsd:base64Binary">' +
    '</xsd:restriction>' +
    '</xsd:simpleType>';


  SXSDElement = 'xsd:element';
  SXSDSchema = 'xsd:schema';
  SXSDAnnotation = 'xsd:annotation';
  SXSDAppinfo = 'xsd:appinfo';
  SXSDComplexType = 'xsd:complexType';
  SXSDSequence = 'xsd:sequence';

  {//mp - list of correct symbols, which can be used for names of xml fields}
  CorrectSymbols = ['a'..'z', 'A'..'Z', '0'..'9', '-', '_', '.', ':'];

{ TQXMLWriter }

procedure TQXMLWriter.EndTag(const TagName: QEString);
begin
  Write(STagB +  STagC + TagName + STagE);
end;

procedure TQXMLWriter.EndTagLn(const TagName: QEString);
begin
  EndTag(TagName);
  EmptyLine;
end;

procedure TQXMLWriter.StartEndTag(const TagName, Options: QEString);
begin
  Write(STagB + TagName + ' ' + Options + STagC + STagE);
end;

procedure TQXMLWriter.StartEndTagLn(const TagName, Options: QEString);
begin
  StartEndTag(TagName, Options);
  EmptyLine;
end;

procedure TQXMLWriter.StartTag(const TagName, Options: QEString);
begin
  if Options <> EmptyStr then Write(STagB + TagName + ' ' + Options + STagE)
  else Write(STagB + TagName + STagE);
end;

procedure TQXMLWriter.StartTagLn(const TagName, Options: QEString);
begin
  StartTag(TagName, Options);
  EmptyLine;
end;

{ TXMLOptions }

procedure TXMLOptions.Assign(Source: TPersistent);
begin
  if Source is TXMLOptions then begin
    StandAlone := (Source as TXMLOptions).StandAlone;
    Encoding := (Source as TXMLOptions).Encoding;
    Version := (Source as TXMLOptions).Version;
    DocumentType := (Source as TXMLOptions).DocumentType;
    ExportXSDSchema := (Source as TXMLOptions).ExportXSDSchema;
    XMLMSAccessConvertImages := (Source as TXMLOptions).XMLMSAccessConvertImages;
    Exit;
  end;
  inherited;
end;

constructor TXMLOptions.Create;
begin
  inherited;
  FStandAlone := true;
  FVersion := '1.0';
  FEncoding := EmptyStr;
  FDocumentType := xtDatapacket2; //xtAccess
  FExportXSDSchema := False; //
  FXMLMSAccessConvertImages := False; //True
end;

{function StringReplace(const S, OldPattern, NewPattern: string;
  Flags: TReplaceFlags): string;
var
  SearchStr, Patt, NewStr: string;
  Offset: Integer;
begin
  if rfIgnoreCase in Flags then
  begin
    SearchStr := AnsiUpperCase(S);
    Patt := AnsiUpperCase(OldPattern);
  end else
  begin
    SearchStr := S;
    Patt := OldPattern;
  end;}

{ TQExport4XML }

procedure TQExport4XML.SetOptions(const Value: TXMLOptions);
begin
  FOptions.Assign(Value);
end;


function TQExport4XML.StrToBitmapStr(AString: string; var NoImage: Boolean): String;
const
  sigBMP = #66#77;
var
  AImg: TGraphic;
  AType: TQEImagePartType;
  SS: TStringStream;
begin
  Result := AString;
  if Pos(sigBMP, AString) = 1 then
  begin
    NoImage := False;
    Result := AString;
    Exit;
  end;
  if Options.XMLMSAccessConvertImages then
  begin
    SS := TStringStream.Create(AString);
    try
      AImg := GetGraphicFromStream(SS, AType);
      if Assigned(AImg) then
      begin
        Result := PictureToBMP(AImg);
        NoImage := False;
      end;
    finally
      SS.Free;
    end;
  end;
end;

function TQExport4XML.AccessDateString(ColData: Variant): QEString;
var
  TempD: TDateTime;

  function GetTryStrToDateTime(AStr: Variant; var ADate: TDateTime): Boolean;
  begin
    {$IFNDEF VCL6}
     try
       ADate := StrToDateTime(AStr);
       Result := True;
     except
       Result := False;
     end;
    {$ELSE}
     Result := TryStrToDateTime(AStr, ADate);
    {$ENDIF}
  end;

begin
  if (Options.DocumentType = xtAccess) and GetTryStrToDateTime(ColData, TempD) then
    Result := FormatDateTime('yyyy-mm-dd', TempD) + 'T' + FormatDateTime('hh:nn:ss', TempD)
  else
    Result := ColData;
end;

procedure TQExport4XML.CreateSchema;

  function GetTag(Name: QEString;
    Start: Boolean; AText: QEString = ''): QEString;
  begin
    if Start then
      Result := STagB + Name
    else
      Result := STagB + STagC + Name;

    Result := Result + SBlank + AText + STagE;
  end;

  function GetFieldType(ColType: TQExportColType): QEString;
  begin
    case ColType of
      ectInteger, ectBigint:
        Result := 'minOccurs="0" od:jetType="longinteger" od:sqlSType="int" type="xsd:int"';
      ectFloat, ectCurrency, ectNumeric:
        Result := 'minOccurs="0" od:jetType="currency" od:sqlSType="money" type="xsd:double"';
      ectDate, ectTime, ectDateTime:
        Result := 'minOccurs="0" od:jetType="datetime" od:sqlSType="datetime" type="xsd:dateTime"';
      ectString:
        Result := 'minOccurs="0" od:jetType="text" od:sqlSType="nvarchar"';
      ectBoolean:
        Result := 'minOccurs="1" od:jetType="yesno" od:sqlSType="bit" od:nonNullable="yes" type="xsd:boolean"';
    else
      Result := 'minOccurs="0" od:jetType="oleobject" od:sqlSType="varbinary"';
    end;
  end;

var
  SchemaBody: QEString;
  Stream: TFileStream;
  Writer: TQXMLWriter;
  i: Integer;
begin
  Stream := TFileStream.Create(ChangeFileExt(FileName, '.xsd'), fmCreate);
  try
    Writer := TQXMLWriter.Create(Self, Stream);
    try
      SchemaBody := '<?xml version="1.0" encoding="UTF-8"?>';
      SchemaBody := SchemaBody + SStartElementDataroot + SStartElementTable + GetTableName +
        SEndElementTable + SEndElementDataroot + CRLF;

      //table options
      SchemaBody := SchemaBody + GetTag(SXSDElement, True, 'name="' + GetTableName + '"') + CRLF;
      SchemaBody := SchemaBody + GetTag(SXSDAnnotation, True) + GetTag(SXSDAppinfo, True) + CRLF;
      //data od:tableProperty is not necessary
      SchemaBody := SchemaBody + GetTag(SXSDAppinfo, False) + GetTag(SXSDAnnotation, False) +
        GetTag(SXSDComplexType, True) + GetTag(SXSDSequence, True) + CRLF;

      for i := 0 to Columns.Count - 1 do
      begin
        SchemaBody := SchemaBody + GetTag(SXSDElement, True,
          'name="' + Columns[i].Name + '" ' + GetFieldType(Columns[i].ColType)) + CRLF;
        SchemaBody := SchemaBody + GetTag(SXSDAnnotation, True) + GetTag(SXSDAppinfo, True) + CRLF;
        //data od:fieldProperty is not necessary
       if Columns.Items[i].ColType <> ectUnknown then
        SchemaBody := SchemaBody + GetTag(SXSDAppinfo, False) + GetTag(SXSDAnnotation, False) +
          GetTag(SXSDElement, False) + CRLF
       else
        SchemaBody := SchemaBody + GetTag(SXSDAppinfo, False) + GetTag(SXSDAnnotation, False) +
          SSimpleType + GetTag(SXSDElement, False) + CRLF;
      end;

      SchemaBody := SchemaBody + GetTag(SXSDSequence, False) +
        GetTag(SXSDComplexType, False) + GetTag(SXSDElement, False) + GetTag(SXSDSchema, False);
      Writer.Write(SchemaBody);
    finally
      Writer.Free;
    end;
  finally
    Stream.Free;
  end;
end;

function TQExport4XML.GetTableName: QEString;
begin
  Result := ChangeFileExt(ExtractFileName(FileName), '');
end;

constructor TQExport4XML.Create(AOwner: TComponent);
begin
  inherited;
  FOptions := TXMLOptions.Create;
  FOptions.NeedBlobBase64 := True;
  FCorrectNames := TStringList.Create;
end;

destructor TQExport4XML.Destroy;
begin
  FCorrectNames.Free;
  FOptions.Free;
  inherited;
end;

procedure TQExport4XML.BeginExport;
var
  sStandAlone, sEnc, sAccessStart: string;
begin
  inherited;
  FCorrectNames.Clear;
  FormCorrectCaptions;
  if FOptions.StandAlone then sStandAlone := SYes
  else sStandAlone := sNo;
  if FOptions.Encoding <> EmptyStr then sEnc := Format(SEncoding, [FOptions.Encoding])
  else sEnc := EmptyStr;
  GetWriter.WriteLn(Format(SStartXML, [FOptions.Version, sEnc, sStandAlone]));

  if Options.ExportXSDSchema then CreateSchema;
  case Options.DocumentType of
    xtDatapacket2:
      GetWriter.WriteLn(SStartData);
    xtAccess:
    begin
      sAccessStart := STagB + SAStartData;
      if Options.ExportXSDSchema then
        sAccessStart := sAccessStart + SBlank + SAXSDSchema + '="' + ChangeFileExt(ExtractFileName(FileName), '.xsd') +'"' + STagE
      else
        sAccessStart := sAccessStart + STagE;
      GetWriter.WriteLn(sAccessStart);
    end;
  end;
end;

procedure TQExport4XML.BeforeExport;
begin
  case Options.DocumentType of
    xtDatapacket2:
      GetWriter.StartTagLn(SRowData, EmptyStr);
  end;
end;

function TQExport4XML.GetColCaption(Index: integer): string;
var
  FName: string;
  FDisplay: string;
begin
  case Options.DocumentType of
    xtDatapacket2:
      begin
        {FName := StringReplace(Columns[Index].Name, ' ', '_', [rfReplaceAll, rfIgnoreCase]);}
        {mp - new string}
        FName := FCorrectNames[Index];
        Result := Format(SFieldName, [FName]) + SBlank;
        FDisplay := NormalString(StringReplace(
          Columns[Index].Caption, ' ', '_', [rfReplaceAll, rfIgnoreCase]));
//dee          Columns[Index].Name, ' ', '_', [rfReplaceAll, rfIgnoreCase]));
        {mp - Check name displaying here - if some bugs will happen}
        {then change FDisplay variable to FName in next string}
        {it will be full compitable}
        Result := Result + Format(SDisplayLabel, [FDisplay]) + SBlank;
        Result := Result + Format(SFieldType,
          [QExportColTypeAsString(Columns[Index].ColType)]) + SBlank;
        Result := Result + Format(SFieldClass, ['TField']);
      end;
  end;
end;


function TQExport4XML.GetExportedValue(Col: TQExportCol): QEString;
begin
  case Columns[Col.ColumnIndex].FieldType of
   ftParadoxOle, ftArray, ftOraBlob,
   ftOraClob, ftDBaseOle, ftGraphic,
   ftBytes, ftVarBytes, ftBlob, ftTypedBinary:
     begin
       if VarIsNull(Col.Data) or VarIsEmpty(Col.Data) {$IFDEF VCL6} or VarIsClear(Col.Data) {$ENDIF}
         or (not Options.NeedBlobBase64) then
          Result := inherited GetExportedValue(Col)
        else
        begin
          {$IFDEF VCL21}
          Result := TNetEncoding.Base64.Encode(AddAccessOleWrap(String(Col.Value)));
          {$ELSE}
          {$IFDEF VCL6}
          Result := {$IFDEF VCL16}Soap.{$ENDIF}EncdDecd.EncodeString(AddAccessOleWrap(String(Col.Value))); //encode to base64
          {$ELSE}
           Result := EncodeBase64(AddAccessOleWrap(String(Col.Value)));
          {$ENDIF}
          {$ENDIF}
        end;
     end;
{   ftDate, ftTime, ftDateTime: Result := AccessDateString(Col.Value);}
   {$IFNDEF VCL6}
     {$IFDEF QE_UNICODE}
    ftWideString, ftString, ftFloat: Result := Utf8EncodeForDelphi5(Col.Value);
    {$ENDIF}
   {$ENDIF}
    ftMemo, {$IFDEF VCL10}ftWideMemo,{$ENDIF}{$IFDEF VCL7} ftFmtMemo,{$ENDIF}
    ftString, ftWideString: Result := NormalStringByType(Col, Col.Value);
    else
      Result := inherited GetExportedValue(Col);
  end;
end;


procedure TQExport4XML.WriteCaptionRow;
var
  i: integer;
begin
  case Options.DocumentType of
    xtDatapacket2:
      begin
        GetWriter.StartTagLn(SMetaData, EmptyStr);
        GetWriter.StartTagLn(SFields, EmptyStr);

        for i := 0 to Columns.Count - 1 do
          GetWriter.StartEndTagLn(SField, GetColCaption(i));

        GetWriter.EndTagLn(SFields);
        GetWriter.EndTagLn(SMetaData);
      end;
  end;
end;

function TQExport4XML.GetDataRow: QEString;
var
  i: integer;
begin
  Result := EmptyStr;
  case Options.DocumentType of
    xtDatapacket2:
      begin
        for i := 0 to ExportRow.Count - 1 do
          Result := Result + {QEStringReplace(ExportRow[i].Name, ' ', '_', [rfReplaceAll, rfIgnoreCase]) +}
            FCorrectNames[i] +
            '="' + GetExportedValue(ExportRow[i]) + '"' + SBlank;
      {  for i := 0 to Columns.Count - 1 do
          Result := Result + Format(sRowField, [Columns[i].Name, GetColData(i, NeedFormat)]) + SBlank;}
        QEDelete(Result, Length(Result), 1);
      end;
    xtAccess:
      begin
        Result := STagB + GetTableName + STagE;
        for i := 0 to ExportRow.Count - 1 do
          if Columns.Count > i then
            if Columns[ExportRow[i].ColumnIndex].FieldType in [ftParadoxOle,
                ftArray, ftOraBlob, ftOraClob, ftDBaseOle, ftGraphic, ftBytes,
                ftVarBytes, ftBlob, ftTypedBinary] then
              begin
                Result := Result + STagB + Columns[i].Name + STagE +
                GetExportedValue(ExportRow[i]) + STagB + STagC + Columns[i].Name + STagE;
              end
            else
              Result := Result + STagB + Columns[i].Name + STagE +
                GetExportedValue(ExportRow[i]) + STagB + STagC + Columns[i].Name + STagE;
        Result := Result + STagB + STagC + GetTableName + STagE;
      end;
  end;
end;

procedure TQExport4XML.WriteDataRow;
begin
  case Options.DocumentType of
    xtDatapacket2:
        GetWriter.StartEndTagLn(SRow, GetDataRow);
    xtAccess:
        GetWriter.WriteLn(GetDataRow);
  end;
end;

function TQExport4XML.AddAccessOleWrap(ColData: String): String;
var str, strb:TStringStream;
    h:longint;
    hb:array [1..4] of byte;
    i:integer;
    ANoImage: Boolean;
const
head1=#21#28#51#0#2#0#0#0#17#0#14#0#20#0#37#0;
head2=#32#32#32#32#66#105#116#109#97#112#32#73#109#97#103#101#32#32#32#32#0#80#97#105#110#116#46#80#105#99#116#117#114#101;
head3=#0#1#5#0#0#2#0#0#0#7#0#0#0;
head4=#80#66#114#117#115#104#0#0#0#0#0#0#0#0#0;
tail1=#0#0#0#0#0#0#0#0;
tail2=#0#0#1#5#0#0#0#0#0#0#0#173#5#254;
begin
   if Options.DocumentType <> xtAccess then
   begin
     Result := ColData;
     Exit;
   end;
   ANoImage := True;
   ColData := StrToBitmapStr(ColData, ANoImage);
   if ANoImage then
   begin
     Result := ColData;
     Exit;
   end;
   str:=TStringStream.Create('');
   strb:=TStringStream.Create('');
   try
     strb.Position := 0;
     strb.WriteString(ColData);
     str.WriteString(head1);
     str.WriteString(head2);
     str.WriteString(head3);
     str.WriteString(head4);
     h:=strb.Size+26;
     for i:=1 to 4 do begin
       hb[i]:=h mod 256;
       h:=h div 256;
     end;
     str.Write(hb,4);
     strb.Seek(0,soFromBeginning);
     str.CopyFrom(strb,strb.Size);
     str.WriteString(tail1);
     str.WriteString(tail1);
     str.WriteString(tail1);
     str.WriteString(tail2);
     str.Seek(0,soFromBeginning);
     Result := str.DataString;
  finally
    strb.Free;
    str.Free;
  end;
end;




procedure TQExport4XML.AfterExport;
begin
  case Options.DocumentType of
    xtDatapacket2:
      begin
        GetWriter.EndTagLn(SRowData);
        GetWriter.WriteLn(SEndData);
      end;
    xtAccess:
      begin
        GetWriter.WriteLn(SAEndData);
      end;
  end;
  
  inherited;
end;

function TQExport4XML.GetSpecialCharacters: TSpecialCharacters;
begin
  Result := ['<', '>', '&', '"'];
end;

function TQExport4XML.GetWriter: TQXMLWriter;
begin
  Result := TQXMLWriter(inherited GetWriter);
end;

function TQExport4XML.GetWriterClass: TQExportWriterClass;
begin
  Result := TQXMLWriter;
end;

function TQExport4XML.NormalString(const S: QEString): QEString;
var
  i, p: integer;
const
  SearchSym: array [0..4] of WideString = ('&', '>', '<', '"', ' ');
  ReplSym: array [0..4] of WideString = ('&amp;', '&gt;', '&lt;', '&quot;', '&#160;');
begin
  Result := S;
  for i := 0 to Length(SearchSym) - 1 do
  begin
    p := 1;
    while p > 0 do
    begin
      p := QEPosEx(SearchSym[i], Result, p);
      if p > 0 then
      begin
        QEDelete(Result, p, 1);
        QEInsert(ReplSym[i], Result, p);
        Inc(p, 4);
      end;
    end;
  end;
end;

function TQExport4XML.NormalStringByType(Col: TQExportCol;
  const S: QEString): QEString;
var
  i, p: integer;
const
  SearchSym: array [0..4] of WideString = ('&', '>', '<', '"', ' ');
  ReplSym: array [0..4] of WideString = ('&amp;', '&gt;', '&lt;', '&quot;', '&#160;');
begin
  Result := S;
  for i := 0 to Length(SearchSym) - 1 do
  begin
    if (SearchSym[i] = ' ') and (Columns[Col.ColumnIndex].FieldType
     in [ftMemo, {$IFDEF VCL10}ftWideMemo,{$ENDIF}{$IFDEF VCL7}ftFmtMemo,{$ENDIF} ftString, ftWideString]) then
       Continue;
    p := 1;
    while p > 0 do
    begin
      p := QEPosEx(SearchSym[i], Result, p);
      if p > 0 then
      begin
        QEDelete(Result, p, 1);
        QEInsert(ReplSym[i], Result, p);
        Inc(p, 4);
      end;
    end;
  end;
end;

{mp - this code is not Unicode yet}
{because Field names aren't unicode in base}
{full correct symbols array can be found in}
{http://www.w3.org/TR/REC-xml in Part B Character Classes}
procedure TQExport4XML.FormCorrectCaptions;
var
  i: integer;
  Generator: integer;
  Temp: string;

  {common function for caption normalization}
  function NormalCaption(Name: string; Number: Integer): string;
  var
    Iter: integer;
  begin
    Result := Name;
    Iter := 1;
    while true do
    begin
      if Iter > Length(Result) then
        break;
      if not QExport4Common.CharInSet(Result[Iter], CorrectSymbols) then
      begin
        {Set modified to true - this caption could be involved}
        {into id generation processes}
        FModifiedCaption[Number] := true;
        Delete(Result, Iter, 1);
        {Check for multiple _ sequnce - if exists - then just removing}
        if Iter = 1 then
          if (Length(Result) = 0) or ((Result[Iter] <> '_')
            and QExport4Common.CharInSet(Result[Iter], CorrectSymbols)) then
          begin
            Insert('_', Result, Iter);
            Iter := Iter + 1;
            continue;
          end;
        if (Iter - 1) = Length(Result) then
          if (Length(Result) = 0) or ((Result[Iter - 1] <> '_')
            and QExport4Common.CharInSet(Result[Iter - 1], CorrectSymbols)) then
          begin
            Insert('_', Result, Iter);
            Iter := Iter + 1;
            continue;
          end;
        if (Iter > 1) and ((Iter - 1) < Length(Result))
            and (Result[Iter - 1] <> '_')
            and (Result[Iter] <> '_')
            and QExport4Common.CharInSet(Result[Iter], CorrectSymbols)
            and (QExport4Common.CharInSet(Result[Iter - 1], CorrectSymbols)) then
          begin
            Insert('_', Result, Iter);
            Iter := Iter + 1;
            continue;
          end;
        Iter := Iter - 1;
      end;
      Iter := Iter + 1;
    end;
  end;

  {Routine for searching equal names}
  function CheckInCurrentList(SearchString: string;
    CurrentNumber: integer): Boolean;
  var
    i: Integer;
  begin
    Result := false;
    for i := 0 to FCorrectNames.Count - 1 do
      if (i <> CurrentNumber) and
        (AnsiCompareStr(SearchString, FCorrectNames[i]) = 0) then
        begin
          Result := true;
          Break;
        end;
  end;

begin
  {Forming new caption array with correct xml names}
  {and forming new bool array for modified captions}
  SetLength(FModifiedCaption, Columns.Count);
  for i := 0 to Columns.Count - 1 do
  begin
    FModifiedCaption[i] := false;
    FCorrectNames.Add(NormalCaption(Columns[i].Name, i));
  end;
  {Looking for equal names in array}
  {If matches found - then generate new number}
  for i := 0 to Columns.Count - 1 do
  begin
    Generator := 1;
    if not FModifiedCaption[i] then
      continue;
    if AnsiCompareStr(FCorrectNames[i], '_') <> 0 then
      Temp := FCorrectNames[i]
    else
      Temp := SField + FCorrectNames[i] + IntToStr(Generator);
    {Routine for generating distinct names in caption rows}
    {If the string looks like '_' - it have to be changed into 'FIELD_1' etc}
    while CheckInCurrentList(Temp, i) do
    begin
      if AnsiCompareStr(FCorrectNames[i], '_') <> 0 then
        Temp := FCorrectNames[i] + IntToStr(Generator)
      else
        Temp := SField + FCorrectNames[i] + IntToStr(Generator);
      Generator := Generator + 1;
    end;
    if AnsiCompareStr(Temp, FCorrectNames[i]) <> 0 then
      FCorrectNames[i] := Temp;
  end;
end;


function PictureToBMP(AGraphic: TGraphic): String;
var
 bmp: tbitmap;
 Stream: TStringStream;
begin
  Stream := TStringStream.Create('');
  try
    Stream.Position := 0;
    bmp := tbitmap.create;
    try
      bmp.assign(AGraphic);
      Stream.Position := 0;
      bmp.SaveToStream(Stream);
    finally
      bmp.free;
    end;
  finally
   Result := Stream.DataString;
   Stream.Free;
 end;
end;


{$IFNDEF VCL6}

 function EncodeBase64(const inStr: string): string;

  function Encode_Byte(b: Byte): char;
  const
    Base64Code: string[64] =
      'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';
  begin
    Result := Base64Code[(b and $3F)+1];
  end;

var
  i: Integer;
begin
  i := 1;
  Result := '';
  while i <= Length(InStr) do
  begin
    Result := Result + Encode_Byte(Byte(inStr[i]) shr 2);
    Result := Result + Encode_Byte((Byte(inStr[i]) shl 4) or (Byte(inStr[i+1]) shr 4));
    if i+1 <= Length(inStr) then
      Result := Result + Encode_Byte((Byte(inStr[i+1]) shl 2) or (Byte(inStr[i+2]) shr 6))
    else
      Result := Result + '=';
    if i+2 <= Length(inStr) then
      Result := Result + Encode_Byte(Byte(inStr[i+2]))
    else
      Result := Result + '=';
    Inc(i, 3);
  end;
end;

// Base64 decoding
function DecodeBase64(const CinLine: string): string;
const
  RESULT_ERROR = -2;
var
  inLineIndex: Integer;
  c: Char;
  x: SmallInt;
  c4: Word;
  StoredC4: array[0..3] of SmallInt;
  InLineLength: Integer;
begin
  Result := '';
  inLineIndex := 1;
  c4 := 0;
  InLineLength := Length(CinLine);

  while inLineIndex <= InLineLength do
  begin
    while (inLineIndex <= InLineLength) and (c4 < 4) do
    begin
      c := CinLine[inLineIndex];
      case c of
        '+'     : x := 62;
        '/'     : x := 63;
        '0'..'9': x := Ord(c) - (Ord('0')-52);
        '='     : x := -1;
        'A'..'Z': x := Ord(c) - Ord('A');
        'a'..'z': x := Ord(c) - (Ord('a')-26);
      else
        x := RESULT_ERROR;
      end;
      if x <> RESULT_ERROR then
      begin
        StoredC4[c4] := x;
        Inc(c4);
      end;
      Inc(inLineIndex);
    end;

    if c4 = 4 then
    begin
      c4 := 0;
      Result := Result + Char((StoredC4[0] shl 2) or (StoredC4[1] shr 4));
      if StoredC4[2] = -1 then Exit;
      Result := Result + Char((StoredC4[1] shl 4) or (StoredC4[2] shr 2));
      if StoredC4[3] = -1 then Exit;
      Result := Result + Char((StoredC4[2] shl 6) or (StoredC4[3]));
    end;
  end;
end;

{$ENDIF}



end.
