qrwebfilt.pas

delphi7报表打印控件源码 可以设计报表

unit QRWebFilt;
////////////////////////////////////////////////////////////////////////////
//  Unit : QRWebFilt.pas
//
//  TQRGAbstractExportFilter -> TQRGHTMLDocumentFilter
//
//  The new HTML Export document filter class -
//   No lines, columns or text entries.
//
//  (c) 2001 QBS Software
//      Upgraded to be multi-page  29th September 2001
//      Right align bug fixed 11th October
//      Center align bug fixed 14th October
//      Stuff spaces with    ..
//      Change text coords to pixels. Add VertAdjust to HRule   ..
//      Suppress 'next' on final page
//      Add 'FirstLastLinks', 'FinalPage' property
//      25/11/02 add proportional control
//      24th Feb 2002 Added JPEG file saves
//      3rd March 2002 Added concat, linkfontname
//     21/12/2003 QR 4 added TQRHTMLFilt component
////////////////////////////////////////////////////////////////////////////
{$define VER36}
interface
uses windows, classes, controls, stdctrls,sysutils, graphics, buttons,
     forms, extctrls, dialogs, printers, db, DBtables, ComCtrls, qrexport,
     QRPrntr, Quickrpt, QR4Const, qrctrls, grimgctrl, jpeg;

