qexport4xml.pas

Advanced.Export.Component.v4.01.rar,delphi 第三方控件

unit QExport4XML;

{$I VerCtrl.inc}

interface

uses QExport4, Classes, 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;
  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;
  end;

  TQExport4XML = class(TQExport4Text)
  private
    FOptions: TXMLOptions;
    FDocumentType: TQExportXMLType;
    FExportXSDSchema: Boolean;
    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 NormalString(const S: QEString): QEString; override;
  published
    property Options: TXMLOptions read FOptions write SetOptions;
    property Captions;
    property Formats;
    property UserFormats;
    property DocumentType: TQExportXMLType read FDocumentType
      write FDocumentType default xtDatapacket2;
    property ExportXSDSchema: Boolean read FExportXSDSchema
      write FExportXSDSchema default False;
  end;

implementation

uses
  SysUtils, {$IFDEF VCL6}StrUtils,{$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 = '>';
  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>';

  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', '-', '_', '.', ':'];

  
{$IFDEF VCL3}

{mp - this routine is defined in WideStrUtils}
{When the meta gonna be changed for unicode captions, this code could be cut}
{and all calls could be changed for QEReplaceString routine}
type
  TReplaceFlags = set of (rfReplaceAll, rfIgnoreCase);

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;
  NewStr := S;
  Result := '';
  while SearchStr <> '' do
  begin
    Offset := AnsiPos(Patt, SearchStr);
    if Offset = 0 then
    begin
      Result := Result + NewStr;
      Break;
    end;
    Result := Result + Copy(NewStr, 1, Offset - 1) + NewPattern;
    NewStr := Copy(NewStr, Offset + Length(OldPattern), MaxInt);
    if not (rfReplaceAll in Flags) then
    begin
      Result := Result + NewStr;
      Break;
    end;
    SearchStr := Copy(SearchStr, Offset + Length(Patt), MaxInt);
  end;
end;
{$ENDIF}

{ 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;
    Exit;
  end;
  inherited;
end;

constructor TXMLOptions.Create;
begin
  inherited;
  FStandAlone := true;
  FVersion := '1.0';
  FEncoding := EmptyStr;
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;

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:
        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="text" od:sqlSType="nvarchar"';
    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;

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

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