qexport4xlsx.pas

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

      end;
  finally
    Stream.Free;
  end;

  //FTempDir + '\docProps\core.xml'
  Stream := TFileStream.Create(FTempDir + '\docProps\core.xml', fmCreate);
  try
    with TQXMLWriter.Create(Stream) do
      try
        CreateProcessingInstruction('1.0', 'UTF-8', 'yes');
        BeginNode('cp:coreProperties', '', ['xmlns:cp', 'xmlns:dc', 'xmlns:dcterms', 'xmlns:dcmitype', 'xmlns:xsi'],
          ['http://schemas.openxmlformats.org/package/2006/metadata/core-properties', 'http://purl.org/dc/elements/1.1/',
          'http://purl.org/dc/terms/', 'http://purl.org/dc/dcmitype/', 'http://www.w3.org/2001/XMLSchema-instance']);
        CreateFullNode('dc:creator', 'User', [], []);
        CreateFullNode('cp:lastModifiedBy', 'User', [], []);
        CreateFullNode('dcterms:created', '2006-10-02T04:59:59Z', ['xsi:type'], ['dcterms:W3CDTF']);
        CreateFullNode('dcterms:modified', '2006-10-02T05:00:35Z', ['xsi:type'], ['dcterms:W3CDTF']);
        EndNode('cp:coreProperties');
      finally
        Free;
      end;
  finally
    Stream.Free;
  end;

  //FTempDir + '\xl\_rels\workbook.xml.rels'
  Stream := TFileStream.Create(FTempDir + '\xl\_rels\workbook.xml.rels', fmCreate);
  try
    with TQXMLWriter.Create(Stream) do
      try
        CreateProcessingInstruction('1.0', 'UTF-8', 'yes');
        BeginNode('Relationships', '', ['xmlns'], ['http://schemas.openxmlformats.org/package/2006/relationships']);
        CreateFullNode('Relationship', '', ['Id', 'Type', 'Target'], ['rId3', 'http://schemas.openxmlformats.org/officeDocument/2006/relationships/styles', 'styles.xml']);
        CreateFullNode('Relationship', '', ['Id', 'Type', 'Target'], ['rId1', 'http://schemas.openxmlformats.org/officeDocument/2006/relationships/worksheet', 'worksheets/' + FSheetName + '.xml']);
        CreateFullNode('Relationship', '', ['Id', 'Type', 'Target'], ['rId4', 'http://schemas.openxmlformats.org/officeDocument/2006/relationships/sharedStrings', 'sharedStrings.xml']);
        EndNode('Relationships');
      finally
        Free;
      end;
  finally
    Stream.Free;
  end;

  //FTempDir + '\xl\worksheets\' + FSheetName + '.xml'
  //DO it into BeginExport procedure
  
  //FTempDir + '\xl\styles.xml'
  if Assigned(FXlsxOptions) then
    CreateStyles;

  //FTempDir + '\xl\workbook.xml'
  Stream := TFileStream.Create(FTempDir + '\xl\workbook.xml', fmCreate);
  try
    with TQXMLWriter.Create(Stream) do
      try
        CreateProcessingInstruction('1.0', 'UTF-8', 'yes');
        BeginNode('workbook', '', ['xmlns', 'xmlns:r'], ['http://schemas.openxmlformats.org/spreadsheetml/2006/main', 'http://schemas.openxmlformats.org/officeDocument/2006/relationships']);
        CreateFullNode('fileVersion ', '', ['lastEdited', 'lowestEdited', 'rupBuild'], ['4', '4', '4017']);
        CreateFullNode('workbookPr', '', ['defaultThemeVersion'], ['123820']);
        BeginNode('bookViews', '', [], []);
        CreateFullNode('workbookView', '', ['xWindow', 'yWindow', 'windowWidth', 'windowHeight'], ['120', '105', '14175', '7365']);
        EndNode('bookViews');
        BeginNode('sheets', '', [], []);
        CreateFullNode('sheet', '', ['name', 'sheetId', 'r:id'], [FSheetName, '1', 'rId1']);
        EndNode('sheets');
        CreateFullNode('calcPr', '', ['calcId'], ['122211']);
        CreateFullNode('webPublishing', '', ['codePage'], ['1251']);
        EndNode('workbook');
      finally
        Free;
      end;
  finally
    Stream.Free;
  end;

  //FTempDir + '\[Content_Types].xml'
  Stream := TFileStream.Create(FTempDir + '\[Content_Types].xml', fmCreate);
  try
    with TQXMLWriter.Create(Stream) do
      try
        CreateProcessingInstruction('1.0', 'UTF-8', 'yes');
        BeginNode('Types', '', ['xmlns'], ['http://schemas.openxmlformats.org/package/2006/content-types']);
        CreateFullNode('Override', '', ['PartName', 'ContentType'], ['/xl/theme/theme1.xml', 'application/vnd.openxmlformats-officedocument.theme+xml']);
        CreateFullNode('Override', '', ['PartName', 'ContentType'], ['/xl/styles.xml', 'application/vnd.openxmlformats-officedocument.spreadsheetml.styles+xml']);
        CreateFullNode('Default', '', ['Extension', 'ContentType'], ['rels', 'application/vnd.openxmlformats-package.relationships+xml']);
        CreateFullNode('Default', '', ['Extension', 'ContentType'], ['xml', 'application/xml']);
        CreateFullNode('Override', '', ['PartName', 'ContentType'], ['/xl/workbook.xml', 'application/vnd.openxmlformats-officedocument.spreadsheetml.sheet.main+xml']);
        CreateFullNode('Override', '', ['PartName', 'ContentType'], ['/docProps/app.xml', 'application/vnd.openxmlformats-officedocument.extended-properties+xml']);
        CreateFullNode('Override', '', ['PartName', 'ContentType'], ['/xl/worksheets/' + FSheetName + '.xml', 'application/vnd.openxmlformats-officedocument.spreadsheetml.worksheet+xml']);
        CreateFullNode('Override', '', ['PartName', 'ContentType'], ['/xl/sharedStrings.xml', 'application/vnd.openxmlformats-officedocument.spreadsheetml.sharedStrings+xml']);
        CreateFullNode('Override', '', ['PartName', 'ContentType'], ['/docProps/core.xml', 'application/vnd.openxmlformats-package.core-properties+xml']);
        EndNode('Types');
      finally
        Free;
      end;
  finally
    Stream.Free;
  end;
