froleexl.pas

不错的报表工具

{******************************************}
{                                          }
{             FastReport v2.5              }
{         Excel OLE export filter          }
{                                          }
{Copyright(c) 1998-2003 by FastReports Inc.}
{                                          }
{******************************************}

unit frOLEExl;

interface

{$I Fr.inc}

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, extctrls, Clipbrd, Printers, ComObj, FR_Class
{$IFDEF Delphi6}
, Variants
{$ENDIF},
  FR_Progr, FR_Ctrls;

function ComparePoints(Item1, Item2: Pointer): Integer;
function CompareObjects(Item1, Item2: Pointer): Integer;

const
  Xdivider = 8;
  Ydivider = 1.3;
  XLMaxHeight = 409;

  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 ;
  xlTextWindows = 20 ;
  xlNormal = -4143 ;
  xlNoChange = 1 ;
  xlPageBreakManual = -4135 ;

type

TfrOLEExcelSet = class(TForm)
  OK: TButton;
  Cancel: TButton;
    GroupPageSettings: TGroupBox;
    GroupPageRange: TGroupBox;
    LeftM: TLabel;
    Pages: TLabel;
    E_Range: TEdit;
    Descr: TLabel;
    E_LMargin: TEdit;
    TopM: TLabel;
    E_TMargin: TEdit;
    ScX: TLabel;
    E_ScaleX: TEdit;
    Label2: TLabel;
    ScY: TLabel;
    E_ScaleY: TEdit;
    Label9: TLabel;
    GroupCellProp: TGroupBox;
    CB_Merged: TCheckBox;
    CB_Align: TCheckBox;
    CB_FillColor: TCheckBox;
    CB_Borders: TCheckBox;
    CB_WrapWords: TCheckBox;
    CB_FontName: TCheckBox;
    CB_FontSize: TCheckBox;
    CB_FontStyle: TCheckBox;
    CB_FontColor: TCheckBox;
    CB_PageBreaks: TCheckBox;
    CB_OpenExcel: TCheckBox;
    Better: TButton;
    Faster: TButton;
    CB_Pictures: TCheckBox;
    procedure BetterClick(Sender: TObject);
    procedure FasterClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
 private
    procedure Localize;
end;

TFrExcel = class;

TObjCell = class(TObject)
public
  Value: integer;
end;

TObjPos = class(TObject)
public
  obj: integer;
  x,y: integer;
  dx, dy: integer;
end;

TfrOLEExcelExport = class(TfrExportFilter)
  private
    CurrentPage: integer;
    FirstPage: boolean;
    CurY: integer;
    RX: TList; // TObjCell
    RY: TList; // TObjCell
    ObjectPos: TList; // TObjPos
    PageObj: TList; // TfrView
    Excel: TFrExcel;
    CY, LastY: integer;
    frExportSet: TfrOLEExcelSet;
    pgList: TStringList;
    pgBreakList: TStringList;
    PicFormat: Word;
    PicData: Cardinal;
    PicPalette: HPALETTE;
    CntPics: integer;
    expMerged, expWrapWords, expFillColor, expBorders, expAlign,
      expPageBreaks, expFontName, expFontSize, expFontStyle,
      expFontColor, expPictures, expOpenAfter: boolean;
    expScaleX, expScaleY, expTopMargin, expLeftMargin: Double;
    procedure ObjCellAdd(Vector: TList; Value: integer);
    procedure ObjPosAdd(Vector: TList; x, y, dx, dy, obj: integer);
    procedure DeleteMultiplePoint(Vector: TList);
    procedure ClearLastPage;
    procedure OrderObjectByCells;
    procedure ExportPage;
    function CleanReturns(Str: string): string;
    procedure AfterExport(const FileName: string);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function ShowModal: Word; override;
    procedure OnBeginDoc; override;
    procedure OnEndDoc; override;
    procedure OnEndPage; override;
    procedure OnBeginPage; override;
    procedure OnData(x, y: Integer; View: TfrView); override;
  published
