qrxmlsfilt.pas

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

unit QRXMLSFilt;
////////////////////////////////////////////////////////////////////////////
//  Unit : QRXMLSFilt.pas
//
//  TQRXAbstractExportFilter -> TQRXDocumentFilter
//
//  The new XMLS Export document filter classes -
//
//  (c) 2002 QBS Software
//
//  03/04/2003 DLM : added concatenating 
//  26/06/2003 DLM : added graphics position adjust
//  26/01/2004 DLM : Update for QR4
//  25/03/2004 Image handling added
////////////////////////////////////////////////////////////////////////////
{$define VER36}
interface
uses windows, classes, controls, stdctrls, sysutils, graphics, buttons,
     forms, extctrls, dialogs, printers, db, DBtables, ComCtrls, 
     QRPrntr, Quickrpt, QR4Const, qrctrls, grids;

const
     CRLF = chr($0D) + chr($0A);
     // ascii
     ORD0 = ord('0');
     ORDA = ord('A');
type

  TQRXAbstractExportFilter = 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 AcceptBand( aBand : TControl; Xoff, Yoff, Expanded : extended); override;
    procedure AcceptGraphic( Xoff, Yoff : extended; GControl : TControl); override;
    procedure TextOut(X, Y : extended; Font : TFont; BGColor : TColor;
               Alignment : TAlignment; Text : string); override;
  end;

  TQRXImageURLNeeded = procedure(Sender: TObject; ImageCtrl: TControl; var ImageURL: String; var IncludeByRef: Boolean) of object;

  TQRXDocumentFilter = class(TQRXAbstractExportFilter)
  private
    FFreeStream : boolean;
    // doc filter properties
    FLastRecordNum : longint;
    FNextPicNum : longint;
    FPagenumber : longint;
    FDocType : string;
    FCreator : string;
    FTitle : string;
    FAuthor : string;
    FDocDate : string;
    FCopyright : string;
    FOrientation : string;
    FXLStyleURL : string;
    FConcatenating : boolean;
    FCompressImages : boolean;
    FXLEncoding: string;
    FDoImages: boolean;
    FOnImageURLNeeded: TQRXImageURLNeeded;
  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
    // graphic finesse properties
    VertLineAdjust, HorizLineAdjust, LeftMarginAdjust : double; // in mm
    constructor Create( filename : string );override;
    procedure NewDocument( doclist : TStringlist; PaperWidth, PaperHeight : double;
              Papername, orient : string);
    procedure TextOut(X, Y : extended; Font : TFont; BGColor : TColor;
               Alignment : TAlignment; Text : string); override;
    procedure LoadDTD( var dlist : TStringlist );
    procedure ProcessPage; override;
    procedure Start(PaperWidth, PaperHeight : integer; Font : TFont); override;
    procedure EndConcat;
    procedure Finish; override;
    procedure NewPage; override;
    procedure EndPage; override;
    procedure AcceptGraphic( Xoff, Yoff : extended; GControl : TControl); override;
    procedure SetDocumentProperties( author, title, copyright : string );
    property Stream;
    property FreeStream : boolean read FFreeStream write FFreeStream;
    property Orientation : string read FOrientation write FOrientation;
    property Creator : string read FCreator write FCreator;
    property Author : string read FAuthor write FAuthor;
    property Title : string read FTitle write FTitle;
    property DocDate : string read FDocDate write FDocDate;
    property Copyright : string read FCopyright write FCopyright;
    property DocType : string read FDocType write FDocType;
    property XLEncoding: string read FXLEncoding write FXLEncoding;
    property XLStyleURL : string read FXLStyleURL write FXLStyleURL;
    property CompressImages : boolean read FCompressImages write FCompressImages;
    property DoImages: boolean read FDoImages write FDoImages;
    property Concatenating : boolean read FConcatenating write FConcatenating;
    property OnImageURLNeeded: TQRXImageURLNeeded read FOnImageURLNeeded write FOnImageURLNeeded;
  end;

  TQRXMLSFilter = class(TComponent)
  protected
  public
    constructor Create(AOwner : TComponent); override;
    destructor Destroy; override;
  published
  end;

  function basename( fname : string ) : string;
  procedure RunLength(Source, Target: TStream);

