qexport4xlsx.pas

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

unit QExport4Xlsx;

{$I VerCtrl.inc}

interface

uses Classes, QExport4IniFiles, QExport4, BaseArchiveClass4, QExport4Types
  {$IFNDEF NOGUI}, Graphics{$ELSE}, QExport4Graphics{$ENDIF},
  ExtCtrls, QXMLWriter,
  {$IFDEF VCL10}
    WideStrings,
  {$ELSE}
    QExport4EmsWideStrings,
  {$ENDIF}
  QExport4MSOfficeCommon;

type
  TXlsxBorder = class(TPersistent)
  private
    FStyle: TXlsxBorderStyle;
    FColor: TColor;
  public
    constructor Create;
    procedure Assign(Source: TPersistent); override;
    procedure Default;
  published
    property Style: TXlsxBorderStyle read FStyle
      write FStyle default xbsThin;
    property Color: TColor read FColor write FColor
      default clBlack;
  end;

  TXlsxCellStyle = class;

  TXlsxStripStyle = class(TCollectionItem)
  private
    FOptions: TXlsxCellStyle;
    procedure SetOptions(const Value: TXlsxCellStyle);
  published
    constructor Create(Collection: TCollection); override;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    property Options: TXlsxCellStyle read FOptions
      write SetOptions;
  end;

  TXlsxStripStyleList = class(TCollection)
  protected
    function GetItem(Index: Integer): TXlsxStripStyle;
    procedure SetItem(Index: Integer; Value: TXlsxStripStyle);
  public
    function Add: TXlsxStripStyle;
    property Items[Index: Integer]: TXlsxStripStyle read GetItem
      write SetItem; default;
  end;

  TXlsxCellStyle = class(TPersistent)
  private
    FFont: TFont;
    FBorder: TXlsxBorder;
    FBackgroundColor: TColor;
    FUseBackground: boolean;
    FAlignment: TMSCellAlignment;
    FVerticalAligment: TMSCellVerticalAligment;
    FWrapText: boolean;
    FUseBorder: boolean;
    function GetIsDefault: Boolean;
    procedure SetDefault(const Value: Boolean);
    procedure SetFont(const Value: TFont);
    procedure SetBorder(const Value: TXlsxBorder);
  public
    constructor Create; 
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    
    procedure LoadFromIni(IniFile: TQIniFile; const Section: WideString);
    procedure SaveToIni(IniFile: TQIniFile; const Section: WideString);
    procedure Default; virtual;
    property IsDefault: Boolean read GetIsDefault write SetDefault;
  published
    property Font: TFont read FFont write SetFont;

    property BackgroundColor: TColor read FBackgroundColor
      write FBackgroundColor default clWhite;
    property UseBackground: boolean read FUseBackground
      write FUseBackground default False;

    property Alignment: TMSCellAlignment read FAlignment
      write FAlignment default caLeft;
    property VerticalAligment: TMSCellVerticalAligment read FVerticalAligment
      write FVerticalAligment default cvaBottom;
    property WrapText: boolean read FWrapText
      write FWrapText default False;
      
    property UseBorder: boolean read FUseBorder
      write FUseBorder default False;
    property Border: TXlsxBorder read FBorder write SetBorder;
  end;

  TQExport4XlsxOptions = class(TPersistent)
  private
    FHolder: TPersistent;
    FHeaderStyle: TXlsxCellStyle;
    FFooterStyle: TXlsxCellStyle;
    FCaptionRowStyle: TXlsxCellStyle;
    FDataStyle: TXlsxCellStyle;
    FStripStyle: TMSStripStyleType;
    FStripStylesList: TXlsxStripStyleList;
    procedure SetHeaderStyle(const Value: TXlsxCellStyle);
    procedure SetCaptionStyle(const Value: TXlsxCellStyle);
    procedure SetDataStyle(const Value: TXlsxCellStyle);
    procedure SetStripStyles(const Value: TXlsxStripStyleList);
    procedure SetFooterStyle(const Value: TXlsxCellStyle);
  public
    constructor Create(Holder: TPersistent);
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
  published
    property HeaderStyle: TXlsxCellStyle read FHeaderStyle
      write SetHeaderStyle;
    property CaptionRowStyle: TXlsxCellStyle read FCaptionRowStyle
      write SetCaptionStyle;
    property DataStyle: TXlsxCellStyle read FDataStyle
      write SetDataStyle;
    property StripStyleType: TMSStripStyleType read FStripStyle
      write FStripStyle default ssNone;
    property StripStylesList: TXlsxStripStyleList read FStripStylesList
      write SetStripStyles;
    property FooterStyle: TXlsxCellStyle read FFooterStyle
      write SetFooterStyle;
  end;

  TXlsxFileMaker = class
  private
    FSharedList: {$IFDEF QE_UNICODE}TWideStringList{$ELSE}TStrings{$ENDIF};
    FExportStream: TStream;
    FExportWriter: TQXMLWriter;
    FXlsxOptions: TQExport4XlsxOptions;

    FZipper: TBaseArchiveClass;
    FTempDir: WideString;
    FSheetName: WideString;
    FExportFileName: WideString;
    function GetSharedString(Value: WideString): Integer;
    procedure SetSheetName(const Value: WideString);
    procedure CreateStyles;
  public
    constructor Create(const ExportFile: WideString;
      ExportOptions: TQExport4XlsxOptions);
    destructor Destroy; override;

    procedure CreateDirsStructure;
    function IsExistDirsStructure: Boolean;
    procedure FillCommonData;
    procedure CompressFile;
    procedure AddCell(Col, Row, LastCol: Integer; Value: WideString;
      CellType: TQExportColType; s: Integer = -1);
    procedure PrepareExport;
    procedure FinishExport;

    property SheetName: WideString read FSheetName write SetSheetName;
    property ExportFileName: WideString read FExportFileName;
  end;

  TQExport4Xlsx = class(TQExport4FormatText)
  private
    FCounter: Integer;
    FDataRowCounter: Integer;
    FXlsxFile: TXlsxFileMaker;
    FXlsxOptions: TQExport4XlsxOptions;
    FSheetName: WideString;
    procedure SetXlsxOptions(const Value: TQExport4XlsxOptions);
    procedure SetSheetName(const Value: WideString);
  private
    procedure WriteHeader;
    procedure WriteFooter;
  protected
    procedure BeginExport; override;
    procedure BeforeExport; override;
    procedure AfterExport; override;
    procedure EndExport; override;

    procedure WriteCaptionRow; override;
    procedure WriteDataRow; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Execute; override;
  published
    property SheetName: WideString read FSheetName write SetSheetName;
    property XlsxOptions: TQExport4XlsxOptions read FXlsxOptions write SetXlsxOptions;
  end;

