delphi vcl 定制组件实例

新建一个包工程：

unit ActiveButton;

interface

uses
  Windows,Graphics,Classes,Controls,ExtCtrls,Messages;
type
  TActiveButton = class(TCustomPanel)
  private
    FPicOnMouseDown: TPicture;
    FPicOnMouseIn: TPicture;
    FPicDisabled: TPicture;
    FPicNormal: TPicture;
    FPicture: TPicture;

    FAutoSize: Boolean;
    FTransparent: Boolean;

    FMouseInFlag: Boolean;
    FTimer: TTimer;
    procedure PictureChanged(Sender:TObject);
    procedure MouseOut();
    procedure TimerProc(Sender:TObject);

    procedure SetPicOnMouseIn(Value:TPicture);
    procedure SetPicOnMouseDown(Value : TPicture);
    procedure SetPicDisabled(Value: TPicture);
    procedure SetPicNormal(Value: TPicture);
  protected
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
      override;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;

    procedure SetEnabled(Value: Boolean); override;
    procedure SetTransparent(const Value: Boolean); virtual;
    procedure SetAutoSize(Value:Boolean);override;
    procedure Paint();override;
  public
    constructor Create(AOwner:TComponent);override;
    destructor Destroy();override;
  published
    property PicOnMouseIn:TPicture read FPicOnMouseIn write  SetPicOnMouseIn;
    property PicOnMouseDown : TPicture Read FPicOnMouseDown Write SetPicOnMouseDown;
    property PicDisabled : TPicture Read FPicDisabled Write SetPicDisabled;
    property PicNormal : TPicture Read FPicNormal Write SetPicNormal;

    property AutoSize : Boolean Read FAutoSize Write SetAutoSize;
    property Transparent : Boolean Read FTransparent Write SetTransparent default false;
    property Enabled;

    property OnClick;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;

  end;

procedure register;

implementation

procedure register;
begin
  RegisterComponents('wjhSoft',[TActiveButton]);
end;

{ TActiveButton }

constructor TActiveButton.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FPicOnMouseIn:=TPicture.Create;
  FPicOnMouseDown:=TPicture.Create;
  FPicDisabled:=TPicture.Create;
  FPicNormal:=TPicture.Create;

  FPicOnMouseIn.OnChange:=PictureChanged;
  FPicOnMouseDown.OnChange := PictureChanged;
  FPicDisabled.OnChange := PictureChanged;
  FPicNormal.OnChange := PictureChanged;
  FPicture:=FPicNormal;
  BevelOuter:=bvNone;
  Caption:=' ';

end;

destructor TActiveButton.Destroy;
begin
    FTimer.Free();
    FTimer := nil;

    FPicNormal.Free();
    FPicNormal := nil;

    FPicDisabled.Free();
    FPicDisabled := nil;

    FPicOnMouseDown.Free();
    FPicOnMouseDown := nil;

    FPicOnMouseIn.Free();
    FPicOnMouseIn := nil;

    FPicture := nil;

    inherited Destroy();
end;

procedure TActiveButton.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
begin
    if Button = mbLeft then
    begin
        if (
            Assigned(FPicOnMouseDown.Graphic) and
            Enabled
        ) then
        begin
            FPicture := FPicOnMouseDown;
            RePaint();
        end;
    end;

    inherited;
end;

procedure TActiveButton.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
    if (
        (X < 0) or
        (Y < 0) or
        (X > Width) or
        (Y > Height)
    ) then
    begin
        MouseOut();
        inherited;
        Exit;
    end;

    if (
        (FMouseInFlag) or
        (not Enabled) or
        (FPicOnMouseIn.Graphic = nil)
    ) then
    begin
        inherited;
        Exit;
    end;

    FMouseInFlag := true;

    if (
        Assigned(FPicOnMouseIn.Graphic) and
        Enabled
    ) then
    begin
        FPicture := FPicOnMouseIn;
        RePaint();
    end;

    if (
        (FTimer = nil) and
        Assigned(FPicOnMouseIn.Graphic)
    ) then
    begin
        FTimer := TTimer.Create(nil);
        FTimer.Interval := 168;
        FTimer.OnTimer := TimerProc;
    end;

    inherited;