implementation
//uses grimgctrl;

constructor TQRXMLSFilter.Create(AOwner : TComponent);
begin
  inherited Create(AOwner);
  QRExportFilterLibrary.AddFilter(TQRXDocumentFilter);
end;

destructor TQRXMLSFilter.Destroy;
begin
  QRExportFilterLibrary.RemoveFilter(TQRXDocumentFilter);
  inherited Destroy;
end;


{TQRXAbstractExportFilter}
constructor TQRXAbstractExportFilter.Create( filename : string);
begin
     inherited Create(filename);
end;

procedure TQRXAbstractExportFilter.AcceptBand( aBand : TControl; Xoff, Yoff, Expanded : extended);
begin
end;

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

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

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

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

procedure TQRXAbstractExportFilter.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 TQRXAbstractExportFilter.CreateStream(Filename : string);
begin
  FStream := TFileStream.Create(Filename, fmCreate);
end;

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

procedure TQRXAbstractExportFilter.WriteToStream(const AText : string);
begin
  if length(AText)>0 then
    Stream.Write(AText[1], length(AText));
end;

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


procedure TQRXAbstractExportFilter.Finish;
begin
  FFont.Free;
  FActiveFont.Free;
  CloseStream;
  inherited Finish;
end;

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

procedure TQRXAbstractExportFilter.EndPage;
begin
  //EndPage;??
  ProcessPage;
  inherited EndPage;
end;

procedure TQRXAbstractExportFilter.ProcessPage;
begin
  FPageProcessed := True;
end;

procedure TQRXAbstractExportFilter.StorePage;
begin
end;

procedure TQRXAbstractExportFilter.TextOut(X, Y : extended; Font : TFont;
                      BGColor : TColor; Alignment : TAlignment; Text : string);
begin
end;

function TQRXAbstractExportFilter.GetText(X, Y : extended; var Font : TFont) : string;
begin
end;

{TQRXDocumentFilter}
function TQRXDocumentFilter.GetFilterName : string;
begin
  Result := SqrQRXDocument;
end;

function TQRXDocumentFilter.GetDescription : string;
begin
  Result := SqrQRXDocumentForWeb;
end;

function TQRXDocumentFilter.GetExtension : string;
begin
  Result := 'QRX'; // Do not translate
end;

function TQRXDocumentFilter.GetStreaming : boolean;
begin
  Result := false;// stream multipage report mode
end;

procedure TQRXDocumentFilter.CreateStream(Filename : string);
begin
  if Filename = '' then
  begin
    FStream := TMemoryStream.Create;
    FreeStream := false;
  end else
  begin
    FreeStream := true;
    inherited CreateStream(Filename);
  end;
end;

procedure TQRXDocumentFilter.CloseStream;
begin
  // the stream is not freed if it's a memory stream
  if FreeStream then
    inherited CloseStream;
end;

constructor TQRXDocumentFilter.Create( filename : string );
begin
   inherited Create( filename);
   FLastRecordNum := 0;
   FNextpicNum := 0;
   FPagenumber := 1;
   FCreator := 'QRXDocumentFilter';
   FDocDate := datetostr( date );
   FOrientation := 'Portrait';
   FCompressImages := true;
   FXLEncoding := 'windows-1252';
   FDoImages := true;
   HorizLineAdjust := 0.0;
   VertLineAdjust := 0.0;
end;

// QBSS : override method to skip converttoxxx
procedure TQRXDocumentFilter.ProcessPage;
begin
  FPageProcessed := True;
  StorePage;
end;

procedure TQRXDocumentFilter.SetDocumentProperties( author, title, copyright : string );
begin
      FAuthor := author;
      FTitle := title;
      FCopyright := copyright;

end;
procedure TQRXDocumentFilter.LoadDTD( var dlist : TStringlist );
var
    ssurl : string;
