Kod
{
  A button which states are indicated by bitmap images.
  @author Derek van Daal
  @version 1.0
}
unit BitmapButton;
 
interface
 
uses
  SysUtils, Messages, Classes, Graphics, Controls, StdCtrls;
 
type
  TBitmapButton = class(TGraphicControl)
  private
    FAutoSize: Boolean;
    FBmpDisabled: TBitmap;
    FBmpHot: TBitmap;
    FBmpNormal: TBitmap;
    FBmpPressed: TBitmap;
    FCurrentBitmap: TBitmap;
    FHotTrack: Boolean;
    FMousePressed: Boolean;
    FMouseInControl: Boolean;
    FTransparent: Boolean;
    FTransparentColor: TColor;
    procedure SetAutoSize(Value: Boolean);
    procedure SetBmpDisabled(Value: TBitmap);
    procedure SetBmpHot(Value: TBitmap);
    procedure SetBmpNormal(Value: TBitmap);
    procedure SetBmpPressed(Value: TBitmap);
    procedure SetTransparent(Value: Boolean);
    procedure SetTransparentColor(Value: TColor);
    { Private declarations }
  protected
    procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
    procedure CMMouseEnter(var msg : TMessage); message CM_MOUSEENTER;
    procedure CMMouseLeave(var msg : TMessage); message CM_MOUSELEAVE;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure Paint; override;
    { Protected declarations }
  public
    constructor Create(AOwner : TComponent); override;
    destructor Destroy; override;
    { Public declarations }
  published
    property Action;
    property Anchors;
    property AutoSize: Boolean read FAutoSize write SetAutoSize;
    property BiDiMode;
    property BmpDisabled: TBitmap read FBmpDisabled write SetBmpDisabled;
    property BmpHot: TBitmap read FBmpHot write SetBmpHot;
    property BmpNormal: TBitmap read FBmpNormal write SetBmpNormal;
    property BmpPressed: TBitmap read FBmpPressed write SetBmpPressed;
    property Constraints;
    property Enabled;
    property HotTrack: Boolean read FHotTrack write FHotTrack;
    property ParentShowHint;
    property ParentBiDiMode;
    property PopupMenu;
    property ShowHint;
    property Transparent: Boolean read FTransparent write SetTransparent;
    property TransparentColor: TColor read FTransparentColor write SetTransparentColor;
    property Visible;
    property OnClick;
    property OnDblClick;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    { Published declarations }
  end;
 
procedure Register;
 
implementation
 
{--------------------------------------------------------------------}
{
  Constructs and initializes the LabelButton component.
  @param AOwner the LabelButton's owner component
}
constructor TBitmapButton.Create(AOwner : TComponent);
begin
  inherited Create(AOwner);
  FAutoSize := True;
  FBmpDisabled := TBitmap.Create;
  FBmpHot := TBitmap.Create;
  FBmpNormal := TBitmap.Create;
  FBmpPressed := TBitmap.Create;
  FCurrentBitmap := FBmpNormal;
  FHotTrack := False;
  FMousePressed := False;
  FMouseInControl := False;
  FTransparent := False;
  FTransparentColor := clNone;
  Width := 25;
  Height := 25;
end;
{--------------------------------------------------------------------}
{
  Frees the LabelButton component from memory.
}
destructor TBitmapButton.Destroy;
begin
  FBmpPressed.Free;
  FBmpNormal.Free;
  FBmpHot.Free;
  FBmpDisabled.Free;
  inherited Destroy;
end;
{--------------------------------------------------------------------}
{
  Sets the current image to the disabled image as
  the EnabledChanged message is dispatched.
  @param Message the message directive
}
procedure TBitmapButton.CMEnabledChanged(var Message: TMessage);
begin
  inherited;
  if not Enabled then
    FCurrentBitmap := FBmpDisabled
  else
    FCurrentBitmap := FBmpNormal;
  Repaint;
end;
{--------------------------------------------------------------------}
{
  Sets the current image to the normal/hot image
  as the MouseEnter message is dispatched.
  @param Message the message directive
}
procedure TBitmapButton.CMMouseEnter(var Msg: TMessage);
begin
  inherited;
  FMouseInControl := True;
  if Enabled then
    begin
      if FMousePressed then
        begin
          FCurrentBitmap := FBmpPressed;
          Repaint;
        end
      else
        if FHotTrack then
          begin
            FCurrentBitmap := FBmpHot;
            Repaint;
          end;
    end;
