qexport3xls.pas

DELPHI开发VCL

    FGlobalsInset: integer;
    // here we store position of the result stream for writing some global
    // settings (fonts, xfs, styles, boundsheets, country, supbook,
    // externsheets, msodrawing, sst) later

    FColWidthList: TList; // for AutoCalcColWidth
    FColInfoPosition: integer; // for AutoCalcColWidth
    FRowHeightList: TStringList; //for Pictures

    FIStorage: IStorage;
    FIStream: IStream;
    FStream: TStream;
    FBuffer: PByteArray;

    procedure CreateLocalVariables;
    procedure FreeLocalVariables;

    procedure WriteGlobals;
    procedure WriteSheetStart(Sheet: TxlsSheet);
    procedure WriteSheetFinish(Sheet: TxlsSheet);
    procedure WriteGlobalInset;
    procedure WriteNotesChartsAndPictures(Sheet: TxlsSheet);
    procedure RecalculateColWidth(const Str: string; XF, ColIndex: integer);
    procedure CorrectColInfo;
    procedure CheckRowHeight(XF, RowIndex: integer);
  private
    FOptions: TXLSOptions;
    FFieldFormats: TxlsFieldFormats;
    FStripStyles: TxlsFormats;
    FStripType: TxlsStripType;
    FSheets: TxlsSheets;
    FExportStage: TxlsExportStage;
    FHeaderRows: word;
    FStartDataCol: byte;
    FFooterRows: word;
    FTotalCounter: integer;
    FHyperlinks: TxlsHyperlinks;
    FNotes: TxlsNotes;
    FCharts: TxlsCharts;
    FPictures: TxlsPictures;
    FImages: TxlsImages;
    FCells: TxlsCells;
    FMergedCells: TxlsMergedCellList;
    FBackground: TxlsGraphic;

    FOnAdvancedExportedRecord: TxlsExportedRecordEvent;
    FOnAdvancedGetExportText: TxlsGetExportTextEvent;
    FOnAdvancedBeforeExportRow: TxlsBeforeExportRowEvent;
    FOnGetHeaderParams: TGetHeaderFooterParamsEvent;
    FOnGetCaptionParams: TGetCaptionParamsEvent;
    FOnGetBeforeDataParams: TGetHeaderFooterParamsEvent;
    FOnGetDataParams: TGetDataParamsEvent;
    FOnGetAggregateParams: TGetAggregateParamsEvent;
    FOnGetFooterParams: TGetHeaderFooterParamsEvent;

    FOnBeforeExportSheet: TxlsExportSheetEvent;
    FOnAfterExportSheet: TxlsExportSheetEvent;

    procedure SetOptions(const Value: TXLSOptions);
    procedure SetFieldFormats(const Value: TxlsFieldFormats);
    procedure SetStripStyles(const Value: TxlsFormats);
    procedure SetSheets(const Value: TxlsSheets);
    procedure SetHyperlinks(const Value: TxlsHyperlinks);
    procedure SetNotes(const Value: TxlsNotes);
    procedure SetCharts(const Value: TxlsCharts);
    procedure SetPictures(const Value: TxlsPictures);
    procedure SetImages(const Value: TxlsImages);
    procedure SetCells(const Value: TxlsCells);
    procedure SetMergedCells(const Value: TxlsMergedCellList);
    procedure SetBackground(const Value: TxlsGraphic);
  private
    procedure WriteRecord(ID, Length: word);
    procedure WriteWordRecord(ID, Value: word);
    procedure WriteBOF(BOFType: word);
    procedure WriteWriteAccess;
    procedure WriteWindow1;
    procedure WriteEOF;
    procedure WriteDelta;
    procedure WriteGuts;
    procedure WriteDefColWidth(Width: word);
    procedure WriteDefRowHeight(Height: double);
    procedure WriteCatchword(ID: word; const Value: WideString);
    procedure WriteColInfo(SheetIndex: integer);
    procedure WriteLabelSST(Row, Col, XF: word; const Str: WideString);
    procedure WriteBoolErr(Row, Col, XF: word; Value: boolean);
    procedure WriteNumber(Row, Col, XF: word; Value: double);
    procedure WriteBlank(Row, Col, XF: word);
    procedure WriteAggregate(Row, Col, StartRow, FinishRow: word;
      AggregateType: TxlsAggregate; XF: word);
    procedure WriteMergedCells(MergedCells: TxlsMergedCellList);
    procedure WriteWindow2;
    procedure WriteDimensions(FirstRow, LastRow: integer; FirstCol,
      LastCol: word);
    procedure WriteSelection;
    procedure WriteHyperlink(Hyperlink: TxlsHyperlink);
    procedure WriteNoteObj(ObjectID: word);
    procedure WriteTXO(TextLength: word; NoteFormat: TxlsNoteFormat);
    procedure WriteContinue1(const NoteText: WideString);
    procedure WriteTXORUN(TextLength: word; Font: TxlsFont);
    procedure WriteChartObj(ObjectID: word);
    procedure WritePictureObj(ObjectID: word);
    procedure WriteNote(Note: TxlsNote; ObjectID: integer);
    procedure WriteXLSChart(SheetIndex: integer; Chart: TxlsChart);
    procedure WriteSetup;
    procedure WriteBackground(Background: TxlsGraphic);
    procedure WriteFBI(HeightApplied, Scale, FontIndex: word);
    procedure WriteChart;
    procedure WriteSCL;
    procedure WritePlotGrowth;
    procedure WriteFrame(AutoSize, AutoPos: boolean);
    procedure WriteLineFormat(Color: cardinal; Pattern, Weight, FormatFlags,
      ColorIndex: word);
    procedure WriteAreaFormat(FgColor, BgColor: cardinal; Pattern, FormatFlags,
      FgColorIndex, BgColorIndex: word);
    procedure WriteSeries;
    procedure WriteAI(LinkType: byte; SheetIndex: integer;
      DataRange: TxlsDataRange);
    procedure WriteSeriesText(const Str: string; const WStr: WideString;
      IsUnicode: boolean);
    procedure WriteDataFormat(Index: integer);
    procedure WriteSerToCRT;
    procedure WriteShtProps;
    procedure WriteDefaultText(ObjectID: word);
    procedure WriteText;
    procedure WritePos(IsLegend: boolean; X1, Y1, X2, Y2: cardinal);
    procedure WriteFontX(FontIndex: word);
    procedure WriteAxesUsed;
    procedure WriteAxisParent;
    procedure WriteAxis(AxisType: word);
    procedure WriteCatSerRange;
    procedure WriteAxcExt;
    procedure WriteTick;
    procedure WriteValueRange;
    procedure WriteAxisLineFormat;
    procedure WriteChartFormat(Style: TxlsChartStyle);
    procedure WriteBar(IsBar: boolean);
    procedure WriteLine;
    procedure WritePie;
    procedure WriteArea;
    procedure WriteSurface;
    procedure WriteRadar;
    procedure WriteRadarArea;
    procedure Write3d;
    procedure WriteLegend(Placement: byte);
    procedure WriteObjectLink;
    procedure WriteSIIndex(Index: word);
  protected
    function GetWriter: TQXLSWriter;
    function GetWriterClass: TQExportWriterClass; override;

    procedure DoExport;
  public
    ExtendedPalette: array[0..15] of integer;
  public
    constructor Create(AOwner: Tcomponent); override;
    destructor Destroy; override;
    procedure Notification(AComponent: TComponent;
      Operation: TOperation); override;
    //{$IFDEF OLE_STREAM}
    procedure Execute; override;
    //{$ENDIF}

    function AddBooleanCell(Col, Row: word; Value: boolean): TxlsCell;
    function AddDateTimeCell(Col, Row: word; DateTimeFormat: string;
      Value: TDateTime): TxlsCell;
    function AddNumericCell(Col, Row: word; NumericFormat: string;
      Value: double): TxlsCell;
    function AddStringCell(Col, Row: word; const Value: string): TxlsCell;
    function AddMergedCells(FirstRow, LastRow, FirstCol,
      LastCol: word): TxlsMergedCells;
    procedure DefineExtendedColor(Index: TExtendedColorIndex; Color: TColor);

    property ExportStage: TxlsExportStage read FExportStage;
    property TotalCounter: integer read FTotalCounter;
  published
    property ColumnsWidth;
    property AutoCalcColWidth default false;

    property Options: TXLSOptions read FOptions write SetOptions;

    property FieldFormats: TxlsFieldFormats read FFieldFormats
      write SetFieldFormats;
    property StripStyles: TxlsFormats read FStripStyles
      write SetStripStyles;
    property StripType: TxlsStripType read FStripType
      write FStripType default ssNone;
    property Hyperlinks: TxlsHyperlinks read FHyperlinks
      write SetHyperlinks;
    property Notes: TxlsNotes read FNotes write SetNotes;
    property Charts: TxlsCharts read FCharts write SetCharts;
    property Sheets: TxlsSheets read FSheets write SetSheets;
    property Pictures: TxlsPictures read FPictures write SetPictures;
    property Images: TxlsImages read FImages write SetImages;
    property Cells: TxlsCells read FCells write SetCells;
    property MergedCells: TxlsMergedCellList read FMergedCells
      write SetMergedCells;
    property Background: TxlsGraphic read FBackground write SetBackground;

    property HeaderRows: word read FHeaderRows write FHeaderRows default 0;
    property StartDataCol: byte read FStartDataCol
      write FStartDataCol default 0;
    property FooterRows: word read FFooterRows write FFooterRows default 0;

    property OnAdvancedExportedRecord: TxlsExportedRecordEvent
      read FOnAdvancedExportedRecord write FOnAdvancedExportedRecord;
    property OnAdvancedGetExportText: TxlsGetExportTextEvent
      read FOnAdvancedGetExportText write FOnAdvancedGetExportText;
    property OnAdvancedBeforeExportRow: TxlsBeforeExportRowEvent
      read FOnAdvancedBeforeExportRow write FOnAdvancedBeforeExportRow;

    property OnGetHeaderParams: TGetHeaderFooterParamsEvent read
      FOnGetHeaderParams write FOnGetHeaderParams;
    property OnGetCaptionParams: TGetCaptionParamsEvent read
      FOnGetCaptionParams write FOnGetCaptionParams;
    property OnGetBeforeDataParams: TGetHeaderFooterParamsEvent read
      FOnGetBeforeDataParams write FOnGetBeforeDataParams;
    property OnGetDataParams: TGetDataParamsEvent read
      FOnGetDataParams write FOnGetDataParams;
    property OnGetAggregateParams: TGetAggregateParamsEvent read
      FOnGetAggregateParams write FOnGetAggregateParams;
    property OnGetFooterParams: TGetHeaderFooterParamsEvent read
      FOnGetFooterParams write FOnGetFooterParams;

    property OnBeforeExportSheet: TxlsExportSheetEvent
      read FOnBeforeExportSheet write FOnBeforeExportSheet;
    property OnAfterExportSheet: TxlsExportSheetEvent
      read FOnAfterExportSheet write FOnAfterExportSheet;
  end;

  function XLSClr2Str(Color: TxlsColor): string;
  function Str2XLSClr(const S: string): TxlsColor;