type

  TQRGAbstractExportFilter = class(TQRExportFilter)
  private
    FStream : TStream;
    FCharWidth,
    FCharHeight,
    FPaperWidth,
    FPaperHeight : extended;
    FLineCount,
    FColCount : integer;
    FPageProcessed : boolean;
    FFont : TFont;
    FActiveFont : TFont;
  protected
    function GetText(X, Y : extended; var Font : TFont) : string;
    function GetFilterName : string; override;
    function GetDescription : string; override;
    function GetExtension : string; override;
    procedure WriteToStream(const AText : string);
    procedure WriteLnToStream(const AText : string);
    procedure CreateStream(Filename : string); virtual;
    procedure CloseStream; virtual;
    procedure ProcessPage; virtual;
    procedure StorePage; virtual;
    property Stream : TStream read FStream write FStream;
    property PageProcessed : boolean read FPageProcessed write FPageProcessed;
    property CharWidth : extended read FCharWidth write FCharWidth;
    property CharHeight : extended read FCharHeight write FCharHeight;
    property PaperWidth : extended read FPaperWidth write FPaperWidth;
    property PaperHeight : extended read FPaperHeight write FPaperHeight;
    property LineCount : integer read FLineCount write FLineCount;
    property ColCount : integer read FColCount write FColCount;
  public
    constructor Create( filename : string ); override;
    procedure Start(PaperWidth, PaperHeight : integer; Font : TFont); override;
    procedure Finish; override;
    procedure EndPage; override;
    procedure NewPage; override;
    procedure AcceptGraphic( Xoff, Yoff : extended; GControl : TControl); override;
    procedure TextOut(X, Y : extended; Font : TFont; BGColor : TColor;
               Alignment : TAlignment; Text : string); override;
  end;


  TQRGHTMLDocumentFilter = class(TQRGAbstractExportFilter)
  private
    FFreeStream : boolean;         
    FPageLength : integer;
    FBodyColor : TColor;
    FBackgroundPic : String;
    FFirstReport : boolean;
    FReportNumber : integer;
    FExtraBody : String;
    FPageNumber : longint;
    FNextPicnum : longint;
    FPageMaxY : integer;
    HTMFirstPage : boolean;
    HTMLastPage : boolean;
    function getTransparentTextBG : boolean;
    procedure setTransparentTextBG( value : boolean);
    function getPictureDir : string;
    procedure setPictureDir( value : string);
    function getMultiPage : boolean;
    procedure setMultiPage( value : boolean);
    function getFinalPage : integer;
    procedure setFinalPage( value : integer);
    function getFirstLastLinks :boolean;
    procedure setFirstLastLinks( value : boolean);
    function getPageLinks :boolean;
    procedure setPageLinks( value : boolean);
    function getConcatenate : boolean;
    procedure setConcatenate( value : boolean);
    function getConcatCount : integer;
    procedure setConcatCount( value : integer);
    procedure setLinkFontHeight( value : integer);
    function getLinkFontHeight : integer;
    function getLinkFontName : string;
    procedure setLinkFontName( value : string);
  protected
    function GetFilterName : string; override;
    function GetDescription : string; override;
    function GetExtension : string; override;
    function GetStreaming : boolean; override;
    procedure CreateStream(Filename : string); override;
    procedure CloseStream; override;
  public
    LinkPrefix : string;
    constructor Create( filename : string ); override;
    procedure StorePage; override;
    procedure TextOut(X, Y : extended; Font : TFont; BGColor : TColor;
               Alignment : TAlignment; Text : string); override;
    procedure ProcessPage; override;
    procedure Start(PaperWidth, PaperHeight : integer; Font : TFont); override;
    procedure Finish; override;
    procedure SetHTMLBody( BodyCol : TColor; BGPic, BExtra : string );
    property TransparentTextBG : boolean read getTransparentTextBG  write setTransparentTextBG;
    procedure NewPage; override;
    procedure EndPage; override;
    procedure EndConcat;
    procedure AcceptGraphic( Xoff, Yoff : extended; GControl : TControl); override;
    property PictureDir : string read getPictureDir write setPictureDir;
    property MultiPage : boolean read getMultiPage  write setMultiPage;
    property PageLinks : boolean read getPageLinks  write setPageLinks;
    property PageLength : integer read FPageLength write FPageLength;
    property FinalPage : integer read getFinalPage write setFinalPage;
    property FirstLastLinks : boolean read getFirstLastLinks write setFirstLastLinks;
    property Stream;
    property FreeStream : boolean read FFreeStream write FFreeStream;
    property Concat : boolean read getConcatenate write setConcatenate;
    property ConcatCount : integer read getConcatCount write setConcatCount;
    property LinkFontSize : integer read getLinkFontHeight write setLinkFontHeight;
    property LinkFontName : string read getLinkFontName write setLinkFontName;
  end;

  TQRHTMLFilter = class(TComponent)
  protected
  private
     FImageLinkPrefix : string;
     FPagelinkPrefix : string;
    function getTransparentTextBG : boolean;
    procedure setTransparentTextBG( value : boolean);
    function getPictureDir : string;
    procedure setPictureDir( value : string);
    function getMultiPage : boolean;
    procedure setMultiPage( value : boolean);
    function getFinalPage : integer;
    procedure setFinalPage( value : integer);
    function getFirstLastLinks :boolean;
    procedure setFirstLastLinks( value : boolean);
    function getPageLinks :boolean;
    procedure setPageLinks( value : boolean);
    function getConcatenate : boolean;
    procedure setConcatenate( value : boolean);
    function getConcatCount : integer;
    procedure setConcatCount( value : integer);
    procedure setLinkFontHeight( value : integer);
    function getLinkFontHeight : integer;
    function getLinkFontName : string;
    procedure setLinkFontName( value : string);
    function getPageLength : integer;
    procedure setPageLength( value : integer);
  public
    constructor Create(AOwner : TComponent); override;
    destructor Destroy; override;
  published
    property ImageLinkPrefix : string read FImageLinkPrefix write FImageLinkPrefix;
    property PagelinkPrefix : string read FPagelinkPrefix write FPagelinkPrefix;
    property PictureDir : string read getPictureDir write setPictureDir;
    property MultiPage : boolean read getMultiPage  write setMultiPage;
    property PageLinks : boolean read getPageLinks  write setPageLinks;
    //property PageLength : integer read getPageLength write setPageLength;
    property FinalPage : integer read getFinalPage write setFinalPage;
    property FirstLastLinks : boolean read getFirstLastLinks write setFirstLastLinks;
    property Concat : boolean read getConcatenate write setConcatenate;
    property ConcatCount : integer read getConcatCount write setConcatCount;
    property LinkFontSize : integer read getLinkFontHeight write setLinkFontHeight;
    property LinkFontName : string read getLinkFontName write setLinkFontName;
  end;
  function basename( fname : string ) : string;


implementation
  var
    HTMTransparentTextBG : boolean;
    HTMFinalPage : integer;
    HTMPageLength : integer;
    HTMMultiPage : boolean;
    HTMPageLinks : boolean;
    HTMConcatenate : boolean;
    HTMConcatCount : integer;
    HTMFirstLastLinks : boolean;
    HTMPictureDir : string;
    HTMLinkFontName : string;
    HTMLinkFontHeight : integer;

constructor TQRHTMLFilter.Create(AOwner : TComponent);
begin
  inherited Create(AOwner);
  QRExportFilterLibrary.AddFilter(TQRGHTMLDocumentFilter);
end;

destructor TQRHTMLFilter.Destroy;
begin
  QRExportFilterLibrary.RemoveFilter(TQRGHTMLDocumentFilter);
  inherited Destroy;
end;

function TQRHTMLFilter.getTransparentTextBG : boolean;
begin
    result := HTMTransparentTextBG;
end;
procedure TQRHTMLFilter.setTransparentTextBG( value : boolean);
begin
     HTMTransparentTextBG := value;
