frxdmpexport.pas

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

{******************************************}
{                                          }
{             FastReport v4.0              }
{         Dot-matrix export filter         }
{                                          }
{         Copyright (c) 1998-2008          }
{         by Alexander Tzyganenko,         }
{            Fast Reports Inc.             }
{                                          }
{******************************************}

unit frxDMPExport;

interface

{$I frx.inc}

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

type
  TfrxTranslateEvent = procedure(Sender: TObject; var s: AnsiString) of object;

  TfrxDotMatrixExport = class(TfrxCustomExportFilter)
  private
    FBufWidth: Integer;
    FBufHeight: Integer;
    FCharBuf: array of AnsiChar;
    FCopies: Integer;
    FCustomFrameSet: AnsiString;
    FEscModel: Integer;
    FFrameBuf: array of Byte;
    FGraphicFrames: Boolean;
    FMaxHeight: Integer;
    FOEMConvert: Boolean;
    FPageBreaks: Boolean;
    FPageStyle: Integer;
    FPrinterInitString: AnsiString;
    FSaveToFile: Boolean;
    FStream: TStream;
    FStyleBuf: array of Integer;
    FUseIniSettings: Boolean;
    FOnTranslate: TfrxTranslateEvent;

    function GetTempFName: String;
    function IntToStyle(i: Integer): TfrxDMPFontStyles;
    function StyleChange(OldStyle, NewStyle: Integer): String;
    function StyleOff(Style: Integer): String;
    function StyleOn(Style: Integer): String;
    function StyleToInt(Style: TfrxDMPFontStyles): Integer;

    procedure CreateBuf(Width, Height: Integer);
    procedure DrawFrame(x, y, dx, dy: Integer; Style: Integer);
    procedure DrawMemo(x, y, dx, dy: Integer; Memo: TfrxDMPMemoView);
    procedure FlushBuf;
    procedure FormFeed;
    procedure FreeBuf;
    procedure Landscape;
    procedure Portrait;
    procedure Reset;
    procedure SetFrame(x, y: Integer; typ: Byte);
    procedure SetString(x, y: Integer; s: AnsiString);
    procedure SetStyle(x, y, Style: Integer);
    procedure SpoolFile(const FileName: String);
    procedure WriteStrLn(const str: AnsiString);
    procedure WriteStr(const str: AnsiString);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function ShowModal: TModalResult; override;
    function Start: Boolean; override;
    procedure ExportObject(Obj: TfrxComponent); override;
    procedure Finish; override;
    procedure FinishPage(Page: TfrxReportPage; Index: Integer); override;
    procedure StartPage(Page: TfrxReportPage; Index: Integer); override;
  published
    property CustomFrameSet: AnsiString read FCustomFrameSet write FCustomFrameSet;
    property EscModel: Integer read FEscModel write FEscModel;
    property GraphicFrames: Boolean read FGraphicFrames write FGraphicFrames;
    property InitString: AnsiString read FPrinterInitString write FPrinterInitString;
    property OEMConvert: Boolean read FOEMConvert write FOEMConvert default True;
    property PageBreaks: Boolean read FPageBreaks write FPageBreaks default True;
    property SaveToFile: Boolean read FSaveToFile write FSaveToFile;
    property UseIniSettings: Boolean read FUseIniSettings write FUseIniSettings;
    property OnTranslate: TfrxTranslateEvent read FOnTranslate write FOnTranslate;
  end;

  TfrxDMPExportDialog = class(TForm)
    OK: TButton;
    Cancel: TButton;
    SaveDialog1: TSaveDialog;
    Image1: TImage;
    PrinterL: TGroupBox;
    PrinterCB: TComboBox;
    EscL: TGroupBox;
    EscCB: TComboBox;
    CopiesL: TGroupBox;
    CopiesNL: TLabel;
    CopiesE: TEdit;
    CopiesUD: TUpDown;
    PagesL: TGroupBox;
    DescrL: TLabel;
    AllRB: TRadioButton;
    CurPageRB: TRadioButton;
    PageNumbersRB: TRadioButton;
    RangeE: TEdit;
    OptionsL: TGroupBox;
    SaveToFileCB: TCheckBox;
    PageBreaksCB: TCheckBox;
    OemCB: TCheckBox;
    PseudoCB: TCheckBox;
    procedure FormCreate(Sender: TObject);
    procedure PrinterCBDrawItem(Control: TWinControl; Index: Integer;
      ARect: TRect; State: TOwnerDrawState);
    procedure PrinterCBClick(Sender: TObject);
    procedure FormHide(Sender: TObject);
    procedure RangeEEnter(Sender: TObject);
    procedure FormKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
  private
    OldIndex: Integer;
  end;