end;

procedure TActiveButton.MouseOut;
begin
    FMouseInFlag := false;
    FTimer.Free;
    FTimer := nil;

    if Enabled then
        FPicture := FPicNormal
    else
        FPicture := FPicDisabled;
    RePaint();
end;

procedure TActiveButton.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
begin
    if (
        (X < 0) or
        (Y < 0) or
        (X > Width) or
        (Y > Height)
    ) then
        Exit;

    if Button = mbLeft then
    begin
        if (
            (FMouseInFlag) and
            (Assigned(FPicOnMouseIn.Graphic)) and
            Enabled
        ) then
            FPicture := FPicOnMouseIn
        else if Enabled then
            FPicture := FPicNormal
        else
            FPicture := FPicDisabled;

        RePaint();
    end;

    inherited;
end;

procedure TActiveButton.Paint;
var
    Rect : TRect;
begin
    if Assigned(FPicture.Graphic) then
    begin
        Canvas.Brush.Style := bsClear;
        Canvas.Font := Font;
        if FPicture.Graphic.Transparent <> FTransparent then
            FPicture.Graphic.Transparent := FTransparent;
        if FAutoSize then
        begin
            Height := FPicture.Height;
            Width := FPicture.Width;
        end;
        Canvas.StretchDraw(ClientRect, FPicture.Graphic);
        Rect := GetClientRect();
        DrawText(Canvas.Handle, PChar(Caption), -1, Rect, DT_CENTER or DT_SINGLELINE or DT_VCENTER);
    end
    else
        inherited Paint();
end;
procedure TActiveButton.PictureChanged(Sender: TObject);
begin
  Repaint;
end;

procedure TActiveButton.SetAutoSize(Value: Boolean);
begin

  FAutoSize := Value;
  RePaint();

end;

procedure TActiveButton.SetEnabled(Value: Boolean);
begin
    if (
        (not Value) and
        (Assigned(FPicDisabled.Graphic))
    ) then
        FPicture := FPicDisabled
    else
        FPicture := FPicNormal;

    RePaint();
    Inherited SetEnabled(Value);
end;

procedure TActiveButton.SetPicDisabled(Value: TPicture);
begin
    FPicDisabled.Assign(Value);

    RePaint();
end;

procedure TActiveButton.SetPicNormal(Value: TPicture);
begin

   FPicNormal.Assign(Value);
   RePaint();
end;

procedure TActiveButton.SetPicOnMouseDown(Value: TPicture);
begin
   FPicOnMouseDown.Assign(Value);
end;

procedure TActiveButton.SetPicOnMouseIn(Value: TPicture);
begin
   FPicOnMouseIn.Assign(Value);
end;

procedure TActiveButton.SetTransparent(const Value: Boolean);
begin
    FTransparent := Value;
    RePaint();
end;

procedure TActiveButton.TimerProc(Sender: TObject);
var
    CurPos : TPoint;
    LeftTop : TPoint;
    RightBottum : TPoint;
begin
    LeftTop.x := 0;
    LeftTop.y := 0;
    RightBottum.x := Width;
    RightBottum.y := Height;
    GetCursorPos(CurPos);

    if Parent <> nil then
    begin
        LeftTop := ClientToScreen(LeftTop);
        RightBottum := ClientToScreen(RightBottum);
    end
    else
        MouseOut();

    if (
        (CurPos.x > LeftTop.x)      and
        (CurPos.x < RightBottum.x)  and
        (CurPos.y > LeftTop.y)      and
        (CurPos.y < RightBottum.y)
    ) then
        Exit;   // in

    // out
    MouseOut();
end;

end.