implementation

uses QExport3Common, QExport3Types, QExport3XLSUtils, TypInfo,
  QExport3XLSConsts, Math
  {$IFDEF WIN32}, Windows, fuQExport3About, FileCtrl, QExport3StrIDs{$ENDIF}
  {$IFDEF LINUX}, VKCodes, QExport3Consts{$ENDIF};

{$IFDEF TRIAL}
{$IFDEF WIN32}
function IsIDERuning: Boolean;
begin
  Result := (FindWindow('TAppBuilder', nil) <> 0) or
            (FindWindow('TPropertyInspector', nil) <> 0) or
            (FindWindow('TAlignPalette', nil) <> 0);
end;
{$ENDIF}
{$ENDIF}

procedure CheckTrial;
begin
{$IFDEF TRIAL}
{$IFDEF WIN32}
  if not IsIDERuning then
    ShowAboutForm;
{$ENDIF}
{$ENDIF}
end;

function XLSClr2Str(Color: TxlsColor): string;
begin
  Result := ColorToString(XLS_STANDARD_PALETTE[Integer(Color)]);
end;

function Str2XLSClr(const S: string): TxlsColor;
var
  i: integer;
begin
  Result := clrBlack;
  for i := Low(XLS_STANDARD_PALETTE) to High(XLS_STANDARD_PALETTE) do
    if Integer(StringToColor(S)) = XLS_STANDARD_PALETTE[i] then begin
      Result := TxlsColor(i);
      Break;
    end;