end;
{--------------------------------------------------------------------}
{
  Sets the current image to the normal image as
  the MouseLeave message is dispatched.
  @param Message the message directive
}
procedure TBitmapButton.CMMouseLeave(var Msg: TMessage);
begin
  inherited;
  FMouseInControl := False;
  If Enabled then FCurrentBitmap := FBmpNormal;
  Repaint;
end;
{--------------------------------------------------------------------}
{
  Sets the current image to the pressed image
  as the MouseDown event occurs.
  @param Button the pressed button
  @param Shift the keyboard shift state
  @param X the mouse X coordinate
  @param Y the mouse Y coordinate
}
procedure TBitmapButton.MouseDown(Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
 
begin
  inherited MouseDown(Button, Shift, X, Y);
  FMousePressed := True;
  FCurrentBitmap := FBmpPressed;
  Repaint;
end;
{--------------------------------------------------------------------}
{
  Sets the current image to the normal/hot image
  as the MouseUp event occurs.
  @param Button the pressed button
  @param Shift the keyboard shift state
  @param X the mouse X coordinate
  @param Y the mouse Y coordinate
}
procedure TBitmapButton.MouseUp(Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
 
begin
  inherited MouseUp(Button, Shift, X, Y);
  FMousePressed := False;
 
  if Enabled then
    begin
      if (FHotTrack) and (FMouseInControl) then
        FCurrentBitmap := FBmpHot
      else
        FCurrentBitmap := FBmpNormal;
      Repaint;
    end;
end;
{--------------------------------------------------------------------}
{
  Paints the appropriate bitmap on the control
  as the Paint event occurs.
}
procedure TBitmapButton.Paint;
 
  function GetX: Integer;
  begin
    Result := Width div 2 - FCurrentBitmap.Width div 2;
  end;
 
  function GetY: Integer;
  begin
    Result := Height div 2 - FCurrentBitmap.Height div 2;
  end;
 
begin
  if csDesigning in ComponentState then
    with inherited Canvas do
      begin
        Pen.Color := clGray;
        Brush.Style := bsClear;
        Rectangle(0, 0, Width, Height);
      end;
 
  if Assigned(FCurrentBitmap) then
    begin
      FCurrentBitmap.TransparentColor := FTransparentColor;
      FCurrentBitmap.Transparent := FTransparent;
      inherited Canvas.Draw(GetX, GetY, FCurrentBitmap);
    end;
end;
{--------------------------------------------------------------------}
{
  Assigns the AutoSize property and resizes the component
  if needed.
  @param Value the AutoSize property value(True/False)
}
procedure TBitmapButton.SetAutoSize(Value: Boolean);
begin
  FAutoSize := Value;
  If (FAutoSize) and (csDesigning in ComponentState) then
    begin
      If Assigned(FBmpNormal) then
        begin
          Height := FBmpNormal.Height;
          Width := FBmpNormal.Width;
        end
      else
        begin
          //Height := 0;
          //Width := 0;
        end;
    end;
end;
{--------------------------------------------------------------------}
{
  Assigns the BmpDisabled property.
  @param Value the new bitmap
}
procedure TBitmapButton.SetBmpDisabled(Value: TBitmap);
begin
  FBmpDisabled.Assign(Value);
end;
{--------------------------------------------------------------------}
{
  Assigns the BmpHot property.
  @param Value the new bitmap
}
procedure TBitmapButton.SetBmpHot(Value: TBitmap);
begin
  FBmpHot.Assign(Value);
end;
{--------------------------------------------------------------------}
{
  Assigns the BmpNormal property.
  @param Value the new bitmap
}
procedure TBitmapButton.SetBmpNormal(Value: TBitmap);
begin
  FBmpNormal.Assign(Value);
  SetAutoSize(FAutoSize);
end;
{--------------------------------------------------------------------}
{
  Assigns the BmpPressed property.
  @param Value the new bitmap
}
procedure TBitmapButton.SetBmpPressed(Value: TBitmap);
begin
  FBmpPressed.Assign(Value);
end;
{--------------------------------------------------------------------}
{
  Assigns the Transparent property and repaints the component.
  @param Value the Transparent property value(True/False)
}
procedure TBitmapButton.SetTransparent(Value: Boolean);
begin
  FTransparent := Value;
  Repaint;
end;
{--------------------------------------------------------------------}
{
  Assigns the TransparentColor property and repaints the component.
  @param Value the transparent color
}
procedure TBitmapButton.SetTransparentColor(Value: TColor);
begin
  FTransparentColor := Value;
  Repaint;
end;
 
 
{ Register }
{--------------------------------------------------------------------}
{
  Registers the Streamer component.
}
procedure Register;
begin
  RegisterComponents('My Components', [TBitmapButton]);
end;
 
end.