rm_e_xls.pas

进销存·完整的·有数据库的·非常完整·只得参考

{*****************************************}
{                                         }
{          Report Machine v2.0            }
{            XLS export filter            }
{                                         }
{*****************************************}

unit RM_e_xls;

interface

{$I RM.inc}

uses
  SysUtils, Windows, Messages, Classes, Graphics, Forms, StdCtrls, Controls,
  Dialogs, ExtCtrls, Buttons, ComCtrls, ComObj, RM_Class, RM_e_main
{$IFDEF RXGIF}, RxGIF{$ENDIF}
{$IFDEF JPEG}, JPeg{$ENDIF}
{$IFDEF Delphi6}, Variants{$ENDIF};

type
  { TRMXLSExport }
  TRMXLSExport = class(TRMMainExportFilter)
  private
    FFirstPage: Boolean;
    FExportPrecision: Integer;
    FExportPages: string;
    FExportFileName: string;
    FShowExcel: Boolean;
    FShowAfterExport: Boolean;
    FPixelFormat: TPixelFormat;
    FMultiSheet: Boolean;

    FOldAfterExport: TRMAfterExportEvent;
    FCols, FRows: TList;
    FrStart: Integer;
    FExcel: Variant;
    FWorkBook: Variant;
    FSheet: Variant;
    FKoefX, FKoefY: double;
    FpgList: TStringList;

    procedure _ClearColsAndRows;
    procedure DoAfterExport(const FileName: string);
    function SaveBitmapAs(Bmp: TBitmap; ImgFormat: TRMEFImageFormat
{$IFDEF JPEG}; JPEGQuality: TJPEGQualityRange{$ENDIF}; const BaseName: string): string;
  public
    constructor Create(AOwner: TComponent); override;
    function ShowModal: Word; override;
    procedure OnBeginDoc; override;
    procedure OnEndDoc; override;
    procedure OnBeginPage; override;
    procedure OnEndPage; override;
  published
    property ExportPages: string read FExportPages write FExportPages;
    property ExportFileName: string read FExportFileName write FExportFileName;
    property ShowExcel: Boolean read FShowExcel write FShowExcel;
    property PixelFormat: TPixelFormat read FPixelFormat write FPixelFormat default pf24bit;
    property ShowAfterExport: Boolean read FShowAfterExport write FShowAfterExport;
    property MultiSheet: Boolean read FMultiSheet write FMultiSheet;
  end;

  { TRMCSVExportForm }
  TRMXLSExportForm = class(TForm)
    btnOK: TButton;
    btnCancel: TButton;
    edtExportFileName: TEdit;
    btnFileName: TSpeedButton;
    GroupBox1: TGroupBox;
    Label1: TLabel;
    SaveDialog: TSaveDialog;
    rdbPrintAll: TRadioButton;
    rbdPrintCurPage: TRadioButton;
    rbdPrintPages: TRadioButton;
    edtPages: TEdit;
    Label2: TLabel;
    GroupBox2: TGroupBox;
    chkShowAfterGenerate: TCheckBox;
    CheckBox1: TCheckBox;
    gbExportImages: TGroupBox;
    lblExportImageFormat: TLabel;
    lblJPEGQuality: TLabel;
    cbImageFormat: TComboBox;
    edJPEGQuality: TEdit;
    UpDown1: TUpDown;
    Label4: TLabel;
    cmbPixelFormat: TComboBox;
    chkMultiSheet: TCheckBox;
    chkExportImages: TCheckBox;
    procedure FormCreate(Sender: TObject);
    procedure btnFileNameClick(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure rbdPrintPagesClick(Sender: TObject);
    procedure edtPagesEnter(Sender: TObject);
    procedure chkExportImagesClick(Sender: TObject);
    procedure cbImageFormatChange(Sender: TObject);
    procedure edJPEGQualityKeyPress(Sender: TObject; var Key: Char);
  private
    { Private declarations }
    procedure Localize;
    function GetExportPages: string;
  public
    { Public declarations }
  end;

implementation

uses Printers, Math, RM_CmpReg, RM_Const, RM_Const1, RM_Utils;

{$R *.DFM}

const
  RMExcelOLEServerName = 'Excel.Application';

  MAX_EXCEL_ROW_HEIGHT = 409;
  MAX_EXCEL_COLUMN_WIDTH = 255;

  XLS_EXPORT_LOGPIXELSX = 108;
  XLS_EXPORT_LOGPIXELSY = 108; //96;

  xlHAlignLeft = $FFFFEFDD;
  xlHAlignCenter = $FFFFEFF4;
  xlHAlignRight = $FFFFEFC8;

  xlVAlignTop = $FFFFEFC0;
  xlVAlignCenter = $FFFFEFF4;
  xlVAlignBottom = $FFFFEFF5;

  xlPortrait = $00000001;
  xlLandscape = $00000002;

  xlPaperUser = $00000100;

  xlEdgeBottom = $00000009;
  xlEdgeLeft = $00000007;
  xlEdgeRight = $0000000A;
  xlEdgeTop = $00000008;

  xlContinuous = $00000001;
  xlDash = $FFFFEFED;
  xlDashDot = $00000004;
  xlDashDotDot = $00000005;
  xlDot = $FFFFEFEA;
  xlDouble = $FFFFEFE9;
  xlSlantDashDot = $0000000D;
  xlLineStyleNone = $FFFFEFD2;

  xlHairline = $00000001;
  xlMedium = $FFFFEFD6;
  xlThick = $00000004;
  xlThin = $00000002;

  xlSolid = $00000001;

//  XLSOrientation: array[TPrinterOrientation] of cardinal = (xlPortrait, xlLandscape);

{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
{TRMXLSExport}

constructor TRMXLSExport.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  RMRegisterExportFilter(Self, RMLoadStr(SCSVFile) + ' (*.xls)', '*.xls');

  ShowDialog := True;
  FExportPrecision := 1;
  FShowExcel := True;
  FShowAfterExport := True;
  FPixelFormat := pf24bit;
end;

procedure TRMXLSExport.DoAfterExport(const FileName: string);
begin
  if FShowAfterExport then
  begin
    FWorkBook.SaveAs(FileName);
    FExcel.DisplayAlerts := True;
    if not FShowExcel then
      FExcel.Visible := True;
    FWorkBook := UnAssigned;
    FExcel := UnAssigned;
  end
  else
  begin
    FWorkBook.SaveAs(FileName);
    FWorkBook.Saved := True;
    FExcel.Quit;
    FWorkBook := UnAssigned;
    FExcel := UnAssigned;
  end;

  FSheet := UnAssigned;
  if Assigned(FOldAfterExport) then FOldAfterExport(FileName);
  OnAfterExport := FOldAfterExport;
end;

function TRMXLSExport.ShowModal: Word;
begin
  if not ShowDialog then
    Result := mrOk
  else
  begin
    with TRMXLSExportForm.Create(nil) do
    begin
      if Self.FileName <> '' then
      begin
        edtExportFileName.Text := Self.FileName;
        edtExportFileName.Enabled := False;
      end
      else
      begin
        edtExportFileName.Text := Self.ExportFileName;
        edtExportFileName.Enabled := True;
      end;
      btnFileName.Enabled := edtExportFileName.Enabled;

      CheckBox1.Checked := Self.ShowExcel;
      chkShowAfterGenerate.Checked := Self.ShowAfterExport;
      chkMultiSheet.Checked := Self.MultiSheet;

      cmbPixelFormat.ItemIndex := Integer(Self.PixelFormat);
      chkExportImages.Checked := ExportImages;
      cbImageFormat.ItemIndex := cbImageFormat.Items.IndexOfObject(TObject(Ord(ExportImageFormat)));
{$IFDEF JPEG}
      UpDown1.Position := JPEGQuality;
{$ENDIF}

      Result := ShowModal;
      if Result = mrOK then
      begin
        Self.ExportFileName := edtExportFileName.Text;
        Self.ExportPages := GetExportPages;
        Self.ShowExcel := CheckBox1.Checked;
        Self.ShowAfterExport := chkShowAfterGenerate.Checked;
        Self.MultiSheet := chkMultiSheet.Checked;

        Self.PixelFormat := TPixelFormat(cmbPixelFormat.ItemIndex);
        ExportImages := chkExportImages.Checked;
        ExportImageFormat := TRMEFImageFormat
          (cbImageFormat.Items.Objects[cbImageFormat.ItemIndex]);
{$IFDEF JPEG}
        JPEGQuality := StrToInt(edJPEGQuality.Text);
{$ENDIF}
      end;
      Free;
    end;
  end;
end;

type
  TCol = class(TObject)
  public
    Index: integer;
    X: integer;
    constructor CreateCol(_X: integer);
  end;

constructor TCol.CreateCol;
begin
  inherited Create;
  X := _X;
end;

type
  TRow = class(TObject)
  private
    Index: integer;
    Y: integer;
    PageIndex: integer;
  public
    constructor CreateRow(_Y: integer; _PageIndex: integer);
  end;

constructor TRow.CreateRow;
begin
  inherited Create;
  Y := _Y;
  PageIndex := _PageIndex;
end;

procedure TRMXLSExport._ClearColsAndRows;
begin
  while FCols.Count > 0 do
  begin
    TCol(FCols[0]).Free;
    FCols.Delete(0);
  end;
  while FRows.Count > 0 do
  begin
    TRow(FRows[0]).Free;
    FRows.Delete(0);
  end;
end;

type
  rXLSExport = record
    LeftCol: TCol;
    RightCol: TCol;
    TopRow: TRow;
    BottomRow: TRow;
  end;
  pXLSExport = ^rXLSExport;

function SortCols(Item1, Item2: pointer): integer;
begin
  Result := TCol(Item1).X - TCol(Item2).X;
end;

function SortRows(Item1, Item2: pointer): integer;
begin
  if TRow(Item1).PageIndex = TRow(Item2).PageIndex then
    Result := TRow(Item1).Y - TRow(Item2).Y
  else
    Result := TRow(Item1).PageIndex - TRow(Item2).PageIndex;
end;

procedure TRMXLSExport.OnBeginDoc;

  procedure _ParsePageNumbers; //确定需要打印的页
  var
    i, j, n1, n2: Integer;
    s: string;
    IsRange: Boolean;
  begin
    s := ExportPages;
    while Pos(' ', s) <> 0 do
      Delete(s, Pos(' ', s), 1);
    if s = '' then
      Exit;

//    if s[Length(s)] = '-' then
//      s := s + IntToStr(EMFPages.Count);
    s := s + ',';
    i := 1; j := 1; n1 := 1;
    IsRange := False;
    while i <= Length(s) do
    begin
      if s[i] = ',' then
      begin
        n2 := StrToInt(Copy(s, j, i - j));
        j := i + 1;
        if IsRange then
        begin
          while n1 <= n2 do
          begin
            FpgList.Add(IntToStr(n1));
            Inc(n1);
          end;
        end
        else
          FpgList.Add(IntToStr(n2));
        IsRange := False;
      end
      else if s[i] = '-' then
      begin
        IsRange := True;
        n1 := StrToInt(Copy(s, j, i - j));
        j := i + 1;
      end;
      Inc(i);
    end;
  end;

begin
	CurReport.Terminated := False;
  FOldAfterExport := OnAfterExport;
  OnAfterExport := DoAfterExport;
  inherited OnBeginDoc;
  FrStart := 0;
  FFirstPage := True;
  try
    FExcel := CreateOleObject(RMExcelOLEServerName);
    FExcel.Visible := ShowExcel;
    FExcel.DisplayAlerts := False;
    FWorkBook := FExcel.WorkBooks.Add;
    while FWorkBook.Sheets.Count > 1 do
      FWorkBook.Sheets[FWorkBook.Sheets.Count].Delete;
    FSheet := FWorkBook.Sheets[1];

    FpgList := TStringList.Create;
    _ParsePageNumbers;

    FCols := TList.Create;
    FRows := TList.Create;
  except
    on E: Exception do
      raise;
  end;
end;

procedure TRMXLSExport.OnEndDoc;
begin
  _ClearColsAndRows;
  FCols.Free;
  FRows.Free;
  FpgList.Free;
  inherited OnEndDoc;
end;

procedure TRMXLSExport.OnBeginPage;
begin
  inherited OnBeginPage;
end;

procedure TRMXLSExport.OnEndPage;
var
  i, k: Integer;
  liDataRec, liDataRec1: PRMEFDataRec;
	lItem: pXLSExport;
	pe: TList;
  pr, r: TRow;
  lRange: Variant;
  lFlag: Boolean;

  function _CEP(v1, v2: integer): boolean;