end;

function PictureTypeByFileName(const FileName: string): TxlsPictureType;
var
  Ext: string;
begin
  Result := ptUndefined;

  Ext := ExtractFileExt(FileName);
  if Ext <> EmptyStr
    then Delete(Ext, 1, 1)
    else Exit;

  if AnsiUpperCase(Ext) = 'WMF' then
    Result := ptWMF
  else if AnsiUpperCase(Ext) = 'EMF' then
    Result := ptEMF
  else if (AnsiUpperCase(Ext) = 'JPG') or (AnsiUpperCase(Ext) = 'JPEG') then
    Result := ptJPEG
  else if (AnsiUpperCase(Ext) = 'PNG') or (AnsiUpperCase(Ext) = 'GIF') then
    Result := ptPNG
  else if AnsiUpperCase(Ext) = 'BMP' then
    Result := ptDIB;
end;

procedure SetDefaultToFont(Font: TFont);
begin
  Font .Style := [];
  Font.Color := clBlack;
  Font.CharSet := {$IFDEF WIN32}1{$ELSE}
    {$IFNDEF NOGUI}fcsAnyCharSet{$ELSE}1{$ENDIF}{$ENDIF};
  Font.Name := 'arial';
  Font.Size := 10;
end;

{ TxlsFont }

constructor TxlsFont.Create;
begin
  inherited;
  SetDefault;
