frxexporttxt.pas

报表源码 FastReport 3 is new generation of the report generators components. It consists of report engin

{******************************************}
{                                          }
{             FastReport v3.0              }
{        Text advanced  export filter      }
{                                          }
{         Copyright (c) 1998-2005          }
{          by Alexander Fediachov,         }
{             Fast Reports Inc.            }
{                                          }
{******************************************}

unit frxExportTXT;

interface

{$I frx.inc}

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ExtCtrls, frxClass, frxProgress, Buttons, ComCtrls, Registry
{$IFDEF Delphi6}
, Variants
{$ENDIF};

type
  TfrxTXTExport = class;

  TfrxTXTExportDialog = class(TForm)
    OK: TButton;
    Cancel: TButton;
    Panel1: TPanel;
    GroupCellProp: TGroupBox;
    GroupPageRange: TGroupBox;
    Pages: TLabel;
    Descr: TLabel;
    E_Range: TEdit;
    GroupScaleSettings: TGroupBox;
    ScX: TLabel;
    Label2: TLabel;
    ScY: TLabel;
    Label9: TLabel;
    E_ScaleX: TEdit;
    CB_PageBreaks: TCheckBox;
    GroupFramesSettings: TGroupBox;
    RB_NoneFrames: TRadioButton;
    RB_Simple: TRadioButton;
    RB_Graph: TRadioButton;
    CB_OEM: TCheckBox;
    CB_EmptyLines: TCheckBox;
    CB_LeadSpaces: TCheckBox;
    CB_PrintAfter: TCheckBox;
    CB_Save: TCheckBox;
    Panel2: TPanel;
    GroupBox1: TGroupBox;
    Label1: TLabel;
    Label3: TLabel;
    PgHeight: TLabel;
    PgWidth: TLabel;
    Preview: TMemo;
    EPage: TEdit;
    PageUpDown: TUpDown;
    LBPage: TLabel;
    ToolButton1: TSpeedButton;
    ToolButton2: TSpeedButton;
    BtnPreview: TSpeedButton;
    SaveDialog1: TSaveDialog;
    UpDown1: TUpDown;
    UpDown2: TUpDown;
    E_ScaleY: TEdit;
    procedure FormCreate(Sender: TObject);
    procedure CB_OEMClick(Sender: TObject);
    procedure RefreshClick(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure FormActivate(Sender: TObject);
    procedure E_ScaleXChange(Sender: TObject);
    procedure BtnPreviewClick(Sender: TObject);
    procedure ToolButton1Click(Sender: TObject);
    procedure ToolButton2Click(Sender: TObject);
    procedure UpDown1Changing(Sender: TObject; var AllowChange: Boolean);
  private
    TxtExp: TfrxTXTExport;
    Flag, created, MakeInit, running: Boolean;
    printer: Integer;
  public
    PagesCount: Integer;
    Exporter: TfrxTXTExport;
    PreviewActive: Boolean;
  end;

  PfrxTXTStyle = ^TfrxTXTStyle;
  TfrxTXTStyle = packed record
    Font: TFont;
    VAlignment: TfrxVAlign;
    HAlignment: TfrxHAlign;
    FrameTyp: TfrxFrameTypes;
    FrameWidth: Single;
    FrameColor: TColor;
    FrameStyle: TfrxFrameStyle;
    FillColor: TColor;
    IsText: Boolean;
  end;

  TfrxTXTPrinterCommand = packed record
    Name: String;
    SwitchOn: String;
    SwitchOff: String;
    Trigger: Boolean;
  end;

  TfrxTXTPrinterType = packed record
    name: String;
    CommCount: Integer;
    Commands: array[0..31] of TfrxTXTPrinterCommand;
  end;

  TfrxTXTExport = class(TfrxCustomExportFilter)
  private
    CurrentPage: Integer;
    FirstPage: Boolean;
    CurY: Integer;
    RX: TList; // TObjCell
    RY: TList; // TObjCell
    ObjectPos: TList; // TObjPos
    PageObj: TList; // TfrxView
    StyleList: TList;
    CY, LastY: Extended;
    frExportSet: TfrxTXTExportDialog;
    pgBreakList: TStringList;
    expBorders, expBordersGraph, expPrintAfter, expUseSavedProps,
      expPrinterDialog, expPageBreaks, expOEM, expEmptyLines,
      expLeadSpaces, expShowProgress: Boolean;
    expCustomFrameSet: String;
    expScaleX, expScaleY: Extended;
    MaxWidth: Extended;
    Scr: array of Char;
    ScrWidth: Integer;
    ScrHeight: Integer;
    PrinterInitString: String;
    Stream: TFileStream;
    procedure WriteExpLn(const str: String);
    procedure WriteExp(const str: String);
    procedure ObjCellAdd(Vector: TList; Value: Extended);
    procedure ObjPosAdd(Vector: TList; x, y, dx, dy, obj: Integer);
    function CompareStyles(Style1, Style2: PfrxTXTStyle): Boolean;
    function FindStyle(Style: PfrxTXTStyle): Integer;
    procedure MakeStyleList;
    procedure ClearLastPage;
    procedure OrderObjectByCells;
    procedure ExportPage;
    function ChangeReturns(const Str: String): String;
    function TruncReturns(const Str: String): String;
    procedure AfterExport(const FileName: String);
    procedure PrepareExportPage;
    procedure DrawMemo(x, y: Integer; dx, dy: Integer; text: String; st: Integer);
    procedure FlushScr;
    procedure CreateScr(dx, dy: Integer);
    procedure FreeScr;
    procedure ScrType(x, y: Integer; c: Char);
    function ScrGet(x, y: Integer): Char;
    procedure ScrString(x, y: Integer; const s: String);
    procedure FormFeed;
    function MakeInitString: String;
  public
    PrintersCount: Integer;
    PrinterTypes: array [0..15] of TfrxTXTPrinterType;
    SelectedPrinterType: Integer;
    PageWidth, PageHeight: Integer;
    IsPreview: Boolean;
    Copys: Integer;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; 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;
    class function GetDescription: String; override;
    function RegisterPrinterType(const Name: String):Integer;
    procedure RegisterPrinterCommand(PrinterIndex: Integer;
      const Name, switch_on, switch_off: String);
    procedure LoadPrinterInit(const FName: String);
    procedure SavePrinterInit(const FName: String);
    procedure SpoolFile(const FileName: String);
  published
    property ScaleWidth: Extended read expScaleX write expScaleX;
    property ScaleHeight: Extended read expScaleY write expScaleY;
    property Borders: Boolean read expBorders write expBorders;
    property Pseudogrpahic: Boolean read expBordersGraph write expBordersGraph;
    property PageBreaks: Boolean read expPageBreaks write expPageBreaks;
    property OEMCodepage: Boolean read expOEM write expOEM;
    property EmptyLines: Boolean read expEmptyLines write expEmptyLines;
    property LeadSpaces: Boolean read expLeadSpaces write expLeadSpaces;
    property PrintAfter: Boolean read expPrintAfter write expPrintAfter;
    property PrinterDialog: Boolean read expPrinterDialog write expPrinterDialog;
    property UseSavedProps: Boolean read expUseSavedProps write expUseSavedProps;
    property InitString: String read PrinterInitString write PrinterInitString;
    property ShowProgress: Boolean read expShowProgress write expShowProgress;
    property CustomFrameSet: String read expCustomFrameSet write expCustomFrameSet;
  end;

implementation

uses frxUtils, frxprinter, Printers, Winspool, frxExportTxtPrn, frxres, frxrcExports;

{$R *.dfm}

type
  PObjCell = ^TObjCell;
  TObjCell = packed record
    Value: Extended;
    Count: Integer;
  end;

  PObjPos = ^TObjPos;
  TObjPos = packed record
    obj: Integer;
    x,y: Integer;
    dx, dy: Integer;
    style: Integer;
  end;

const
  Xdivider = 7;
  Ydivider = 8;
  FrameSet: array [1..2] of String = (
// frameset: vertical, horizontal, up-left corner, up-right corner
//           down-left corner, down-right corner, down tap, left tap,
//           up tap, right tap,  cross
  '|-+++++++++',
  #179#196#218#191#192#217#193#195#194#180#197 );
  EpsonCommCnt = 12;
  Epson: array [0..EpsonCommCnt - 1, 0..2] of String = (
   ('Reset', #27#64, ''),
   ('Normal', #27#120#00, ''),
   ('Pica', #27#120#01#27#107#00, ''),
   ('Elite', #27#120#01#27#107#01, ''),
   ('Condensed', #15, #18),
   ('Bold', #27#71, #27#72),
   ('Italic', #27#52, #27#53),
   ('Wide', #27#87#01, #27#87#00),
   ('12cpi', #27#77, #27#80),
   ('Linefeed 1/8"', #27#48, ''),
   ('Linefeed 7/72"', #27#49, ''),
   ('Linefeed 1/6"', #27#50, ''));
  HPCommCnt = 6;
  HPComm: array [0..HPCommCnt - 1, 0..2] of String = (
   ('Reset', #27#69, ''),
   ('Landscape orientation', #27#38#108#49#79, #27#38#108#48#79),
   ('Italic', #27#40#115#49#83, #27#40#115#48#83),
   ('Bold', #27#40#115#51#66, #27#40#115#48#66),
   ('Draft EconoMode', #27#40#115#49#81, #27#40#115#50#81),
   ('Condenced', #27#40#115#49#50#72#27#38#108#56#68, #27#40#115#49#48#72));
  IBMCommCnt = 8;
  IBMComm: array [0..IBMCommCnt - 1, 0..2] of String = (
   ('Reset', #27#64, ''),
   ('Normal', #27#120#00, ''),
   ('Pica', #27#48#73, ''),
   ('Elite', #27#56#73, ''),
   ('Condensed', #15, #18),
   ('Bold', #27#71, #27#72),
   ('Italic', #27#52, #27#53),
   ('12cpi', #27#77, #27#80));

function ComparePoints(Item1, Item2: Pointer): Integer;
begin
  if PObjCell(Item1).Value > PObjCell(Item2).Value then
    Result := 1
  else if PObjCell(Item1).Value < PObjCell(Item2).Value then
    Result := -1
  else
    Result := 0;
end;

function CompareObjects(Item1, Item2: Pointer): Integer;
var
  m1, m2:  TfrxView;
  Res: Extended;
begin
  m1 := TfrxView(Item1);
  m2 := TfrxView(Item2);
  Res := m1.Top - m2.Top;
  if Res = 0 then
    Res := m1.Left - m2.Left;
  if Res = 0 then
    if (m1 is TfrxCustomMemoView) and (m2 is TfrxCustomMemoView) then
      Res := Length(TfrxMemoView(m1).Memo.Text) - Length(TfrxMemoView(m2).Memo.Text);
  if Res > 0 then
    Result := 1
  else if Res < 0 then
    Result := -1
  else
    Result := 0;
end;

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

constructor TfrxTXTExport.Create(AOwner: TComponent);
var
  i: Integer;
begin
  inherited Create(AOwner);
  RX := TList.Create;
  RY := TList.Create;
  PageObj := TList.Create;
  ObjectPos := TList.Create;
  StyleList := TList.Create;
  pgBreakList := TStringList.Create;
  ShowDialog := True;
  expBorders := False;
  expPageBreaks := True;
  expScaleX := 1.0;
  expScaleY := 1.0;
  expBordersGraph := False;
  expOEM := False;
  expEmptyLines := False;
  expLeadSpaces := False;
  PrinterInitString := '';
  PageWidth := 0;
  PageHeight := 0;
  IsPreview := False;
  expPrintAfter := False;
  expUseSavedProps := True;
  expPrinterDialog := True;
  expShowProgress := True;
  PrintersCount := 0;
  SelectedPrinterType := 0;
  expCustomFrameSet := '';
  Copys := 1;
  /// printer registration
  RegisterPrinterType('NONE');
  RegisterPrinterType('EPSON ESC/P2 Matrix/Stylus)');
  for i := 0 to EpsonCommCnt - 1 do
    RegisterPrinterCommand(1, Epson[i, 0], Epson[i, 1], Epson[i, 2]);
  RegisterPrinterType('HP PCL (LaserJet/DeskJet)');
  for i := 0 to HPCommCnt - 1 do
    RegisterPrinterCommand(2, HPComm[i, 0], HPComm[i, 1], HPComm[i, 2]);
  RegisterPrinterType('CANON/IBM (Matrix)');
  for i := 0 to IBMCommCnt - 1 do
    RegisterPrinterCommand(3, IBMComm[i, 0], IBMComm[i, 1], IBMComm[i, 2]);
end;

destructor TfrxTXTExport.Destroy;
begin
  ClearLastPage;
  RX.Free;
  RY.Free;
  PageObj.Free;
  ObjectPos.Free;
  StyleList.Free;
  pgBreakList.Free;
  inherited;
end;

function TfrxTXTExport.TruncReturns(const Str: String): String;
begin
  Result := StringReplace(Str, #1, '', [rfReplaceAll]);
  if Copy(Result, Length(Result) - 1, 2) = #13#10 then
    Delete(Result, Length(Result) - 1, 2);
end;

function TfrxTXTExport.ChangeReturns(const Str: String): String;
begin
  Result := StringReplace(Str, #1, '', [rfReplaceAll]);
end;

procedure TfrxTXTExport.ClearLastPage;
var
  i: Integer;
begin
  PageObj.Clear;
  for i := 0 to StyleList.Count - 1 do
  begin
    PfrxTXTStyle(StyleList[i]).Font.Free;
    FreeMemory(PfrxTXTStyle(StyleList[i]));
  end;
  StyleList.Clear;
  for i := 0 to RX.Count - 1 do FreeMem(PObjCell(RX[i]));
  RX.Clear;
  for i := 0 to RY.Count - 1 do FreeMem(PObjCell(RY[i]));
  RY.Clear;
  for i := 0 to ObjectPos.Count - 1 do FreeMem(PObjPos(ObjectPos[i]));
  ObjectPos.Clear;
end;

procedure TfrxTXTExport.ObjCellAdd(Vector: TList; Value: Extended);
var
   ObjCell: PObjCell;
   i, cnt: Integer;
   exist: Boolean;
begin
   exist := False;
   if Vector.Count > 0 then
   begin
     if Vector.Count > 100 then
       cnt := Vector.Count - 100 else
       cnt := 0;
     for i := Vector.Count - 1 downto cnt do
       if Round(PObjCell(Vector[i]).Value) = Round(Value) then
       begin
         exist := True;
         break;
       end;
   end;
   if not exist then
   begin
     GetMem(ObjCell, SizeOf(TObjCell));
     ObjCell.Value := Value;
     ObjCell.Count := 0;
     Vector.Add(ObjCell);
   end;
end;

procedure TfrxTXTExport.ObjPosAdd(Vector: TList; x, y, dx, dy, obj: Integer);
var
  ObjPos: PObjPos;
begin
  GetMem(ObjPos, SizeOf(TObjPos));
  ObjPos.x := x;
  ObjPos.y := y;
  ObjPos.dx := dx;
  ObjPos.dy := dy;
  ObjPos.obj := Obj;
  Vector.Add(ObjPos);
end;

procedure TfrxTXTExport.OrderObjectByCells;
var
   obj, c, fx, fy, dx, dy, mi: integer;
   m, curx, cury: Extended;
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 Round(PObjCell(RX[c]).Value) = Round(TfrxView(PageObj[obj]).Left) then
       begin
          fx := c;
          m := TfrxView(PageObj[obj]).Left;
          mi := c + 1;
          curx := TfrxView(PageObj[obj]).Left + TfrxView(PageObj[obj]).Width;
          while Round(m) < Round(curx) do
          begin
            m := m + PObjCell(RX[mi]).Value - PObjCell(RX[mi - 1]).Value;
            inc(mi);
          end;
          dx := mi - c - 1;
          break;
       end;
     for c := 0 to RY.Count - 1 do
       if Round(PObjCell(RY[c]).Value) = Round(TfrxView(PageObj[obj]).Top) then
       begin
          fy := c;
          m := TfrxView(PageObj[obj]).Top;
          mi := c + 1;
          cury := TfrxView(PageObj[obj]).Top + TfrxView(PageObj[obj]).Height;
          while Round(m) < Round(cury) do
          begin
            m := m + PObjCell(RY[mi]).Value - PObjCell(RY[mi - 1]).Value;
            inc(mi);
          end;
          dy := mi - c - 1;
          break;
       end;
     ObjPosAdd(ObjectPos, fx, fy, dx, dy, obj);
   end;
end;

function TfrxTXTExport.CompareStyles(Style1, Style2: PfrxTXTStyle): Boolean;
begin
  if Style1.IsText and Style2.IsText then
  begin
    Result := (Style1.Font.Color = Style2.Font.Color) and
      (Style1.Font.Name = Style2.Font.Name) and
      (Style1.Font.Size = Style2.Font.Size) and
      (Style1.Font.Style = Style2.Font.Style) and
      (Style1.Font.Charset = Style2.Font.Charset) and
      (Style1.VAlignment = Style2.VAlignment) and
      (Style1.HAlignment = Style2.HAlignment) and
      (Style1.FrameTyp = Style2.FrameTyp) and
      (Style1.FrameWidth = Style2.FrameWidth) and
      (Style1.FrameColor = Style2.FrameColor) and
      (Style1.FrameStyle = Style2.FrameStyle) and
      (Style1.FillColor = Style2.FillColor);
  end
  else if (not Style1.IsText) and (not Style2.IsText) then
  begin
    Result := (Style1.VAlignment = Style2.VAlignment) and
      (Style1.HAlignment = Style2.HAlignment) and
      (Style1.FrameTyp = Style2.FrameTyp) and
      (Style1.FrameWidth = Style2.FrameWidth) and
      (Style1.FrameColor = Style2.FrameColor) and
      (Style1.FrameStyle = Style2.FrameStyle) and
      (Style1.FillColor = Style2.FillColor);
  end
  else
    Result := False;