end;

procedure TXlsxFileMaker.CompressFile;
begin
  FZipper := TBaseArchiveClass.Create;
  try
    FZipper.FileName := ExportFileName;
    FZipper.Compress;
  finally
    FZipper.Free;
  end;
end;

procedure TXlsxFileMaker.AddCell(Col, Row, LastCol: Integer; Value: WideString;
  CellType: TQExportColType; s: Integer = -1);
begin
  with FExportWriter do
  begin
    if Col = 0 then
      BeginNode('row', '', ['r', 'spans'], [IntToStr(Row), '1:5']);

      if s > -1 then
        BeginNode('c', '', ['r', 's', 't'], [Col2Letter(Col + 1) + IntToStr(Row), IntToStr(s), 's'])
      else
        BeginNode('c', '', ['r', 't'], [Col2Letter(Col + 1) + IntToStr(Row), 's']);
      if Value <> '' then
        CreateFullNode('v', IntToStr(GetSharedString(ReplaceSymbols(Value))), [], [])
      else
        CreateFullNode('v', '', [], []);
      EndNode('c');

    if Col = LastCol then
      EndNode('row');
  end;
end;

procedure TXlsxFileMaker.PrepareExport;
begin
  //FTempDir + '\xl\worksheets\' + FSheetName + '.xml'
  FExportStream := TFileStream.Create(FTempDir + '\xl\worksheets\' + FSheetName + '.xml', fmCreate);
  FExportWriter := TQXMLWriter.Create(FExportStream);
  with FExportWriter do
  begin
    CreateProcessingInstruction('1.0', 'UTF-8', 'yes');
    BeginNode('worksheet', '', ['xmlns', 'xmlns:r'], ['http://schemas.openxmlformats.org/spreadsheetml/2006/main', 'http://schemas.openxmlformats.org/officeDocument/2006/relationships']);
    CreateFullNode('dimension', '', ['ref'], ['A1']);
    BeginNode('sheetViews', '', [], []);
    BeginNode('sheetView', '', ['tabSelected', 'workbookViewId'], ['1', '0']);
    CreateFullNode('selection', '', [], []);
    EndNode('sheetView');
    EndNode('sheetViews');
    CreateFullNode('sheetFormatPr', '', ['defaultRowHeight'], ['15']);
    BeginNode('sheetData', '', [], []);
  end;

end;

procedure TXlsxFileMaker.FinishExport;
var
  Stream: TStream;
  i: Integer;
begin
  Stream := TFileStream.Create(FTempDir + '\xl\sharedStrings.xml', fmCreate);
  try
    with TQXMLWriter.Create(Stream) do
      try
        CreateProcessingInstruction('1.0', 'UTF-8', 'yes');
        BeginNode('sst', '', ['xmlns', 'count', 'uniqueCount'], ['http://schemas.openxmlformats.org/spreadsheetml/2006/main', IntToStr(FSharedList.Count), IntToStr(FSharedList.Count)]);
        for i := 0 to FSharedList.Count - 1 do
        begin
          BeginNode('si', '', [], []);
          CreateFullNode('t', FSharedList[i], [], []);
          EndNode('si');
        end;
        EndNode('sst');
      finally
        Free;
      end;
  finally
    Stream.Free;
  end;

  //FTempDir + '\xl\worksheets\' + FSheetName +'.xml'
  with FExportWriter do
  begin
    EndNode('sheetData');
    CreateFullNode('printOptions', '', [], []);
    CreateFullNode('pageMargins', '', ['left', 'right', 'top', 'bottom', 'header', 'footer'], ['0.7', '0.7', '0.75', '0.75', '0.3', '0.3']);
    CreateFullNode('headerFooter', '', [], []);
    EndNode('worksheet');
  end;
  FExportWriter.Free;
  FExportStream.Free;
end;


procedure TXlsxFileMaker.CreateStyles;
var
  Stream: TStream;
  Writer: TQXMLWriter;
  i, n: Integer;

  function GetStyle(Styles: TFontStyles): WideString;
  begin
    Result := '';
    if fsBold in Styles then
      Result := Result + '<b/>' + CRLF;
    if fsItalic in Styles then
      Result := Result + '<i/>' + CRLF;
    if fsUnderline in Styles then
      Result := Result + '<u/>' + CRLF; 
  end;

  function GetAlignmentNode(CellAlignment: TMSCellAlignment;
    CellVerticalAligment: TMSCellVerticalAligment; WrapText: Boolean): WideString;
  begin
    Result := '<alignment ';
    if CellAlignment <> caLeft then
      Result := Result + 'horizontal="' + MSCellAlignmentToStr(CellAlignment) + '" ';
    if CellVerticalAligment <> cvaBottom then
      Result := Result + 'vertical="' + MSCellAlignmentToStr(CellVerticalAligment) + '" ';
    if WrapText then
      Result := Result + 'wrapText="1" ';
    Result := Result + '/>';
  end;

  procedure CreateBorder(Default: Boolean; Style: TXlsxBorderStyle = xbsThin; Color: TColor = clBlack);
  var
    i: Integer;
  begin
    with Writer do
      if Default then
      begin
        BeginNode('border', '', [], []);
        CreateFullNode('left', '', [], []);
        CreateFullNode('right', '', [], []);
        CreateFullNode('top', '', [], []);
        CreateFullNode('bottom', '', [], []);
        CreateFullNode('diagonal', '', [], []);
        EndNode('border');
      end else
      begin
        BeginNode('border', '', [], []);
        for i := 0 to 4 do
        begin
          case i of
            0: BeginNode('left', '', ['style'], [MSBorderStyleToStr(Style)]);
            1: BeginNode('right', '', ['style'], [MSBorderStyleToStr(Style)]);
            2: BeginNode('top', '', ['style'], [MSBorderStyleToStr(Style)]);
            3: BeginNode('bottom', '', ['style'], [MSBorderStyleToStr(Style)]);
            4: CreateFullNode('diagonal', '', [], []);
          end;
          if i < 4 then
            if Color <> clBlack then
              CreateFullNode('color', '', ['rgb'], [ColorToHex(Color)])
            else
              CreateFullNode('color', '', ['indexed'], ['64']);
          case i of
            0: EndNode('left');
            1: EndNode('right');
            2: EndNode('top');
            3: EndNode('bottom');
          end;
        end;
        EndNode('border');
      end;
  end;

begin
  //FTempDir + '\xl\styles.xml'
  Stream := TFileStream.Create(FTempDir + '\xl\styles.xml', fmCreate);
  try
    Writer := TQXMLWriter.Create(Stream);
    with Writer do
      try
        with FXlsxOptions do
        begin
          CreateProcessingInstruction('1.0', 'UTF-8', 'yes');
          BeginNode('styleSheet', '', ['xmlns'], ['http://schemas.openxmlformats.org/spreadsheetml/2006/main']);

          if (StripStylesList.Count > 0) and (StripStyleType <> ssNone) then
            BeginNode('fonts', '', ['count'], [IntToStr(5 + StripStylesList.Count)])
          else
            BeginNode('fonts', '', ['count'], ['5']);

          BeginNode('font', '', [], []); //Default
          CreateFullNode('sz', '', ['val'], ['11']);
          CreateFullNode('color', '', ['theme'], ['1']);
          CreateFullNode('name', '', ['val'], ['Calibri']);
          CreateFullNode('family', '', ['val'], ['2']);
          CreateFullNode('charset', '', ['val'], ['204']);
          CreateFullNode('scheme', '', ['val'], ['minor']);
          EndNode('font');

          for i := 1 to 4 do // 0 default
          begin
            BeginNode('font', '', [], []);
            case i of
              1:
                begin  //Header
                  Write(GetStyle(HeaderStyle.Font.Style));
                  CreateFullNode('sz', '', ['val'], [IntToStr(HeaderStyle.Font.Size)]);
                  CreateFullNode('color', '', ['rgb'], [ColorToHex(HeaderStyle.Font.Color)]);
                  CreateFullNode('name', '', ['val'], [HeaderStyle.Font.Name]);
                  CreateFullNode('charset', '', ['val'], [IntToStr(HeaderStyle.Font.Charset)]);
                end;
              2:
                begin  //CaptionRow
                  Write(GetStyle(CaptionRowStyle.Font.Style));
                  CreateFullNode('sz', '', ['val'], [IntToStr(CaptionRowStyle.Font.Size)]);
                  CreateFullNode('color', '', ['rgb'], [ColorToHex(CaptionRowStyle.Font.Color)]);
                  CreateFullNode('name', '', ['val'], [CaptionRowStyle.Font.Name]);
                  CreateFullNode('charset', '', ['val'], [IntToStr(CaptionRowStyle.Font.Charset)]);
                end;
              3:
                begin  //Data
                  Write(GetStyle(DataStyle.Font.Style));
                  CreateFullNode('sz', '', ['val'], [IntToStr(DataStyle.Font.Size)]);
                  CreateFullNode('color', '', ['rgb'], [ColorToHex(DataStyle.Font.Color)]);
                  CreateFullNode('name', '', ['val'], [DataStyle.Font.Name]);
                  CreateFullNode('charset', '', ['val'], [IntToStr(DataStyle.Font.Charset)]);
                end;
              4:
                begin  //Footer
                  Write(GetStyle(FooterStyle.Font.Style));
                  CreateFullNode('sz', '', ['val'], [IntToStr(FooterStyle.Font.Size)]);
                  CreateFullNode('color', '', ['rgb'], [ColorToHex(FooterStyle.Font.Color)]);
                  CreateFullNode('name', '', ['val'], [FooterStyle.Font.Name]);