rm_e_xls1.pas

来自「胜天进销存源码,国产优秀的进销存」· PAS 代码 · 共 647 行 · 第 1/2 页

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

unit RM_e_xls1;

interface

{$I RM.inc}

uses
  SysUtils, Windows, Messages, Classes, Graphics, Forms, StdCtrls, Controls,
  Dialogs, ExtCtrls, Buttons, ComCtrls, ComObj, ShellApi,
  RM_Common, RM_Class, RM_e_main,
  XLSReadWriteII, BIFFRecsII //szc
{$IFDEF RXGIF}, JvGIF{$ENDIF}
{$IFDEF JPEG}, JPeg{$ENDIF}
{$IFDEF Delphi6}, Variants{$ENDIF};

type
  RMEXCELCELL = ^TRMEXCELCELL;
  TRMEXCELCELL = record
    row: integer;
    col: integer;
    fdatalistindex: integer;
    rowindex: integer;
    colindex: integer;
  end;

  { TRMXlsExport1 }
  TRMXlsExport1 = class(TRMMainExportFilter)
  private
    FExportPages: string;
    FExportFileName: string;
    Fsheet: tlist;
    FCols, FRows: TList;
    Fpagemaxrowindex: array of integer;
    FShowAfterExport: Boolean;
    FMultiSheet: Boolean;

    FOldAfterExport: TRMAfterExportEvent;
    FExcel: txlsreadwriteii;

    procedure DoAfterExport(const aFileName: string);
  protected
    procedure InternalOnePage(aPage: TRMEndPage); override;
  public
    constructor Create(AOwner: TComponent); override;
    function ShowModal: Word; override;
    procedure OnBeginDoc; override;
    procedure OnEndDoc; override;
    procedure OnBeginPage; override;
  published
    property ExportPages: string read FExportPages write FExportPages;
    property ExportFileName: string read FExportFileName write FExportFileName;
    property MultiSheet: Boolean read FMultiSheet write FMultiSheet;
    property ShowAfterExport: Boolean read FShowAfterExport write FShowAfterExport;
    property PixelFormat;
  end;

  { TRMCSVExportForm }
  TRMXLSExport1Form = 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;
    gbExportImages: TGroupBox;
    lblExportImageFormat: TLabel;
    lblJPEGQuality: TLabel;
    cmbImageFormat: TComboBox;
    edJPEGQuality: TEdit;
    UpDown1: TUpDown;
    Label4: TLabel;
    cmbPixelFormat: TComboBox;
    GroupBox2: TGroupBox;
    chkShowAfterGenerate: TCheckBox;
    chkMultiSheet: TCheckBox;
    chkExportFrames: 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 cmbImageFormatChange(Sender: TObject);
    procedure edJPEGQualityKeyPress(Sender: TObject; var Key: Char);
  private
    { Private declarations }
    procedure Localize;
    function GetExportPages: string;
  public
    { Public declarations }
  end;

implementation

uses Math, RM_Const, RM_Const1, RM_Utils;

{$R *.DFM}

const
  XLSscalewidth = 35;
  XLSscaleheight = 13;