end;
function TQRHTMLFilter.getPictureDir : string;
begin
    result := HTMPictureDir;
end;
procedure TQRHTMLFilter.setPictureDir( value : string);
begin
    HTMPictureDir := value;
end;
function TQRHTMLFilter.getMultiPage : boolean;
begin
    result := HTMMultiPage;
end;
procedure TQRHTMLFilter.setMultiPage( value : boolean);
begin
     HTMMultiPage := value;
end;

function TQRHTMLFilter.getPageLength : integer;
begin
    result := HTMPageLength;
end;
procedure TQRHTMLFilter.setPageLength( value : integer);
begin
     HTMPageLength := value;
end;

function TQRHTMLFilter.getFinalPage : integer;
begin
    result := HTMFinalPage;
end;
procedure TQRHTMLFilter.setFinalPage( value : integer);
begin
     HTMFinalPage := value;
end;

function TQRHTMLFilter.getFirstLastLinks :boolean;
begin
    result := HTMFirstLastLinks;
end;
procedure TQRHTMLFilter.setFirstLastLinks( value : boolean);
begin
     HTMFirstLastLinks := value;
end;
function TQRHTMLFilter.getPageLinks :boolean;
begin
    result := HTMPageLinks;
end;
procedure TQRHTMLFilter.setPageLinks( value : boolean);
begin
     HTMPageLinks := value;
end;
function TQRHTMLFilter.getConcatenate : boolean;
begin
    result := HTMConcatenate;
end;
procedure TQRHTMLFilter.setConcatenate( value : boolean);
begin
     HTMConcatenate := value;
end;
function TQRHTMLFilter.getConcatCount : integer;
begin
    result := HTMConcatCount;
end;
procedure TQRHTMLFilter.setConcatCount( value : integer);
begin
     HTMConcatCount := value;
end;
procedure TQRHTMLFilter.setLinkFontHeight( value : integer);
begin
     HTMLinkFontHeight := value;
end;
function TQRHTMLFilter.getLinkFontHeight : integer;
begin
    result := HTMLinkFontHeight;
end;
function TQRHTMLFilter.getLinkFontName : string;
begin
    result := HTMLinkFontName;
end;
procedure TQRHTMLFilter.setLinkFontName( value : string);
begin
     HTMLinkFontName := value;
end;
{TQRGAbstractExportFilter}
constructor TQRGAbstractExportFilter.Create( filename : string );
begin
      inherited Create( filename);
end;

procedure TQRGAbstractExportFilter.AcceptGraphic( Xoff, Yoff : extended; GControl : TControl);
begin
end;

function TQRGAbstractExportFilter.GetFilterName : string;
begin
  result := 'QRAbstract'; // Do not translate
end;

function TQRGAbstractExportFilter.GetDescription : string;
begin
  Result := '';
end;

function TQRGAbstractExportFilter.GetExtension : string;
begin
  Result := '';
end;

procedure TQRGAbstractExportFilter.Start(PaperWidth, PaperHeight : integer; Font : TFont);
begin
  CreateStream(Filename);
  FFont := TFont.Create;
  FActiveFont := TFont.Create;
  FFont.Assign(Font);
  CharHeight := Font.Size * (254 / 72);
  CharWidth := Font.Size * (254 / 72);
  FPaperHeight := PaperHeight;
  FPaperWidth := PaperWidth;
  LineCount := round(PaperHeight / CharHeight);
  FPageProcessed := false;
  inherited Start(PaperWidth, PaperHeight, Font);
end;


procedure TQRGAbstractExportFilter.CreateStream(Filename : string);
begin
  FStream := TFileStream.Create(Filename, fmCreate);
end;

procedure TQRGAbstractExportFilter.CloseStream;
begin
  FStream.Free;
end;

procedure TQRGAbstractExportFilter.WriteToStream(const AText : string);
begin
  Stream.Write(AText[1], length(AText));
end;

procedure TQRGAbstractExportFilter.WriteLnToStream(const AText : string);
begin
  WriteToStream(AText + #13 + #10);
end;


procedure TQRGAbstractExportFilter.Finish;
begin
  FFont.Free;
  FActiveFont.Free;
  CloseStream;
  inherited Finish; // doesn't do owt
end;

procedure TQRGAbstractExportFilter.NewPage;
begin
  FPageProcessed := False;
  FActiveFont.Free;
  FActiveFont := TFont.Create;
  inherited NewPage;
end;

procedure TQRGAbstractExportFilter.EndPage;
begin
  ProcessPage;
  inherited EndPage;
end;

procedure TQRGAbstractExportFilter.ProcessPage;
begin