Графическая кнопка

Исходный код компонента:

unit Bibutton;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, 
  Graphics, Controls, Forms, ExtCtrls;

type
  TBiButton = class(TCustomControl)
  private
    FTPicture : TPicture;
    FPPicture : TPicture;
    FOnPaint  : TNotifyEvent;
    FRegion   : THandle;
    FBRegion  : THandle;
    FBorder   : Boolean;
    FOffset   : Integer;
    FCaption  : String;

    FXRad,
    FYRad     : Integer;

    Down,
    Pressed   : Boolean;

    procedure SetTPicture (Value : TPicture);
    procedure SetPPicture (Value : TPicture);
    procedure SetXRadius (Value : Integer);
    procedure SetYRadius (Value : Integer);
    procedure SetBorder (Value : Boolean);
    procedure PictureChanged(Sender : TObject);
    procedure WM_LButtonDown (var Msg : TWMLButtonDown);
        message wm_LButtonDown;
    procedure WM_LButtonUp (var Msg : TWMLButtonUp);
        message wm_LButtonUp;
    procedure WM_MouseMove (var Msg : TWMMouseMove);
        message wm_MouseMove;
    procedure WM_Size (var Msg : TWMSize);
        message wm_Size;
    procedure SetRegion;
    procedure SetOffest(const Value: Integer);
    procedure SetCaption(const Value: String);

  public
    constructor Create (AOwner : TComponent); override;
    destructor Destroy; override;
    property Canvas;

  protected
    function GetPalette : HPalette; override;
    procedure Paint; override;

  published
    // "не нажатое изображение"
    property TopPicture : TPicture read FTPicture write SetTPicture;
    // "нажатое изображение" - если нет, будет использоваться TopPicture
    property PressedPicture : TPicture read FPPicture write SetPPicture;
    // для круглых кнопок
    property XRadius : Integer read FXRad write SetXRadius;
    property YRadius : Integer read FYRad write SetYRadius;
    // показывать грагицу кнопки или нет
    property Border : Boolean read FBorder write SetBorder;
    // смещение "нажатого изображения"
    property Offset : Integer read FOffset write SetOffest;
    property Caption : String read FCaption write SetCaption;

    property Color;
    property Font;
    property Align;
    property Visible;
    property ShowHint;
    property Enabled;
    property ParentColor;
    property ParentFont;
    property ParentShowHint;
    property TabOrder;
    property OnClick;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEnter;
    property OnExit;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('GBit', [TBiButton]);
end;

constructor TBiButton.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FRegion := 0;
  FBRegion := 0;
  ControlStyle := [csCaptureMouse, csClickEvents];
  FTPicture := TPicture.Create;
  FTPicture.OnChange := PictureChanged;
  FPPicture := TPicture.Create;
  FPPicture.OnChange := PictureChanged;
  FBorder := True;
  Height := 100;
  Width := 100;
  XRadius := Width;
  YRadius := Height;
  Offset := 2;
  Pressed := False;
end;

destructor TBiButton.Destroy;
begin
  FTPicture.Free;
  FPPicture.Free;
  DeleteObject (FRegion);
  DeleteObject (FBRegion);
  inherited Destroy;
end;

function TBiButton.GetPalette: HPalette;
begin
  Result := 0;
  if FTPicture.Graphic is TBitmap then
    Result := TBitmap(FTPicture.Graphic).Palette;
end;

procedure TBiButton.SetTPicture(Value: TPicture);
begin
  FTPicture.Assign(Value);
end;

procedure TBiButton.SetPPicture(Value: TPicture);
begin
  FPPicture.Assign(Value);
end;

procedure TBiButton.Paint;
var
  Rect  : TRect;
  Ha    : HDC;
  ps    : TPaintStruct;
  x, y  : Integer;
  R, rx,
  G, gx,
  B, bx : Word;
  AColor,
  LightC,
  DarkC : TColor;