//    property ScaleX : Double read expScaleX write expScaleX default 1.0;
//    property ScaleY : Double read expScaleY write expScaleY default 1.0;
    property CellsAlign : Boolean read expAlign write expAlign default True;
    property CellsBorders : Boolean read expBorders write expBorders default True;
    property CellsFillColor : Boolean read expFillColor write expFillColor default True;
    property CellsFontColor : Boolean read expFontColor write expFontColor default True;
    property CellsFontName : Boolean read expFontName write expFontName default True;
    property CellsFontSize : Boolean read expFontSize write expFontSize default True;
    property CellsFontStyle : Boolean read expFontStyle write expFontStyle default True;
    property CellsMerged : Boolean read expMerged write expMerged default True;
    property CellsWrapWords : Boolean read expWrapWords write expWrapWords default True;
    property ExportPictures : Boolean read expPictures write expPictures default True;
    property LeftMargin : Double read expLeftMargin write expLeftMargin;
    property OpenExcelAfterExport : Boolean read expOpenAfter write expOpenAfter default False;
    property PageBreaks : Boolean read expPageBreaks write expPageBreaks default True;
    property TopMargin : Double read expTopMargin write expTopMargin;
end;

TFrExcel = class(TComponent)
private
  IsOpened: Boolean;
  IsVisible: Boolean;
  Excel: Variant;
  WorkBook: Variant;
  WorkSheet: Variant;
  Range : Variant;
protected
  procedure SetVisible(DoShow: Boolean);
  function GetCell(x, y: Integer): string;
  procedure SetCell(x, y: Integer; const Value: string);
  function Pos2Str(Pos: Integer): string;
  function IntToCoord(X, Y: Integer): string;
public
  constructor Create (AOwner: TComponent); override;
  destructor Destroy; override;
  procedure OpenExcel;
  procedure SetRange(x, y, dx, dy: integer);
  procedure SetColSize(x: integer; Size: Extended);
  procedure SetRowSize(y: integer; Size: Extended);
  procedure MergeCells;
  procedure SetPageMargin(Left, Right, Top, Bottom: Extended; Orient: integer);
  procedure SetCellFontName(FontName: string);
  procedure SetCellFontSize(FontSize: integer);
  procedure SetCellFontColor(FontColor: Integer);
  procedure SetCellFontStyle(Style: TFontStyles);
  procedure SetCellHAlign(Horiz: Integer);
  procedure SetCellVAlign(Vert: Integer);
  procedure SetCellOrientation(Grad: Integer);
  procedure SetCellFrame(Frame: integer);
  procedure SetCellFrameInsideV;
  procedure SetCellFrameInsideH;
  procedure SetCellFillColor(Color: integer);
  procedure SendArrayValue(Arr: variant);
  property Cell[x, y: Integer]: string read GetCell write SetCell;
  function IsOpen: Boolean;
published
  property Visible: Boolean read IsVisible write SetVisible;
end;

implementation

uses FR_Const, FR_Utils;

{$R *.dfm}

function ComparePoints(Item1, Item2: Pointer): Integer;
begin
  Result := TObjCell(Item1).Value - TObjCell(Item2).Value;
end;

function CompareObjects(Item1, Item2: Pointer): Integer;
var
  r: integer;
begin
  r := TfrView(Item1).y - TfrView(Item2).y;
  if r = 0 then
    r := TfrView(Item1).x - TfrView(Item2).x;
  if r = 0 then
    r :=Length(TfrView(Item1).Memo.Text) - Length(TfrView(Item2).Memo.Text);
  Result := r;
end;

constructor TfrOLEExcelExport.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  frRegisterExportFilter(Self, frLoadStr(frRes + 1840), '*.xls');
  RX := TList.Create;
  RY := TList.Create;
  PageObj := TList.Create;
  ObjectPos := TList.Create;
  Excel := TfrExcel.Create(nil);
  pgList := TStringList.Create;
  pgBreakList := TStringList.Create;
  ShowDialog := True;
  expMerged := True;
  expWrapWords := True;
  expFillColor := True;
  expBorders := True;
  expAlign := True;
  expPageBreaks := True;
  expFontName := True;
  expFontSize := True;
  expFontStyle := True;
  expFontColor := True;
  expPictures := True;
  expScaleX := 1.0;
  expScaleY := 1.0;
end;

destructor TfrOLEExcelExport.Destroy;
begin
  ClearLastPage;
  frUnRegisterExportFilter(Self);
  RX.Destroy;
  RY.Destroy;
  PageObj.Destroy;
  ObjectPos.Destroy;
  Excel.Destroy;
  pgList.Destroy;
  pgBreakList.Destroy;
  inherited;