const
  cmdName = 1;
  cmdReset = 2;
  cmdFormFeed = 3;
  cmdLandscape = 4;
  cmdPortrait = 5;
  cmdBoldOn = 6;
  cmdBoldOff = 7;
  cmdItalicOn = 8;
  cmdItalicOff = 9;
  cmdUnderlineOn = 10;
  cmdUnderlineOff = 11;
  cmdSuperscriptOn = 12;
  cmdSuperscriptOff = 13;
  cmdSubscriptOn = 14;
  cmdSubscriptOff = 15;
  cmdCondensedOn = 16;
  cmdCondensedOff = 17;
  cmdWideOn = 18;
  cmdWideOff = 19;
  cmd12cpiOn = 20;
  cmd12cpiOff = 21;
  cmd15cpiOn = 22;
  cmd15cpiOff = 23;

  CommandCount = 23;
  CommandNames: array[1..CommandCount] of String = (
    'Name', 'Reset', 'FormFeed', 'Landscape', 'Portrait',
    'BoldOn', 'BoldOff', 'ItalicOn', 'ItalicOff', 'UnderlineOn', 'UnderlineOff',
    'SuperscriptOn', 'SuperscriptOff', 'SubscriptOn', 'SubscriptOff',
    'CondensedOn', 'CondensedOff', 'WideOn', 'WideOff',
    'cpi12On', 'cpi12Off', 'cpi15On', 'cpi15Off');

type
  TfrxDMPrinter = class(TCollectionItem)
  public
    Commands: array[1..CommandCount] of String;
    procedure Assign(Source: TPersistent); override;
  end;

  TfrxDMPrinters = class(TCollection)
  private
    function GetItem(Index: Integer): TfrxDMPrinter;
  public
    constructor Create;
    function Add: TfrxDMPrinter;
    procedure ReadDefaultPrinters;
    procedure ReadExtPrinters;
    procedure ReadPrinters(x: TfrxXMLDocument);
    property Items[Index: Integer]: TfrxDMPrinter read GetItem; default;
  end;

var
  frxDMPrinters: TfrxDMPrinters;


implementation

uses frxUtils, frxPrinter, Printers, frxRes, IniFiles, Winspool;

{$R *.dfm}

