frxexportxls.pas

这个是功能强大的报表软件

{******************************************}
{                                          }
{             FastReport v4.0              }
{         Excel OLE export filter          }
{                                          }
{         Copyright (c) 1998-2008          }
{          by Alexander Fediachov,         }
{             Fast Reports Inc.            }
{                                          }
{******************************************}
{               Improved by:               }
{              Serge Buzadzhy              }
{             [e-mail]             }
{              Bysoev Alexander            }
{             [e-mail]            }
{******************************************}

unit frxExportXLS;

interface

{$I frx.inc}
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Printers, ComObj, frxClass, frxProgress,
  frxExportMatrix, Clipbrd, ActiveX
{$IFDEF Delphi6}, Variants {$ENDIF};

type
  TfrxXLSExportDialog = class(TForm)
    OkB: TButton;
    CancelB: TButton;
    SaveDialog1: TSaveDialog;
    GroupPageRange: TGroupBox;
    DescrL: TLabel;
    AllRB: TRadioButton;
    CurPageRB: TRadioButton;
    PageNumbersRB: TRadioButton;
    PageNumbersE: TEdit;
    GroupQuality: TGroupBox;
    MergeCB: TCheckBox;
    WCB: TCheckBox;
    ContinuousCB: TCheckBox;
    PicturesCB: TCheckBox;
    OpenExcelCB: TCheckBox;
    AsTextCB: TCheckBox;
    BackgrCB: TCheckBox;
    FastExpCB: TCheckBox;
    PageBreaksCB: TCheckBox;
    procedure FormCreate(Sender: TObject);
    procedure PageNumbersEChange(Sender: TObject);
    procedure PageNumbersEKeyPress(Sender: TObject; var Key: Char);
    procedure FormKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
  end;

  TfrxExcel = class;

  TfrxXLSExport = class(TfrxCustomExportFilter)
  private
    FExcel: TfrxExcel;
    FExportPictures: Boolean;
    FExportStyles: Boolean;
    FFirstPage: Boolean;
    FMatrix: TfrxIEMatrix;
    FMergeCells: Boolean;
    FOpenExcelAfterExport: Boolean;
    FPageBottom: Extended;
    FPageLeft: Extended;
    FPageRight: Extended;
    FPageTop: Extended;
    FPageOrientation: TPrinterOrientation;
    FProgress: TfrxProgress;
    FWysiwyg: Boolean;
    FAsText: Boolean;
    FBackground: Boolean;
    FFastExport: Boolean;
    FpageBreaks: Boolean;
    FEmptyLines: Boolean;
    FExportEMF: Boolean;
    procedure ExportPage_Fast;
    procedure ExportPage;
    function CleanReturns(const Str: WIdeString): WideString;
    function FrameTypesToByte(Value: TfrxFrameTypes): Byte;
    function GetNewIndex(Strings: TStrings; ObjValue: Integer): Integer;
  public
    constructor Create(AOwner: TComponent); override;
    class function GetDescription: String; override;
    function ShowModal: TModalResult; override;
    function Start: Boolean; override;
    procedure Finish; override;
    procedure FinishPage(Page: TfrxReportPage; Index: Integer); override;
    procedure StartPage(Page: TfrxReportPage; Index: Integer); override;
    procedure ExportObject(Obj: TfrxComponent); override;
  published
    property ExportEMF: Boolean read FExportEMF write FExportEMF;
    property ExportStyles: Boolean read FExportStyles write FExportStyles default True;
    property ExportPictures: Boolean read FExportPictures write FExportPictures default True;
    property MergeCells: Boolean read FMergeCells write FMergeCells default True;
    property OpenExcelAfterExport: Boolean read FOpenExcelAfterExport
      write FOpenExcelAfterExport default False;
    property Wysiwyg: Boolean read FWysiwyg write FWysiwyg default True;
    property AsText: Boolean read FAsText write FAsText;
    property Background: Boolean read FBackground write FBackground;
    property FastExport: Boolean read FFastExport write FFastExport;
    property PageBreaks: Boolean read FpageBreaks write FPageBreaks;
    property EmptyLines: Boolean read FEmptyLines write FEmptyLines;
    property SuppressPageHeadersFooters;
    property OverwritePrompt;
  end;

  TfrxExcel = class(TObject)
  private
    FIsOpened: Boolean;
    FIsVisible: Boolean;
    Excel: Variant;
    WorkBook: Variant;
    WorkSheet: Variant;
    Range: Variant;
    function ByteToFrameTypes(Value: Byte): TfrxFrameTypes;
  protected
    function IntToCoord(X, Y: Integer): String;
    function Pos2Str(Pos: Integer): String;
    procedure SetVisible(DoShow: Boolean);
    procedure ApplyStyles(aRanges:TStrings; Kind:byte;aProgress: TfrxProgress);
    procedure ApplyFrame(const RangeCoord:string; aFrame:byte);
    procedure SetRowsSize(aRanges: TStrings; Sizes: array of Currency;MainSizeIndex:integer;RowsCount:integer;aProgress: TfrxProgress);
    procedure ApplyStyle(const RangeCoord: string; aStyle: integer);
    procedure ApplyFormats(aRanges: TStringlist; aProgress: TfrxProgress);
    procedure ApplyFormat(const RangeCoord, aFormat: String);
  public
    constructor Create;
    destructor Destroy; override;
    procedure MergeCells;
    procedure SetCellFrame(Frame: TfrxFrameTypes);
    procedure SetRowSize(y: Integer; Size: Extended);
    procedure OpenExcel;
    procedure SetColSize(x: Integer; Size: Extended);
    procedure SetPageMargin(Left, Right, Top, Bottom: Extended;
      Orientation: TPrinterOrientation);
    procedure SetRange(x, y, dx, dy: Integer);
    property Visible: Boolean read FIsVisible write SetVisible;
  end;