begin
     if trim(FXLEncoding)='' then
       dlist.add('<?xml version="1.0"?>')
     else
       dlist.add('<?xml version="1.0" encoding="'+FXLEncoding+'"?>');

     if trim( FXLStyleURL) = '' then
       ssurl := 'QXDStylesheet.xsl'
     else
       ssurl := FXLStyleURL;

     dlist.add('<?xml-stylesheet type="text/xsl" href="'+ssurl+'"?>');
     dlist.add('<!DOCTYPE QXDocument [');
     dlist.add('<!ELEMENT QXDocument (Header, Page*)>');
     dlist.add('<!ELEMENT Header (Title*, DocType*, Creator*, Author*, Date*, Copyright*, Orientation*)>');
     dlist.add('<!ELEMENT DocType (#PCDATA)>');
     dlist.add('<!ELEMENT Title (#PCDATA)>');
     dlist.add('<!ELEMENT Creator (#PCDATA)>');
     dlist.add('<!ELEMENT Author (#PCDATA)>');
     dlist.add('<!ELEMENT Date (#PCDATA)>');
     dlist.add('<!ELEMENT Copyright (#PCDATA)>');
     dlist.add('<!ELEMENT Orientation (#PCDATA)>');
     dlist.add('<!ELEMENT Page (Item*)>');
     dlist.add('<!ELEMENT Item (#PCDATA)>');
     dlist.add('<!ELEMENT Contents (#PCDATA)>');
     dlist.add('<!ATTLIST Header Units CDATA "mm">');
     dlist.add('<!ATTLIST Header Pagewidth CDATA "210">');
     dlist.add('<!ATTLIST Header Pageheight CDATA "297">');
     dlist.add('<!ATTLIST Header PaperName CDATA "A4">');
     dlist.add('<!ATTLIST Header Layers CDATA "3">');
     dlist.add('<!ATTLIST Item Type CDATA "Text">');
     dlist.add('<!ATTLIST Item XPos CDATA "0">');
     dlist.add('<!ATTLIST Item YPos CDATA "0">');
     dlist.add('<!ATTLIST Item Font CDATA "Arial">');
     dlist.add('<!ATTLIST Item Height CDATA "12">');
     dlist.add('<!ATTLIST Item Color CDATA "Black">');
     dlist.add('<!ATTLIST Item BackColor CDATA "White">');
     dlist.add('<!ATTLIST Item Weight CDATA "Normal">');
     dlist.add('<!ATTLIST Item Decoration CDATA "None">');
     dlist.add('<!ATTLIST Item Width CDATA "1">');
     dlist.add('<!ATTLIST Item Height CDATA "1">');
     dlist.add('<!ATTLIST Item Shape CDATA "0">');
     dlist.add('<!-- 0=rect, 1=ellipse, 2=hline,3=vline,4=roundrect-->');
     dlist.add('<!ATTLIST Item Linewidth CDATA "1">');
     dlist.add('<!ATTLIST Item FillType CDATA "0">');
     dlist.add('<!ATTLIST Item Layer CDATA "0">');
     dlist.add('<!ATTLIST Item Opacity CDATA "1">');
     dlist.add('<!ATTLIST Item ImageFile CDATA "">');
     dlist.add('<!ATTLIST Item Compression CDATA "None">');
     dlist.add('<!ATTLIST Item Xscale CDATA "1.0">');
     dlist.add('<!ATTLIST Item Yscale CDATA "1.0">');
     dlist.add('<!ATTLIST Item Extra CDATA "">');
     dlist.add('<!ATTLIST Page Number CDATA "1">');
     dlist.add(']>');
end;

// strip off file extension
function basename( fname : string ) : string;
var
   p : integer;
begin
    basename := fname;
    p := pos( '.', fname );
    if p = 0 then exit;
    basename := copy( fname, 1, p - 1 );
end;

function EntityReplace( var ctext : string ) : string;
begin
     ctext :=  stringreplace( ctext, '&', '&amp;', [rfReplaceAll] ); // must be first
     ctext :=  stringreplace( ctext, '<', '&lt;', [rfReplaceAll] );
     ctext :=  stringreplace( ctext, '>', '&gt;', [rfReplaceAll] );
     ctext :=  stringreplace( ctext, '''', '&apos;', [rfReplaceAll] );
     ctext :=  stringreplace( ctext, '"', '&quot;', [rfReplaceAll] );
     result := ctext;