procedure DrawXlsxCell(PaintBox: TPaintBox; CellStyle: TXlsxCellStyle);

implementation

uses
  SysUtils{$IFDEF VCL6}, StrUtils{$ENDIF}, QExport4Common
  {$IFDEF VER130}, FileCtrl{$ENDIF};

const
  LETTERS = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ';

function Col2Letter(Col: integer): string;
var
  n, m, c: integer;
begin
  c := Col - 1;
  Result := EmptyStr;
  n := c div 26;
  m := c mod 26;
  if n > 0 then Result := Result + Copy(LETTERS, n, 1);
  Result := Result + Copy(LETTERS, m + 1, 1);
end;

procedure DrawXlsxCell(PaintBox: TPaintBox; CellStyle: TXlsxCellStyle);

  procedure FillBackground;
  begin
    if CellStyle.UseBackground then
      PaintBox.Canvas.Brush.Color := CellStyle.BackgroundColor
    else
      PaintBox.Canvas.Brush.Color := clWhite;
    PaintBox.Canvas.FillRect(Rect(0, 0, PaintBox.Width, PaintBox.Height));
  end;

const
  OutText = 'Aa Zz';
var
  X, Y: integer;
begin
  if not Assigned(CellStyle) then Exit;
  
  FillBackground;
  with PaintBox.Canvas.Font do
  begin
    Name := CellStyle.Font.Name;
    Size := CellStyle.Font.Size;
    Charset := CellStyle.Font.Charset;
    Color := CellStyle.Font.Color;
    Style := CellStyle.Font.Style;
  end;

  case CellStyle.Alignment of
    caLeft: X := 5;
    caCenter: X := (PaintBox.Width - PaintBox.Canvas.TextWidth(OutText)) div 2;
    caRight: X := PaintBox.Width - 5 - PaintBox.Canvas.TextWidth(OutText);
    else
      X := 0;
  end;

  case CellStyle.VerticalAligment of
    cvaTop: Y := 5;
    cvaMiddle: Y := (PaintBox.Height - PaintBox.Canvas.TextHeight(OutText)) div 2;
    cvaBottom: Y := PaintBox.Height - 5 - PaintBox.Canvas.TextHeight(OutText);
    else
      Y := 0;
  end;
  PaintBox.Canvas.TextOut(X, Y, OutText);
end;

{ TXlsxBorder }

constructor TXlsxBorder.Create;
begin
  Default;
end;

procedure TXlsxBorder.Assign(Source: TPersistent);
begin
  if Source is TXlsxBorder then
  begin
    Style := (Source as TXlsxBorder).Style;
    Color := (Source as TXlsxBorder).Color;
  end;
end;

procedure TXlsxBorder.Default;
begin
  FStyle := xbsThin;
  FColor := clBlack;
end;

{ TXlsxStripStyle }

procedure TXlsxStripStyle.SetOptions(const Value: TXlsxCellStyle);
begin
  FOptions.Assign(Value);
end;

constructor TXlsxStripStyle.Create(Collection: TCollection);
begin
  inherited Create(Collection);
  FOptions := TXlsxCellStyle.Create;
end;

destructor TXlsxStripStyle.Destroy;
begin
  FOptions.Free;
  inherited Destroy;
end;

procedure TXlsxStripStyle.Assign(Source: TPersistent);
begin
  FOptions.Assign(TXlsxStripStyle(Source).Options);
end;

{ TXlsxStripStyleList }

function TXlsxStripStyleList.GetItem(Index: Integer): TXlsxStripStyle;
begin
  Result := TXlsxStripStyle(inherited Items[Index]);
end;

procedure TXlsxStripStyleList.SetItem(Index: Integer;
  Value: TXlsxStripStyle);
begin
  inherited Items[Index] := Value;
end;

function TXlsxStripStyleList.Add: TXlsxStripStyle;
begin
  Result := TXlsxStripStyle(inherited Add)
end;

{ TXlsxCellStyle }