end;

function TfrOLEExcelExport.CleanReturns(Str: string): string;
var
  i: integer;
begin
   i := Pos(#13, Str);
   while i > 0 do
   begin
      if i > 0 then Delete(Str, i, 1);
      i := Pos(#13, Str);
   end;
   i := Pos(#1, Str);
   while i > 0 do
   begin
      if i > 0 then Delete(Str, i, 1);
      i := Pos(#1, Str);
   end;
   while Copy(Str, Length(str), 1) = #10 do
      Delete(Str, Length(Str), 1);
   Result := Str;
end;

procedure TfrOLEExcelExport.ClearLastPage;
var
  i: integer;
begin
  for i := 0 to RX.Count - 1 do TObjCell(RX[i]).Free;
  RX.Clear;
  for i := 0 to RY.Count - 1 do TObjCell(RY[i]).Free;
  RY.Clear;
  for i := 0 to PageObj.Count - 1 do
  begin
    if TfrView(PageObj[i]) is TfrMemoView then
      TfrMemoView(PageObj[i]).Destroy
    else
    if TfrView(PageObj[i]) is TfrPictureView then
      TfrPictureView(PageObj[i]).Destroy;
  end;
  PageObj.Clear;
  for i := 0 to ObjectPos.Count - 1 do TObjPos(ObjectPos[i]).Free;
  ObjectPos.Clear;
end;

procedure TfrOLEExcelExport.ObjCellAdd(Vector: TList; Value: integer);
var
   ObjCell: TObjCell;
begin
   ObjCell := TObjCell.Create;
   ObjCell.Value := Value;
   Vector.Add(ObjCell);
end;

procedure TfrOLEExcelExport.ObjPosAdd(Vector: TList; x, y, dx, dy, obj: integer);
var
    ObjPos: TObjPos;
begin
   ObjPos := TObjPos.Create;
   ObjPos.x := x;
   ObjPos.y := y;
   ObjPos.dx := dx;
   ObjPos.dy := dy;
   ObjPos.obj := Obj;
   Vector.Add(ObjPos);
end;

procedure TfrOLEExcelExport.DeleteMultiplePoint(Vector: TList);
var
  i: integer;
  point, lpoint: TObjCell;
begin
   if Vector.Count > 0 then
   begin
    i := 0;
    lpoint := TObjCell(Vector[i]);
    inc(i);
    while i <= Vector.Count - 1 do
    begin
      point := TObjCell(Vector[i]);
      if (point.Value = lpoint.Value) then
      begin
        point.Free;
        Vector.Delete(i);
      end
      else
      begin
        lpoint := point;
        inc(i);
      end;
    end;
   end;
end;

procedure TfrOLEExcelExport.OrderObjectByCells;
var
   obj, c, fx, fy, dx, dy, m, mi, curx, cury: integer;
begin
   for obj := 0 to PageObj.Count - 1 do
   begin
     fx := 0; fy := 0;
     dx := 1; dy := 1;
     for c := 0 to RX.Count - 1 do
       if TObjCell(RX[c]).Value = TfrView(PageObj[obj]).x then
       begin
          fx := c;
          m := TfrView(PageObj[obj]).x;
          mi := c + 1;
          curx :=TfrView(PageObj[obj]).x + (TfrView(PageObj[obj]).dx - 10); //TfrView(PageObj[obj]).dx div 10
          while m < curx do
          begin
            m := m + TObjCell(RX[mi]).Value - TObjCell(RX[mi - 1]).Value;
            inc(mi);
          end;
          dx := mi - c - 1;
          break;
       end;
     for c := 0 to RY.Count - 1 do
       if TObjCell(RY[c]).Value = TfrView(PageObj[obj]).y then
       begin
          fy := c;
          m := TfrView(PageObj[obj]).y;
          mi := c + 1;
          cury := TfrView(PageObj[obj]).y + (TfrView(PageObj[obj]).dy - 10); //TfrView(PageObj[obj]).dy div 10
          while m < cury do
          begin
            m := m + TObjCell(RY[mi]).Value - TObjCell(RY[mi - 1]).Value;
            inc(mi);