begin
  Rect := GetClientRect;
  InvalidateRgn (Handle, FRegion, False);
  try
    SetWindowRgn (Self.Handle, FBRegion, True);
  except
  end;

  if Color < 0 then begin
    AColor := GetSysColor (Color and $00FFFFFF);
  end else
    AColor := Color;

  R := GetRValue (AColor);
  G := GetGValue (AColor);
  B := GetBValue (AColor);

  rx := Round ((255-R) * 0.5);
  gx := Round ((255-G) * 0.5);
  bx := Round ((255-B) * 0.5);
  LightC := RGB (R+rx, G+gx, B+bx);

  rx := Round (R * 0.3);
  gx := Round (G * 0.3);
  bx := Round (B * 0.3);
  darkC := RGB (R-rx, G-gx, B-bx);

  Ha := BeginPaint (Handle, ps);
  Canvas.Handle := Ha;
  if not Down then begin
    with Canvas do begin
      if FTPicture.Graphic is TBitmap then begin
        Brush.Color := AColor;
        FillRect(Rect);
        Draw (0, 0, FTPicture.Graphic);
      end else begin
        Brush.Color := AColor;
        FillRect(Rect);
      end;
      if Border then begin
        Brush.Style := bsClear;
        Pen.Width := 2;
        Pen.Color := LightC;
        RoundRect (2, 2, Width, Height, XRadius, YRadius);
        Pen.Width := 2;
        Pen.Color := DarkC;
        RoundRect (0, 0, Width, Height, XRadius, YRadius);
      end;
      Font := Self.Font;
      x := (Width - TextWidth (Caption)) div 2;
      y := (Height - TextHeight (Caption)) div 2;
      TextOut (x, y, Caption);
    end;
  end else begin
    with Canvas do begin
      if FPPicture.Graphic is TBitmap then begin
        Brush.Color := AColor;
        FillRect(Rect);
        Draw (Offset, Offset, FPPicture.Graphic);
      end else begin
        Brush.Color := AColor;
        FillRect(Rect);
      end;
      if Border then begin
        Brush.Style := bsClear;
        Pen.Width := 2;
        Pen.Color := LightC;
        RoundRect (0, 0, Width-2, Height-2, XRadius, YRadius);
        Pen.Width := 4;
        Pen.Color := DarkC;
        RoundRect (0, 0, Width, Height, XRadius, YRadius);
      end;
      Font := Self.Font;
      x := (Width - TextWidth (Caption)) div 2;
      y := (Height - TextHeight (Caption)) div 2;
      TextOut (x+1, y+1, Caption);
    end;
  end;
  EndPaint (Ha, ps);
end;

procedure TBiButton.PictureChanged(Sender: TObject);
begin
  if (FTPicture.Graphic is TBitmap) and (FTPicture.Width = Width) and
    (FTPicture.Height = Height) then
    ControlStyle := ControlStyle + [csOpaque] else
    ControlStyle := ControlStyle - [csOpaque];
  if (FPPicture.Graphic is TBitmap) and (FPPicture.Width = Width) and
    (FPPicture.Height = Height) then
    ControlStyle := ControlStyle + [csOpaque] else
    ControlStyle := ControlStyle - [csOpaque];
  Invalidate;
end;

procedure TBiButton.WM_LButtonDown (var Msg : TWMLButtonDown);
begin
  Pressed := PtInRegion (FRegion, Msg.xPos, Msg.yPos);
  if Pressed then begin
    Down := Pressed;
    SetCapture (Handle);
    Invalidate;
  end;
  inherited;
end;

procedure TBiButton.WM_LButtonUp (var Msg : TWMLButtonUp);
begin
  if not Pressed then
    exit;
  Pressed := False;
  Down := Pressed;
  ReleaseCapture;
  Invalidate;
  inherited;
end;

procedure TBiButton.WM_MouseMove (var Msg : TWMMouseMove);
var
   D : Boolean;
begin
  D := PtInRegion (FRegion, Msg.xPos, Msg.yPos);
  if Pressed then begin
    if D <> Down then begin
      Down := D;
      Invalidate;
    end;
  end;
  inherited;
end;

procedure TBiButton.SetYRadius (Value : Integer);
begin
  if Value > Height then
    Value := Height;
  if Value <> YRadius then begin
    FYRad := Value;
    SetRegion;
    Invalidate;
  end;
end;

procedure TBiButton.SetXRadius (Value : Integer);
begin
  if Value > Width then
    Value := Width;
  if Value <> XRadius then begin
    FXRad := Value;
    SetRegion;
    Invalidate;
  end;
end;

procedure TBiButton.SetRegion;
begin
  DeleteObject (FRegion);
  DeleteObject (FBRegion);
  if XRadius > Width then
    FXRad := Width;
  if YRadius > Height then
    FYRad := Height;
  FRegion := CreateRoundRectRgn (0, 0, Width+1, Height+1, XRadius, YRadius);
  FBRegion := CreateRoundRectRgn (0, 0, Width+1, Height+1, XRadius, YRadius);
end;

procedure TBiButton.WM_Size (var Msg : TWMSize);
begin
  SetRegion;
  Invalidate;
end;

procedure TBiButton.SetBorder (Value : Boolean);
begin
  if Value <> FBorder then begin
    FBorder := Value;
    Invalidate;
  end;
end;

procedure TBiButton.SetOffest(const Value: Integer);
begin
  FOffset := Value;
  Invalidate;
end;

procedure TBiButton.SetCaption(const Value: String);
begin
  FCaption := Value;
  Invalidate;
end;

end.