程序代码如下所示：

unit HImage;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls;

type
THImage = class(TGraphicControl)
private
{ Private declarations }
FPictureNormal:TPicture;
FPictureHot:TPicture;
FPicture:TPicture;
FOnProgress: TProgressEvent;
FStretch: Boolean;
FCenter: Boolean;
FIncrementalDisplay: Boolean;
FTransparent: Boolean;
FDrawing: Boolean;
function GetCanvas: TCanvas;
procedure PictureChanged(Sender: TObject);
procedure SetCenter(Value: Boolean);
procedure SetStretch(Value: Boolean);
procedure SetTransparent(Value: Boolean);
procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
procedure CMMouseLeave(var Message:TMessage); message CM_MOUSELEAVE;
procedure SetPictureNormal(value:TPicture);
procedure SetPictureHot(value:TPicture);
procedure SetPicture(value:Tpicture);
protected
{ Protected declarations }
function CanAutoSize(var NewWidth, NewHeight: Integer): Boolean; override;
function DestRect: TRect;
function DoPaletteChange: Boolean;
function GetPalette: HPALETTE; override;
procedure Paint; override;
procedure Progress(Sender: TObject; Stage: TProgressStage;
PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string); dynamic;
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
property Picture:TPicture read FPicture write SetPicture;
property Canvas: TCanvas read GetCanvas;
published
{ Published declarations }
property Align;
property Anchors;
property AutoSize;
property Center: Boolean read FCenter write SetCenter default False;
property Constraints;
property DragCursor;
property DragKind;
property DragMode;
property Enabled;
property IncrementalDisplay: Boolean read FIncrementalDisplay write FIncrementalDisplay default False;
property ParentShowHint;
property PopupMenu;
property ShowHint;
property Stretch: Boolean read FStretch write SetStretch default False;
property Transparent: Boolean read FTransparent write SetTransparent default False;
property Visible;
property OnClick;
// property OnContextPopup;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDock;
property OnEndDrag;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnProgress: TProgressEvent read FOnProgress write FOnProgress;
property OnStartDock;
property OnStartDrag;
property PictureNormal:TPicture read FPictureNormal Write SetPictureNormal;
property PictureHot:TPicture read FPictureHot Write SetPictureHot;
end;

procedure Register;

implementation

constructor THImage.Create(AOwner: TComponent);
begin
   inherited Create(AOwner);
   ControlStyle := ControlStyle + [csReplicatable];
   FPictureNormal := TPicture.Create;
   FPictureHot := TPicture.Create;
   FPicture := TPicture.Create;
   FPicture.OnChange := PictureChanged;
   FPicture.OnProgress := Progress;
   Height := 105;
   Width := 105;
end;

destructor THImage.Destroy;
begin
   FPicture.Free;
   inherited Destroy;
end;

function THImage.GetPalette: HPALETTE;
begin
Result := 0;
if FPicture.Graphic <> nil then
Result := FPicture.Graphic.Palette;
end;

procedure THImage.SetPictureNormal(value:TPicture);
begin
FPictureNormal.Assign(value);
FPicture.Assign(value);
end;

procedure THImage.SetPictureHot(value:TPicture);
begin
FPictureHot.Assign(value);
end;

function THImage.DestRect: TRect;
begin
if Stretch then
   Result := ClientRect
    else if Center then
       Result := Bounds((Width - Picture.Width) div 2, (Height - Picture.Height) div 2,Picture.Width, Picture.Height)
   else
Result := Rect(0, 0, Picture.Width, Picture.Height);
end;

procedure THImage.Paint;
var
Save: Boolean;
begin
if csDesigning in ComponentState then
   with inherited Canvas do
     begin
       Pen.Style := psDash;
       Brush.Style := bsClear;
       Rectangle(0, 0, Width, Height);
     end;
       Save := FDrawing;
       FDrawing := True;
      try
    with inherited Canvas do
   StretchDraw(DestRect, Picture.Graphic);
 finally
FDrawing := Save;
end;
end;

function THImage.DoPaletteChange: Boolean;
var
ParentForm: TCustomForm;
Tmp: TGraphic;
begin
   Result := False;
   Tmp := Picture.Graphic;
   if Visible and (not (csLoading in ComponentState)) and (Tmp <> nil) and(Tmp.PaletteModified) then
   begin
     if (Tmp.Palette = 0) then
     Tmp.PaletteModified := False
   else
begin
 ParentForm := GetParentForm(Self);
  if Assigned(ParentForm) and ParentForm.Active and Parentform.HandleAllocated then
    begin
      if FDrawing then
         ParentForm.Perform(wm_QueryNewPalette, 0, 0)
      else
          PostMessage(ParentForm.Handle, wm_QueryNewPalette, 0, 0);
          Result := True;
        Tmp.PaletteModified := False;
      end;
     end;
  end;
end;

procedure THImage.Progress(Sender: TObject; Stage: TProgressStage;
PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string);
begin
  if FIncrementalDisplay and RedrawNow then
     begin
       if DoPaletteChange then Update
       else Paint;
     end;
  if Assigned(FOnProgress) then FOnProgress(Sender, Stage, PercentDone, RedrawNow, R, Msg);
end;

function THImage.GetCanvas: TCanvas;
var
Bitmap: TBitmap;
begin
if Picture.Graphic = nil then
begin
   Bitmap := TBitmap.Create;
   try
   Bitmap.Width := Width;
   Bitmap.Height := Height;
   Picture.Graphic := Bitmap;
   finally
   Bitmap.Free;
end;
end;
if Picture.Graphic is TBitmap then
Result := TBitmap(Picture.Graphic).Canvas;

end;

procedure THImage.SetCenter(Value: Boolean);
begin
if FCenter <> Value then
   begin
     FCenter := Value;
     PictureChanged(Self);
   end;
end;

procedure THImage.SetPicture(Value: TPicture);
begin
   FPicture.Assign(Value);
end;

procedure THImage.SetStretch(Value: Boolean);
begin
if Value <> FStretch then
  begin
    FStretch := Value;
    PictureChanged(Self);
  end;
end;

procedure THImage.SetTransparent(Value: Boolean);
begin
  if Value <> FTransparent then
   begin
      FTransparent := Value;
     PictureChanged(Self);
   end;
end;

procedure THImage.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;
end;

function THImage.CanAutoSize(var NewWidth, NewHeight: Integer): Boolean;
begin
   Result := True;
    if not (csDesigning in ComponentState) or (Picture.Width > 0) and (Picture.Height > 0) then
begin
    if Align in [alNone, alLeft, alRight] then
       NewWidth := Picture.Width;
    if Align in [alNone, alTop, alBottom] then
       NewHeight := Picture.Height;
end;
end;

procedure THImage.CMMouseLeave(var Message:TMessage);
begin
   inherited;
     if FPicture<>FPictureNormal then
      Picture.Assign(FPictureNormal);
end;

procedure THImage.CMMouseEnter(var Message: TMessage);
begin
  inherited;
    if FPicture<>FPictureHot then
      Picture.Assign(FPictureHot);
end;

procedure Register;
begin
     RegisterComponents('Lee', [THImage]);
end;

end.