qexport4xml.pas

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

      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;
  DocumentType := xtDatapacket2;
  FExportXSDSchema := False;
  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 FExportXSDSchema then CreateSchema;
  case FDocumentType of
    xtDatapacket2:
      GetWriter.WriteLn(SStartData);
    xtAccess:
    begin
      sAccessStart := STagB + SAStartData;
      if FExportXSDSchema 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 FDocumentType of
    xtDatapacket2:
      GetWriter.StartTagLn(SRowData, EmptyStr);
  end;
end;

function TQExport4XML.GetColCaption(Index: integer): string;
var
  FName: string;
  FDisplay: string;
begin
  case FDocumentType 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].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;

procedure TQExport4XML.WriteCaptionRow;
var
  i: integer;
begin
  case FDocumentType 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 FDocumentType 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
        begin
          if Columns.Count > i then
            Result := Result + STagB + Columns[i].Name + STagE +
              GetExportedValue(ExportRow[i]) + STagB + STagC + Columns[i].Name + STagE;
        end;
        Result := Result + STagB + STagC + GetTableName + STagE;
      end;
  end;
end;

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

procedure TQExport4XML.AfterExport;
begin
  case FDocumentType 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;

{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 (Result[Iter] in 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 (Result[Iter] in 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 (Result[Iter - 1] in 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 ((Result[Iter] in CorrectSymbols))
             and ((Result[Iter - 1] in 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;

end.