implementation

uses frxUtils, frxFileUtils, frxRes, frxUnicodeUtils, frxrcExports;

{$R *.dfm}

const
  Xdivider = 8;
  Ydivider = 1.315;
  XLMaxHeight = 409;
  XLMaxChars = 900;
  xlLeft = -4131;
  xlRight = -4152;
  xlTop = -4160;
  xlCenter = -4108 ;
  xlBottom = -4107;
  xlJustify = -4130 ;
  xlThin = 2;
  xlHairline = 1;
  xlNone = -4142;
  xlAutomatic = -4105;
  xlInsideHorizontal = 12 ;
  xlInsideVertical = 11 ;
  xlEdgeBottom = 9 ;
  xlEdgeLeft = 7 ;
  xlEdgeRight = 10 ;
  xlEdgeTop = 8 ;
  xlSolid = 1 ;
  xlLineStyleNone = -4142;
  xlTextWindows = 20 ;
  xlNormal = -4143 ;
  xlNoChange = 1 ;
  xlPageBreakManual = -4135 ;
  xlSizeYRound = 0.25;

{ TfrxXLSExport }

type
  TArrData = array [1..1] of variant;
  PArrData = ^TArrData;
  PFrameTypes = ^TfrxFrameTypes;

constructor TfrxXLSExport.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FMergeCells := True;
  FExportPictures := True;
  FExportStyles := True;
  FWysiwyg := True;
  FAsText := False;
  FBackground := True;
  FFastExport := True;
  FPageBreaks := True;
  FilterDesc := frxGet(8009);
  DefaultExt := frxGet(8010);
  FEmptyLines := True;
  FExportEMF := True;
end;

class function TfrxXLSExport.GetDescription: String;
begin
  Result := frxResources.Get('XlsOLEexport');
end;

function TfrxXLSExport.FrameTypesToByte(Value: TfrxFrameTypes): Byte;
begin
  Result := PByte(@Value)^
end;

function TfrxXLSExport.GetNewIndex(Strings: TStrings; ObjValue: Integer): Integer;
var
  L, H, I, C: Integer;
begin
  Result:=0;
  if Strings.Count > 0 then
  begin
    L := 0;
    H := Strings.Count - 1;
    while L <= H do
    begin
      I := (L + H) shr 1;
      C:= Integer(Strings.Objects[I]) - ObjValue;
      if C < 0 then
        L := I + 1
      else begin
        H := I - 1;
        if C = 0 then
        begin
          L := I;
          break;
        end;
      end;
    end;
    Result := L;
  end;