end;

procedure TxlsFont.Assign(Source: TPersistent);
begin
  if Source is TxlsFont then begin
    Size := (Source as TxlsFont).Size;
    Style := (Source as TxlsFont).Style;
    Color := (Source as TxlsFont).Color;
    Script := (Source as TxlsFont).Script;
    Underline := (Source as TxlsFont).Underline;
    Charset := (Source as TxlsFont).Charset;
    Name := (Source as TxlsFont).Name;
    Exit;
  end;

  if Source is TFont then begin
    Size := (Source as TFont).Size;
    Style := [];
    Underline := fulNone;
    if fsBold in (Source as TFont).Style then Style := Style + [xfsBold];
    if fsItalic in (Source as TFont).Style then Style := Style + [xfsItalic];
    if fsStrikeOut in (Source as TFont).Style then Style := Style + [xfsStrikeOut];
    if fsUnderline in (Source as TFont).Style then Underline := fulSingle;
    case (Source as TFont).Color of
      clMaroon: Color := clrDarkRed;
      clGreen: Color := clrGreen;
      clOlive: Color := clrDarkYellow;
      clNavy: Color := clrDarkBlue;
      clPurple: Color := clrViolet;
      clTeal: Color := clrTeal;
      clGray: Color := clrGray50Percent;
      clSilver: Color := clrGray25Percent;
      clRed: Color := clrRed;
      clLime: Color := clrBrightGreen;
      clYello