Mega Code Archive
Bug fixed image printing under Win2000
<![CDATA[
Title: Bug fixed image printing under Win2000
Question: Image Printing under Windows 2000
Answer:
unit QRImg;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
QuickRpt;
type
TQRCustImage = class(TQRPrintable)
private
{ Private declarations }
FPicture: TPicture;
FAutoSize : Boolean;
procedure SetPicture(Value: TPicture);
procedure PictureChanged(Sender: TObject);
procedure SetAutoSize;
protected
{ Protected declarations }
public
{ Public declarations }
constructor Create(AOwner : TComponent); override;
destructor Destroy; override;
procedure Paint; override;
procedure Print(OfsX, OfsY : integer); override;
published
{ Published declarations }
property Picture: TPicture read FPicture write SetPicture;
property AutoSize : Boolean read FAutoSize write FAutoSize;
end;
procedure Register;
implementation
constructor TQRCustImage.Create(AOwner : TComponent);
begin
inherited Create(AOwner);
// ControlStyle := ControlStyle + [csReplicatable];
FPicture := TPicture.Create;
FPicture.OnChange := PictureChanged;
Height := 105;
Width := 105;
end;
destructor TQRCustImage.Destroy;
begin
inherited Destroy;
end;
procedure TQRCustImage.Paint;
begin
SetAutoSize;
Canvas.Draw(0, 0,FPicture.Bitmap);
end;
procedure TQRCustImage.Print(OfsX, OfsY : integer);
begin
ParentReport.QRPrinter.Canvas.Draw(Self.Left,Self.Top,FPicture.Bitmap);
end;
procedure TQRCustImage.PictureChanged(Sender: TObject);
var
G: TGraphic;
begin
if AutoSize and (Picture.Width 0) and (Picture.Height 0) then
SetBounds(Left, Top, Picture.Width, Picture.Height);
G := Picture.Graphic;
{ if G nil then
begin
if not ((G is TMetaFile) or (G is TIcon)) then
G.Transparent := FTransparent;
if (not G.Transparent) and (Stretch or (G.Width = Width)
and (G.Height = Height)) then
ControlStyle := ControlStyle + [csOpaque]
else
ControlStyle := ControlStyle - [csOpaque];
if DoPaletteChange and FDrawing then Update;
end
else ControlStyle := ControlStyle - [csOpaque];}
// if not FDrawing then
Invalidate;
SetAutoSize;
end;
procedure TQRCustImage.SetPicture(Value: TPicture);
begin
FPicture.Assign(Value);
end;
procedure TQRCustImage.SetAutoSize;
begin
if AutoSize and (FPicture.Bitmap.Width 0) and (FPicture.Bitmap.Height 0) then begin
Self.Height := FPicture.Bitmap.Height;
Self.Width := FPicture.Bitmap.Width;
end;
end;
procedure Register;
begin
RegisterComponents('Delphi 3.0 Components', [TQRCustImage]);
end;
end.
]]>