grimgctrl.pas

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

unit grimgctrl;
////////////////////////////////////////////////////////////////////////////
//  Unit : grimgctrl.pas
//
//  TQRPrintable -> TQRGrDBImage
//  TQRPrintable -> TQRGrImage
//  TQRPrintable -> TQRHRule
//  TQRPrintable -> TCustomHTMLLabel -> TQRHTMLLabel
//
//  New image controls - export to HTML and PDF export filters
//  New Hyper-text label
//  New Horizontal rule added FVertAdjust property
//  New PDFShape control
//  14th Nov. Changed Print method to scale images when 'stretch' is false.
//  18th Nov . Added keepwidth and keepheight
//  24th nov. - Fixed bug in Keeps.!!!
//  25th nov replaced keeps with FitMode
//  11th Jan 02 added another FitMode - InsideProp
//  (c) 2001 QBS Software
//  Revision to v3.7 of QR
////////////////////////////////////////////////////////////////////////////
interface
uses messages, windows, classes, controls, stdctrls,sysutils, graphics, buttons,
     forms, extctrls, dialogs, printers, db, DBtables, ComCtrls, RichEdit,
     QRPrntr, Quickrpt, QR4Const, qrexpr, qrctrls, qrlabled;

const
  BreakChars : set of Char = [' ', #13, '-'];
type

  TQRFixFrame = class(TQRFrame);

  TLinkDef = ( ldHTTPJump, ldNameJump, ldNameLabel );
  TFitMode = ( fmProportional, fmKeepWidth, fmKeepHeight, fmInsideProp );
{ TQRCustomHTMLLabel - base class for printable HTML text components }
  TQRCustomHTMLLabel = class(TQRPrintable)
  private
    FCaptionBased : boolean;
    DoneFormat : boolean;
    FAutoSize : boolean;
    FAutoStretch : boolean;
    FCaption : string;
    FPrintCaption : string;
    FFontSize : integer;
    FFormattedLines : TStrings;
    FLines : TStrings;
    FOnPrint : TQRLabelOnPrintevent;
    FWordWrap : boolean;
    FShowOnDocs : boolean;
    UpdatingBounds : boolean;
    function GetCaption : string;
    function GetCaptionBased : boolean; virtual;
    procedure SetAutoStretch(Value : boolean);
    procedure SetCaption(Value : string);
    procedure SetLines(Value : TStrings);
    procedure SetWordWrap(Value : boolean);
    procedure PaintToCanvas(aCanvas : TCanvas; aRect : TRect; CanExpand : boolean; LineHeight : integer);
    procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
  protected
    procedure PrintToCanvas(aCanvas : TCanvas; aLeft, aTop, aWidth, aHeight, LineHeight : extended;
                            CanExpand : boolean); virtual;
    procedure FormatLines; virtual;
    procedure Loaded; override;
    procedure SetName(const Value: TComponentName); override;
    procedure SetParent(AParent: TWinControl); override;
    procedure DefineProperties(Filer: TFiler); override;
    procedure ReadFontSize(Reader : TReader); virtual;
    procedure WriteFontSize(Writer : TWriter); virtual;
    procedure Paint; override;
    procedure Prepare; override;
    procedure Unprepare; override;
    procedure Print(OfsX, OfsY : integer); override;
    procedure SetAlignment(Value : TAlignment); override;
    property OnPrint : TQRLabelOnPrintEvent read FOnPrint write FOnPrint;
  public
    constructor Create(AOwner : TComponent); override;
    destructor Destroy; override;
    function GetControlsAlignment: TAlignment; override;
    property CaptionBased : boolean read GetCaptionBased;
    property Alignment;
    property AutoSize : boolean read FAutoSize write FAutoSize;
    property AutoStretch : boolean read FAutoStretch write SetAutoStretch;
    property Caption : string read GetCaption write SetCaption stored true;
    property Color;
    property Font;
    property Lines : TStrings read FLines write SetLines;
    property WordWrap : boolean read FWordWrap write SetWordWrap;
    property ShowOnDocs : boolean read FShowOnDocs write FShowOnDocs;
  end;

  TQRHTMLLabel = class(TQRCustomHTMLLabel)
  protected
    function GetEditorClass : TQRPrintableEditorClass; override;
    procedure PrintToCanvas(aCanvas : TCanvas; aLeft, aTop, aWidth, aHeight,
                        LineHeight : extended; CanExpand : boolean);override;
  public
     FFlashColor : TColor;
     FLinkText : string;
     FLinkType : TLinkDef;
  published
    // 4 new
    property Flashcolor : TColor read FFlashcolor write FFlashcolor;
    property LinkText : string read FLinkText write FLinkText;
    property LinkType : TLinkDef read FLinkType write FLinkType;
    // inherited
    property Alignment;
    property AlignToBand;
    property AutoSize;
    property AutoStretch;
    property BiDiMode;
    property ParentBiDiMode;
    property Caption;
    property Color;
    property Font;
    property OnPrint;
    property ParentFont;
    property Transparent;
    property WordWrap;
    property ShowOnDocs;
  end;

  TQRHRule = class(TQRPrintable)
  private
    FBrush : TBrush;
    FPen : TPen;
    FVertAdjust : integer;
    procedure SetBrush(Value : TBrush);
    procedure SetPen(Value : TPen);
  protected
    procedure Paint; override;
    procedure Print(OfsX, OfsY : integer); override;
    procedure StyleChanged(sender : TObject);
  public
    constructor Create(AOwner : TComponent); override;
    destructor Destroy; override;
  published
    property VertAdjust : integer read FVertAdjust write FVertAdjust;
    property Brush : TBrush read FBrush write SetBrush;
    property Height default 10;
    property Pen : TPen read FPen write Setpen;
    property Width default 100;
  end;

  {TQRPDFShape}
  TQRPDFShape = class(TQRPrintable)
  private
    FBrush : TBrush;
    FPen : TPen;
    FVertAdjust : integer;
    FShapeType : TQRShapetype;
    procedure SetBrush(Value : TBrush);
    procedure SetPen(Value : TPen);
  protected
    procedure Paint; override;
    procedure Print(OfsX, OfsY : integer); override;
    procedure StyleChanged(sender : TObject);
  public
    constructor Create(AOwner : TComponent); override;
    destructor Destroy; override;
  published
    property VertAdjust : integer read FVertAdjust write FVertAdjust;
    property Brush : TBrush read FBrush write SetBrush;
    property ShapeType : TQRShapetype read FShapeType write FShapeType;
    property Height default 10;
    property Pen : TPen read FPen write Setpen;
    property Width default 100;
  end;

{ TQRGrImage }
  TQRGrImage = class(TQRPrintable)
  private
    FPicture: TPicture;
    FAutoSize: Boolean;
    FStretch: Boolean;
    FCenter: Boolean;
    FClipImage : Boolean;
    function GetCanvas: TCanvas;
    procedure PictureChanged(Sender: TObject);
    procedure SetCenter(Value: Boolean);
    procedure SetPicture(Value: TPicture);
    procedure SetStretch(Value: Boolean);
  protected
    procedure SetAutoSize(Value: Boolean);override;
    function GetPalette: HPALETTE; override;
    procedure Paint; override;
    procedure Print(OfsX, OfsY : integer); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property Canvas: TCanvas read GetCanvas;
  published
    property ClipImage: Boolean read FClipImage write FClipImage default False;
    property AutoSize: Boolean read FAutoSize write SetAutoSize default False;
    property Center: Boolean read FCenter write SetCenter default False;
    property Picture: TPicture read FPicture write SetPicture;
    property Stretch: Boolean read FStretch write SetStretch default False;
  end;
  { TQRGrDBImage }
  TQRGrDBImage = class(TQRPrintable)
  private
    FField : TField;
    FDataSet : TDataSet;
    FDataField : string;
    FPicture: TPicture;
    FStretch: boolean;
    FCenter: boolean;
    FPictureLoaded: boolean;
    FClipImage : Boolean;
    FKeepWidth : Boolean;
    FKeepHeight : Boolean;
    FFitMode : TFitMode;
    procedure PictureChanged(Sender: TObject);
    procedure SetCenter(Value: Boolean);
    procedure SetDataField(const Value: string);
    procedure SetDataSet(Value: TDataSet);
    procedure SetPicture(Value: TPicture);
    procedure SetStretch(Value: Boolean);
  protected
    function GetPalette: HPALETTE; override;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure Paint; override;
    procedure Prepare; override;
    procedure Print(OfsX, OfsY : integer); override;
    procedure UnPrepare; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure LoadPicture;
    property Field: TField read FField;
    property Picture: TPicture read FPicture write SetPicture;
  published
    property Center: boolean read FCenter write SetCenter default True;
    property DataField: string read FDataField write SetDataField;
    property DataSet: TDataSet read FDataSet write SetDataSet;
    property Stretch: boolean read FStretch write SetStretch default False;
    property ClipImage: Boolean read FClipImage write FClipImage default False;
    property FitMode : TFitMode read FFitMode write FFitMode default fmProportional;
  end;

implementation
uses QRWebFilt, QRPDFfilt;

{ TQRHRule }
constructor TQRHRule.Create(AOwner : TComponent);
begin
  inherited Create(AOwner);
  width := 100;
  Height := 10;
  FVertAdjust := 0;
  FPen := TPen.Create;
  FBrush := TBrush.Create;
  FBrush.OnChange := StyleChanged;
  FPen.OnChange := StyleChanged;
end;

procedure TQRHRule.StyleChanged(Sender : TObject);
begin
  invalidate;
end;

procedure TQRHRule.SetBrush(Value : TBrush);
begin
  FBrush.Assign(Value);
end;

procedure TQRHRule.SetPen(Value : TPen);
begin
  FPen.Assign(value);
end;

procedure TQRHRule.Paint;
begin
  inherited paint;
  with Canvas do
  begin
    Pen := FPen;
    Brush := FBrush;
    MoveTo(0,Height div 2);
    LineTo(Width,Height div 2);
  end;
end;

procedure TQRHRule.Print(OfsX,OfsY : Integer);
begin
  if parentreport.Exporting then
  begin
         // alter ypos to be same as moveto...
         if (ParentReport.ExportFilter is TQRGHTMLDocumentFilter) then
         TQRGHTMLDocumentFilter(ParentReport.ExportFilter).acceptgraphic(
                              qrprinter.XPos(OfsX + self.Size.Left),
                              qrprinter.YPos(OfsY + self.size.top), self )
         else if (ParentReport.ExportFilter is TQRPDFDocumentFilter) then
         TQRPDFDocumentFilter(ParentReport.ExportFilter).acceptgraphic(
                              qrprinter.XPos(OfsX + self.Size.Left),
                              qrprinter.YPos(OfsY+ self.size.top ), self );
  end;


  if ParentReport.FinalPass and IsEnabled then
  begin
    QRPrinter.Canvas.Brush := Brush;
    QRPrinter.Canvas.Pen := Pen;
    with QRPrinter do
    begin
      with Canvas do
      begin
          MoveTo(XPos(OfsX + Size.Left), YPos(OfsY + Size.Top + self.size.height/2));
          LineTo(XPos(OfsX + Size.Left + Size.Width),YPos(OfsY + Size.Top+ self.size.height/2));
        end;
      end;
    end;
end;

destructor TQRHRule.Destroy;
begin
  FPen.Free;
  FBrush.Free;
  inherited Destroy;
end;

{ TQRPDFShape }
constructor TQRPDFShape.Create(AOwner : TComponent);
begin
  inherited Create(AOwner);
  width := 100;
  Height := 10;
  FVertAdjust := 0;
  FPen := TPen.Create;
  FBrush := TBrush.Create;
  FBrush.OnChange := StyleChanged;
  FPen.OnChange := StyleChanged;
end;

procedure TQRPDFShape.StyleChanged(Sender : TObject);
begin
  invalidate;
end;

procedure TQRPDFShape.SetBrush(Value : TBrush);
begin
  FBrush.Assign(Value);
end;

procedure TQRPDFShape.SetPen(Value : TPen);
begin
  FPen.Assign(value);
end;
procedure TQRPDFShape.Paint;
begin
  inherited paint;
  with Canvas do
  begin
    Pen := FPen;
    Brush := FBrush;
    Case FShapeType of
      qrsRectangle : Rectangle(pen.width,pen.width,Width,Height);
      qrsCircle : Ellipse(0,0,Width,Height);
      qrsHorLine : begin
          MoveTo(0,Height div 2);
          LineTo(Width,Height div 2);
        end;
      qrsVertLine : begin
          MoveTo(Width div 2,0);
          LineTo(Width div 2,Height);
        end;
      qrsTopAndBottom : begin
          MoveTo(0,0);
          LineTo(Width,0);
          MoveTo(0,Height-1);
          LineTo(Width,Height-1);
        end;
      qrsRightAndLeft : begin
          MoveTo(0,0);
          LineTo(0,Height);
          MoveTo(Width-1,0);
          LineTo(Width-1,Height);
        end;
    end
  end
end;

procedure TQRPDFShape.Print(OfsX,OfsY : Integer);
begin
  if parentreport.Exporting then
  begin
         if (ParentReport.ExportFilter is TQRPDFDocumentFilter) then
         TQRPDFDocumentFilter(ParentReport.ExportFilter).acceptgraphic(
                              qrprinter.XPos(OfsX + self.Size.Left),
                              qrprinter.YPos(OfsY+ self.size.top ), self );
  end;

  if ParentReport.FinalPass and IsEnabled then
  begin
    QRPrinter.Canvas.Brush := Brush;
    QRPrinter.Canvas.Pen := Pen;
    with qrprinter do begin
      with canvas do begin
       case FShapetype of
          qrsRectangle : Rectangle(XPos(OfsX + Size.Left), YPos(OfsY + Size.Top),
            XPos(OfsX+Size.Left + Size.Width), YPos(OfsY + Size.Top + Size.Height));
          qrsCircle : Ellipse(XPos(OfsX + Size.Left), YPos(OfsY + Size.Top),
            XPos(OfsX+Size.Left + Size.Width), YPos(OfsY + Size.Top + Size.Height));
          qrsHorLine : begin
              MoveTo(XPos(OfsX + Size.Left), YPos(OfsY + Size.Top + Size.Height / 2));
              LineTo(XPos(OfsX + Size.Left + Size.Width),YPos(OfsY + Size.Top + Size.Height/2));
            end;
          qrsVertLine : begin
              MoveTo(XPos(OfsX+Size.Left + Size.Width / 2), YPos(OfsY + Size.Top));
              LineTo(XPos(OfsX+Size.Left + Size.Width / 2), Ypos(OfsY + Size.Height + Size.Top));
            end;
          qrsTopAndBottom : begin
              MoveTo(XPos(OfsX + Size.Left), YPos(OfsY + Size.Top));
              LineTo(Xpos(OfsX + Size.Left + Size.Width), YPos(OfsY + Size.Top));
              MoveTo(Xpos(OfsX + Size.Left), YPos(OfsY + Size.Top + Size.Height));
              LineTo(Xpos(OfsX + Size.Left + Size.Width), Ypos(OfsY + Size.Top + Size.Height));
            end;
          qrsRightAndLeft : Begin
              MoveTo(XPos(OfsX + Size.Left), YPos(OfsY + Size.Top));
              LineTo(Xpos(OfsX + Size.Left), YPos(OfsY + Size.Top + Size.Height));
              MoveTo(XPos(OfsX + Size.Left + Size.Width), YPos(OfsY + Size.Top));
              LineTo(XPos(OfsX + Size.Left + Size.Width), YPos(OfsY + Size.Top + Size.Height));
            end;
        end
       end;
      end;
     end;
end;

destructor TQRPDFShape.Destroy;
begin
  FPen.Free;
  FBrush.Free;
  inherited Destroy;
end;

{ TQRGRImage }
  procedure PrintBitmap(aCanvas : TCanvas; Dest : TRect; Bitmap : TBitmap);
  var
    Info : PBitmapInfo;
    InfoSize : DWORD;
    Image : Pointer;
    ImageSize : DWord;
  begin
    with Bitmap do
    begin
      GetDIBSizes(Handle, InfoSize, ImageSize);
      Info := AllocMem(InfoSize);
      try
        Image := AllocMem(ImageSize);
        try
          GetDIB(Handle, Palette, Info^, Image^);
          if not Monochrome then
            SetStretchBltMode(ACanvas.Handle, STRETCH_DELETESCANS);
          with Info^.bmiHeader do
            StretchDIBits(aCanvas.Handle, Dest.Left, Dest.Top,
              Dest.RIght - Dest.Left, Dest.Bottom - Dest.Top,
              0, 0, biWidth, biHeight, Image, Info^, DIB_RGB_COLORS, SRCCOPY);
        finally
          FreeMem(Image, ImageSize);
        end;
      finally
        FreeMem(Info, InfoSize);
      end;
    end;
  end;

constructor TQRGRImage.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FPicture := TPicture.Create;
  FPicture.OnChange := PictureChanged;
  Height := 105;
  Width := 105;
end;

destructor TQRGRImage.Destroy;
begin