{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
{ TRMXlsExport1 }

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

  ShowDialog := True;
  CreateFile := False;
  ExportImages := True;
  ExportFrames := True;
  MultiSheet := True; //waw 03-07-26
  FShowAfterExport := True;
  FExportImageFormat := ifBMP;
  FIsXLSExport := True;
end;

function TRMXlsExport1.ShowModal: Word;
begin
  if not ShowDialog then
    Result := mrOk
  else
  begin
    with TRMXLSExport1Form.Create(nil) do
    begin
      edtExportFileName.Text := Self.FileName;
      btnFileName.Enabled := edtExportFileName.Enabled;

      chkExportFrames.Checked := ExportFrames;
      chkShowAfterGenerate.Checked := Self.ShowAfterExport;
      chkMultiSheet.Checked := Self.MultiSheet;

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

      Result := ShowModal;
      if Result = mrOK then
      begin
        Self.FileName := edtExportFileName.Text;
        Self.ExportFrames := chkExportFrames.Checked;
        Self.ExportPages := GetExportPages;
        Self.ShowAfterExport := chkShowAfterGenerate.Checked;
        Self.MultiSheet := chkMultiSheet.Checked;

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

procedure TRMXlsExport1.OnBeginDoc;
begin
  FOldAfterExport := OnAfterExport;
  OnAfterExport := DoAfterExport;

  FCols := TList.Create;
  FRows := TList.Create;
  Fsheet := TList.Create;

  FExcel := txlsreadwriteii.Create(nil);
  SetLength(Fpagemaxrowindex, pagecount);

  inherited OnBeginDoc;
end;

procedure TRMXlsExport1.OnEndDoc;
begin
  FCols.free;
  FRows.free;
  Fsheet.free;
  inherited OnEndDoc;
end;

procedure TRMXlsExport1.DoAfterExport(const aFileName: string);
begin
  try
    FExcel.Filename := aFileName;
    FExcel.Write;
  finally
    FExcel.Free;
    if FShowAfterExport then //by waw
      ShellExecute(0, 'open', PChar(FileName), '', '', SW_SHOWNORMAL);

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

procedure TRMXlsExport1.OnBeginPage;
begin
  inherited OnBeginPage;
end;

procedure TRMXlsExport1.InternalOnePage(aPage: TRMEndPage); ///主力程序
var
  lDataRec, lDataRec1: TRMEFDataRec;
  i, x, y, li_col, li_row, index: integer;
  ECELL1, ECELL2, ECELL3: RMEXCELCELL;
  fpicture: tpicture;

  function getrowcount: integer;
  var
    i: integer;
  begin
    result := 0;
    for i := 1 to FPageNo do begin
      result := result + Fpagemaxrowindex[i - 1];
    end;
    if FPageNo <> 0 then
      result := result + 1
  end;

{  procedure setrowcol(lDataRec: TRMEFDataRec; i: integer; ECELL: RMEXCELCELL);
  begin

  end;
}
  procedure sortcol(fcols: tlist; FExcel: txlsreadwriteii);
  var
    i, i2, index: integer;
  begin
    x := 0;
    for i := 0 to fcols.Count - 1 do begin
      x := RMEXCELCELL(fcols.Items[i]).col;
      index := -1;
      for i2 := i + 1 to fcols.count - 1 do begin
        if x > RMEXCELCELL(fcols.Items[i2]).col then begin
          x := RMEXCELCELL(fcols.Items[i2]).col;
          index := i2;
        end;
      end;
      if index <> -1 then begin
        fcols.Exchange(i, index);
      end;
      if i = 0 then begin
        RMEXCELCELL(fcols.Items[i]).colindex := 0;
      end else begin
        if RMEXCELCELL(fcols.Items[i]).col = RMEXCELCELL(fcols.Items[i - 1]).col then begin
          RMEXCELCELL(fcols.Items[i]).colindex := RMEXCELCELL(fcols.Items[i - 1]).colindex;
        end else begin
          RMEXCELCELL(fcols.Items[i]).colindex := RMEXCELCELL(fcols.Items[i - 1]).colindex + 1;
        end;
      end;
        ///设置列宽
      with FExcel.Sheets[0].ColumnFormats.add do
      begin
        col1 := RMEXCELCELL(fcols.Items[i]).colindex;
        col2 := RMEXCELCELL(fcols.Items[i]).colindex;
//        width := TRMEFDataRec(fdatalist.Items[RMEXCELCELL(fcols.Items[i]).fdatalistindex]).dx * XLSscalewidth;
      end;
    end;
  end;

  procedure sortrow(frows: tlist; FExcel: txlsreadwriteii);
  var
    i, i2, index: integer;
  begin
    x := 0;
    for i := 0 to frows.Count - 1 do
    begin
      x := RMEXCELCELL(frows.Items[i]).row;
      index := -1;
      for i2 := i + 1 to frows.count - 1 do
      begin
        if x > RMEXCELCELL(frows.Items[i2]).row then
        begin
          x := RMEXCELCELL(frows.Items[i2]).row;
          index := i2;
        end;
      end;

      if index <> -1 then
        frows.Exchange(i, index);
      if i = 0 then
      begin
        RMEXCELCELL(frows.Items[i]).rowindex := 0;
      end
      else
      begin
        if RMEXCELCELL(frows.Items[i]).row = RMEXCELCELL(frows.Items[i - 1]).row then
        begin
          RMEXCELCELL(frows.Items[i]).rowindex := RMEXCELCELL(frows.Items[i - 1]).rowindex;
        end
        else
        begin
          RMEXCELCELL(frows.Items[i]).rowindex := RMEXCELCELL(frows.Items[i - 1]).rowindex + 1;
        end;
      end;
        ///设置行高
      if FPageNo = 0 then