runden Button

[SirThornberry]

Hier mal Source für einen ganze einfachen Runden Button der nur ein OnClick hat.

Delphi-Quellcode:

type
  TRundBtn = class(TCustomControl)
  private
    fIsDown: Boolean;
    fNeedsFormSet: Boolean;
    procedure fDownProc(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
    procedure fUpProc(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
  public
    constructor Create(AOwner: TComponent); override;
    procedure Paint; override;
    procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
  published
    OnClick;
  end;

constructor TRundBtn.Create(AOwner: TComponent);
var LRgn: HRGN;
begin
  inherited;
  fIsDown := False;
  color := clRed;
  OnMouseDown := fDownProc;
  OnMouseUp := fUpProc;
  SetBounds(Left, Top, 75, 25);
end;

procedure TRundBtn.Paint;
var LRgn: HRGN;
begin
  if fNeedsFormSet then
  begin
    fNeedsFormSet := False;
    LRgn := CreateEllipticRgn(0, 0, Width, Height);
    SetWindowRgn(Handle, LRgn, True);
    DeleteObject(LRgn);
  end;
  inherited;
  if fIsDown then
    Canvas.Brush.Color := clBlue
  else
    Canvas.Brush.Color := Color;
  Canvas.FillRect(Canvas.ClipRect);
end;

procedure TRundBtn.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
var LRgn: HRGN;
    LNeedsResize: Boolean;
begin
  if (AWidth <> Width) or (AHeight <> Height) then
    LNeedsResize := True;
  inherited;
  if LNeedsResize then
  begin
    if Parent <> nil then
    begin
      LRgn := CreateEllipticRgn(0, 0, Width, Height);
      SetWindowRgn(Handle, LRgn, True);
      DeleteObject(LRgn);
    end else fNeedsFormSet := True;
  end;
end;

procedure TRundBtn.fDownProc(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  fIsDown := True;
  Repaint;
end;

procedure TRundBtn.fUpProc(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  fIsDown := False;
  Repaint;
end;