const
  FrameSet: array[1..2] of AnsiString = (
    '  + |++ +-+++++',
    #32#32#192#32#179#218#195#32#217#196#193#191#180#194#197);
  DefaultPrinters: String =
'<?xml version="1.0" encoding="utf-8"?>' +
'<printers>' +
'  <printer id="0" Name="None" FormFeed="0C"/>' +
'  <printer id="1" Name="Epson Generic" Inherit="0" Reset="1B40" ' +
'BoldOn="1B45" BoldOff="1B46" ItalicOn="1B34" ItalicOff="1B35" ' +
'UnderlineOn="1B2D01" UnderlineOff="1B2D00" SuperscriptOn="#27#83#01" SuperscriptOff="#27#84" ' +
'SubscriptOn="#27#83#00" SubscriptOff="#27#84" CondensedOn="0F" CondensedOff="12" ' +
'WideOn="1B5701" WideOff="1B5700" cpi12On="1B4D" cpi12Off="1B50" cpi15On="1B67" cpi15Off="1B50"/>' +
'  <printer id="2" Name="HP Generic" Inherit="0" Reset="1B45" ' +
'Portrait="1B266C304F" Landscape="1B266C314F" BoldOn="1B28733342" ' +
'BoldOff="1B28733042" ItalicOn="1B28733153" ItalicOff="1B28733053" ' +
'UnderlineOn="1B26643144" UnderlineOff="1B266440" ' +
'SuperscriptOn="#27#38#97#45#46#53#82" SuperscriptOff="#27#38#97#43#46#53#82" ' +
'SubscriptOn="#27#38#97#43#46#53#82" SubscriptOff="#27#38#97#45#46#53#82" ' +
'CondensedOn="1B2873313648" CondensedOff="1B2873313048" ' +
'WideOn="1B28733548" WideOff="1B2873313048" cpi12On="1B266B313048" ' +
'cpi12Off="1B266B313248" cpi15On="" cpi15Off=""/>' +
'  <printer id="3" Name="IBM Generic" Inherit="1" Reset="" cpi12On="1B3A" ' +
'cpi12Off="12" cpi15On="1B67" cpi15Off="12"/>' +
'</printers>';

type
  TWordSet = set of 0..15;
  PWordSet = ^TWordSet;
  PfrxDMPFontStyles = ^TfrxDMPFontStyles;


{ TfrxDMPrinter }

procedure TfrxDMPrinter.Assign(Source: TPersistent);
begin
  if Source is TfrxDMPrinter then
    Commands := TfrxDMPrinter(Source).Commands;
end;


{ TfrxDMPrinters }

constructor TfrxDMPrinters.Create;
begin
  inherited Create(TfrxDMPrinter);
end;

function TfrxDMPrinters.Add: TfrxDMPrinter;
begin
  Result := TfrxDMPrinter(inherited Add);
end;

function TfrxDMPrinters.GetItem(Index: Integer): TfrxDMPrinter;
begin
  Result := TfrxDMPrinter(inherited Items[Index]);
end;

procedure TfrxDMPrinters.ReadDefaultPrinters;
var
  x: TfrxXMLDocument;
  s: TStringStream;
begin
  x := TfrxXMLDocument.Create;
  s := TStringStream.Create(DefaultPrinters);
  try
    x.LoadFromStream(s);
    ReadPrinters(x);
  finally
    s.Free;
    x.Free;
  end;
end;

procedure TfrxDMPrinters.ReadExtPrinters;
var
  x: TfrxXMLDocument;
begin
  if not FileExists(ExtractFilePath(Application.ExeName) + 'printers.xml') then
    Exit;
  x := TfrxXMLDocument.Create;
  try
    x.LoadFromFile(ExtractFilePath(Application.ExeName) + 'printers.xml');
    ReadPrinters(x);
  except
    ShowMessage('Error in file printers.xml');
  end;

  x.Free;
end;

procedure TfrxDMPrinters.ReadPrinters(x: TfrxXMLDocument);
var
  i, j: Integer;
  xi: TfrxXMLItem;
  Item: TfrxDMPrinter;

  function ConvertProp(s: String): String;
  var
    i: Integer;
    s1: String;
  begin
    Result := '';
    s1 := '';
    if Pos('#', s) = 1 then
    begin
      s := s + '#';
      for i := 2 to Length(s) do
        if s[i] = '#' then
        begin
          Result := Result + Chr(StrToInt(s1));
          s1 := '';
        end
        else
          s1 := s1 + s[i];
    end
    else
    begin
      for i := 1 to Length(s) do
      begin
        s1 := s1 + s[i];
        if i mod 2 = 0 then
        begin
          Result := Result + Chr(StrToInt('$' + s1));
          s1 := '';
        end;
      end;
    end;
  end;

begin
  Clear;
  for i := 0 to x.Root.Count - 1 do
  begin
    Item := Add;
    xi := x.Root[i];
    if xi.Prop['Inherit'] <> '' then
      Item.Assign(Items[StrToInt(xi.Prop['Inherit'])]);
    for j := 1 to CommandCount do
      if xi.PropExists(CommandNames[j]) then
        if j = 1 then
          Item.Commands[j] := xi.Prop[CommandNames[j]] else
          Item.Commands[j] := ConvertProp(xi.Prop[CommandNames[j]]);
  end;
end;


{ TfrxDotMatrixExport }

constructor TfrxDotMatrixExport.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  frxDotMatrixExport := Self;
  FCopies := 1;
  FOEMConvert := True;
  FPageBreaks := True;
  FUseIniSettings := True;
end;

destructor TfrxDotMatrixExport.Destroy;
begin
  FreeBuf;
  frxDotMatrixExport := nil;
  inherited;
end;

function TfrxDotMatrixExport.GetTempFName: String;
var
  Path: String;
  FileName: String;
begin
  Path := Report.EngineOptions.TempDir;
  if Path = '' then
  begin
    SetLength(Path, MAX_PATH);
    SetLength(Path, GetTempPath(MAX_PATH, @Path[1]));
  end
  else
    Path := Path + #0;
  SetLength(FileName, MAX_PATH);
  GetTempFileName(@Path[1], PChar('fr'), 0, @FileName[1]);
{$IFDEF Delphi12}
  Result := StrPas(PWideChar(@FileName[1]));
{$ELSE}
  Result := StrPas(PChar(@FileName[1]));
{$ENDIF}
end;

function TfrxDotMatrixExport.IntToStyle(i: Integer): TfrxDMPFontStyles;
begin
  Result := TfrxDMPFontStyles(PfrxDMPFontStyles(@i)^);
end;

function TfrxDotMatrixExport.StyleToInt(Style: TfrxDMPFontStyles): Integer;
begin
  Result := Word(PWordSet(@Style)^);
end;

procedure TfrxDotMatrixExport.SpoolFile(const FileName: String);
const
  BUF_SIZE = 1024;
var
  f: TFileStream;
  buf: AnsiString;
  l: longint;
begin
  if Report.ReportOptions.Name <> '' then
    frxPrinters.Printer.Title := Report.ReportOptions.Name else
    frxPrinters.Printer.Title := Report.FileName;
  frxPrinters.Printer.BeginRAWDoc;

  f := TFileStream.Create(FileName, fmOpenRead);
  SetLength(buf, BUF_SIZE);
  l := BUF_SIZE;
  while l = BUF_SIZE do
  begin
    l := f.Read(buf[1], BUF_SIZE);
    SetLength(buf, l);
    frxPrinters.Printer.WriteRAWDoc(buf);
  end;

  f.Free;
  frxPrinters.Printer.EndRAWDoc;
end;

procedure TfrxDotMatrixExport.FormFeed;
begin
  WriteStr(AnsiString(frxDMPrinters[FEscModel].Commands[cmdFormFeed]));
end;

procedure TfrxDotMatrixExport.Landscape;
begin
  WriteStr(AnsiString(frxDMPrinters[FEscModel].Commands[cmdLandscape]));
end;

procedure TfrxDotMatrixExport.Portrait;
begin
  WriteStr(AnsiString(frxDMPrinters[FEscModel].Commands[cmdPortrait]));
end;

procedure TfrxDotMatrixExport.Reset;
begin
  WriteStr(AnsiString(frxDMPrinters[FEscModel].Commands[cmdReset]));
end;

function TfrxDotMatrixExport.StyleOff(Style: Integer): String;
var
  st: TfrxDMPFontStyles;
begin
  st := IntToStyle(Style);
  Result := '';
  if fsxBold in st then
    Result := Result + frxDMPrinters[FEscModel].Commands[cmdBoldOff];
  if fsxItalic in st then
    Result := Result + frxDMPrinters[FEscModel].Commands[cmdItalicOff];
  if fsxUnderline in st then
    Result := Result + frxDMPrinters[FEscModel].Commands[cmdUnderlineOff];
  if fsxSuperScript in st then
    Result := Result + frxDMPrinters[FEscModel].Commands[cmdSuperscriptOff];
  if fsxSubScript in st then
    Result := Result + frxDMPrinters[FEscModel].Commands[cmdSubscriptOff];
  if fsxCondensed in st then
    Result := Result + frxDMPrinters[FEscModel].Commands[cmdCondensedOff];
  if fsxWide in st then
    Result := Result + frxDMPrinters[FEscModel].Commands[cmdWideOff];
  if fsx12cpi in st then
    Result := Result + frxDMPrinters[FEscModel].Commands[cmd12cpiOff];
  if fsx15cpi in st then
    Result := Result + frxDMPrinters[FEscModel].Commands[cmd15cpiOff];
end;

function TfrxDotMatrixExport.StyleOn(Style: Integer): String;
var
  st: TfrxDMPFontStyles;
begin
  st := IntToStyle(Style);
  Result := '';
  if fsxBold in st then
    Result := Result + frxDMPrinters[FEscModel].Commands[cmdBoldOn];
  if fsxItalic in st then
    Result := Result + frxDMPrinters[FEscModel].Commands[cmdItalicOn];
  if fsxUnderline in st then
    Result := Result + frxDMPrinters[FEscModel].Commands[cmdUnderlineOn];
  if fsxSuperScript in st then
    Result := Result + frxDMPrinters[FEscModel].Commands[cmdSuperscriptOn];
  if fsxSubScript in st then
    Result := Result + frxDMPrinters[FEscModel].Commands[cmdSubscriptOn];
  if fsxCondensed in st then
    Result := Result + frxDMPrinters[FEscModel].Commands[cmdCondensedOn];
  if fsxWide in st then
    Result := Result + frxDMPrinters[FEscModel].Commands[cmdWideOn];
  if fsx12cpi in st then
    Result := Result + frxDMPrinters[FEscModel].Commands[cmd12cpiOn];
  if fsx15cpi in st then
    Result := Result + frxDMPrinters[FEscModel].Commands[cmd15cpiOn];
end;

function TfrxDotMatrixExport.StyleChange(OldStyle, NewStyle: Integer): String;
begin
  Result := StyleOff(OldStyle) + StyleOn(NewStyle);
end;

procedure TfrxDotMatrixExport.SetFrame(x, y: Integer; typ: Byte);
begin
  if (x < 0) or (y < 0) or (x >= FBufWidth) or (y >= FBufHeight) then Exit;
  FFrameBuf[FBufWidth * y + x] := FFrameBuf[FBufWidth * y + x] or typ;
end;

procedure TfrxDotMatrixExport.SetString(x, y: Integer; s: AnsiString);
var
  i, j: Integer;
  c: AnsiChar;
begin
  if (x < 0) or (y < 0) or (y >= FBufHeight) then Exit;
  if Assigned(FOnTranslate) then
    FOnTranslate(Self, s);
  for i := 1 to Length(s) do
  begin
    if x + i - 1 >= FBufWidth then break;
    c := s[i];
    j := FBufWidth * y + x + i - 1;
    FCharBuf[j] := c;
  end;
end;

procedure TfrxDotMatrixExport.SetStyle(x, y, Style: Integer);
begin
  if (x < 0) or (y < 0) or (x >= FBufWidth) or (y >= FBufHeight) then Exit;
  FStyleBuf[FBufWidth * y + x] := Style;