end;

function TfrxXLSExport.CleanReturns(const Str: WideString): WideString;
var
  i: Integer;
  s: WideString;
begin
  s := Str;
  i := Pos(#13, s);
  while i > 0 do
  begin
    if i > 0 then
      Delete(s, i, 1);
    i := Pos(#13, s);
  end;
  while Copy(s, Length(s), 1) = #10 do
    Delete(s, Length(s), 1);
  Result := s;
end;

{$WARNINGS OFF}
procedure TfrxXLSExport.ExportPage;
var
  i, fx, fy, x, y, dx, dy: Integer;
  dcol, drow: Extended;
  s: WideString;
  Vert, Horiz: Integer;
  ExlArray: Variant;
  obj: TfrxIEMObject;
  EStyle: TfrxIEMStyle;
  XStyle: Variant;
  Pic: TPicture;
  PicFormat: Word;
  PicData: Cardinal;
  PicPalette: HPALETTE;
  PicCount: Integer;
  PBreakCounter: Integer;

  procedure AlignFR2AlignExcel(HAlign: TfrxHAlign; VAlign: TfrxVAlign; var AlignH, AlignV: integer);
  begin
    if HAlign = haLeft then
      AlignH := xlLeft
    else if HAlign = haRight then
      AlignH := xlRight
    else if HAlign = haCenter then
      AlignH := xlCenter
    else if HAlign = haBlock then
      AlignH := xlJustify
    else
      AlignH := xlLeft;

    if VAlign = vaTop then
      AlignV := xlTop
    else if VAlign = vaBottom then
      AlignV := xlBottom
    else if VAlign = vaCenter then
      AlignV := xlCenter
    else
      AlignV := xlTop;
  end;

begin
  PicCount := 0;
  FExcel.SetPageMargin(FPageLeft, FPageRight, FPageTop, FPageBottom, FPageOrientation);

  if ShowProgress then
  begin
    FProgress := TfrxProgress.Create(self);
    FProgress.Execute(FMatrix.Height - 1, frxResources.Get('ProgressRows'), True, True);
  end;

  PBreakCounter := 0;
  for y := 1 to FMatrix.Height - 1 do
  begin
    if ShowProgress then
    begin
      if FProgress.Terminated then break;
      FProgress.Tick;
    end;
    drow := (FMatrix.GetYPosById(y) - FMatrix.GetYPosById(y - 1)) / Ydivider;
    FExcel.SetRowSize(y, drow);
    if (FMatrix.GetCellYPos(y) >= FMatrix.GetPageBreak(PBreakCounter)) and FpageBreaks then
    begin
      FExcel.WorkSheet.Rows[y + 2].PageBreak := xlPageBreakManual;
      Inc(PBreakCounter);
    end;
  end;

  if ShowProgress then
  begin
    if not FProgress.Terminated then
      FProgress.Execute(FMatrix.Width - 1, frxResources.Get('ProgressColumns'), True, True);
  end else;

  for x := 1 to FMatrix.Width - 1 do
  begin
    if ShowProgress then
    begin
      if FProgress.Terminated then break;
      FProgress.Tick;
    end;
    dcol := (FMatrix.GetXPosById(x) - FMatrix.GetXPosById(x - 1)) / Xdivider;
    FExcel.SetColSize(x, dcol);
  end;

  if ShowProgress then
    if not FProgress.Terminated then
      FProgress.Execute(FMatrix.StylesCount - 1, frxResources.Get('ProgressStyles'), True, True);

  for x := 0 to FMatrix.StylesCount - 1 do
  begin
    if ShowProgress then
    begin
      if FProgress.Terminated then break;
      FProgress.Tick;
    end;
    EStyle := FMatrix.GetStyleById(x);
    s := 'S' + IntToStr(x);
    XStyle := FExcel.Excel.ActiveWorkbook.Styles.Add(s);
    XStyle.Font.Bold := fsBold in EStyle.Font.Style;
    XStyle.Font.Italic := fsItalic in EStyle.Font.Style;
    XStyle.Font.Underline := fsUnderline in EStyle.Font.Style;;
    XStyle.Font.Name := EStyle.Font.Name;
    XStyle.Font.Size := EStyle.Font.Size;
    XStyle.Font.Color:= ColorToRGB(EStyle.Font.Color);
    XStyle.Interior.Color := ColorToRGB(EStyle.Color);
    AlignFR2AlignExcel(EStyle.HAlign, EStyle.VAlign, Horiz, Vert);
    XStyle.VerticalAlignment := Vert;
    XStyle.HorizontalAlignment := Horiz;
    Application.ProcessMessages;
  end;

  ExlArray := VarArrayCreate([0, FMatrix.Height - 1, 0, FMatrix.Width - 1], varOleStr);

  if ShowProgress then
    if not FProgress.Terminated then
      FProgress.Execute(FMatrix.Height, frxResources.Get('ProgressObjects'), True, True);

  for y := 1 to FMatrix.Height do
  begin
    if ShowProgress then
    begin
      if FProgress.Terminated then break;
      FProgress.Tick;
    end;
    for x := 1 to FMatrix.Width do
    begin
      i := FMatrix.GetCell(x - 1, y - 1);
      if i <> -1 then
      begin
        Obj := FMatrix.GetObjectById(i);
        if Obj.Counter = 0 then
        begin
          Obj.Counter := 1;
          FMatrix.GetObjectPos(i, fx, fy, dx, dy);
          FExcel.SetRange(x, y, dx, dy);
          if Obj.IsText then
          begin
            if FExportStyles then
              FExcel.Range.Style := 'S' + IntToStr(Obj.StyleIndex);
            if FMergeCells then
              if (dx > 1) or (dy > 1) then
                if (dx > 1) or (dy > 1) then
                begin
                  FExcel.SetRange(x, y, dx, dy);
                  FExcel.MergeCells;
                end;
            if FExportStyles then
              FExcel.SetCellFrame(obj.Style.FrameTyp);
            s := CleanReturns(Obj.Memo.Text);
            if Length(s) > XLMaxChars then
              s := Copy(s, 1, XLMaxChars);
            ExlArray[y - 1, x - 1] := s;
          end
          else
          if (Obj.Image <> nil) or (Obj.Metafile.Width > 0) then
          begin
            Inc(PicCount);
            if FExportEMF then
              Obj.Metafile.SaveToClipboardFormat(PicFormat, PicData, PicPalette)
            else
            begin
              Pic := TPicture.Create;
              try
                Pic.Bitmap.Assign(Obj.Image);
                Pic.SaveToClipboardFormat(PicFormat, PicData, PicPalette);
              finally
                Pic.Free;
              end;
            end;
            Clipboard.SetAsHandle(PicFormat,THandle(PicData));
            FExcel.Range.PasteSpecial(EmptyParam, EmptyParam, EmptyParam, EmptyParam);
            FExcel.WorkSheet.Pictures[PicCount].Width := Obj.Width / 1.38;
            FExcel.WorkSheet.Pictures[PicCount].Height := Obj.Height/ 1.38;
          end;
        end;
      end;
    end;
  end;

  FExcel.SetRange(1, 1, FMatrix.Width - 1, FMatrix.Height - 1);
  FExcel.Range.Value := ExlArray;
  FExcel.WorkSheet.Cells.WrapText := True;
  if ShowProgress then
    FProgress.Free;
end;
{$WARNINGS ON}

procedure TfrxXLSExport.ExportPage_Fast;
var
  i, fx, fy, x, y, dx, dy: Integer;
  dcol, drow: Extended;
  s: OLEVariant;
  Vert, Horiz: Integer;
  ExlArray: Variant;

  obj: TfrxIEMObject;
  EStyle: TfrxIEMStyle;
  XStyle: Variant;
  Pic: TPicture;
  PicFormat: Word;
  PicData: Cardinal;
  PicPalette: HPALETTE;
  PicCount: Integer;
  PBreakCounter: Integer;
  RowSizes: array of Currency;
  RowSizesCount: array of Integer;
  imc: Integer;