procedure TForm1.FarbButton1Click(Sender: TObject); 
begin 
  ColorDialog1.Color := FarbButton1.Colour; 
  if ColorDialog1.execute then begin 
    FarbButton1.Colour := ColorDialog1.Color; 
   //... 
  end; 
end;

unit FarbButton; 
 
interface 
 
uses 
  Classes, 
  Windows, 
  SysUtils, 
  Graphics, 
  Controls, 
  Messages, 
  Stdctrls; 
 
type 
  TFarbButton = class(TCustomLabel) 
  private 
    FBitmap: TBitmap; 
    FSchrift: TStringlist; 
    FFarbe, FFontC, FFontS, FSchatten, Fcol: TColor; 
    FOnEnter, FOnLeave, FOnChange: TNotifyevent; 
    FAccel, FName, FDoppel, FVerlauf, Fdrin, Frect, FMove, Fdown, FLck, 
      FRast, Fenabled: Boolean; 
    FAlign, Fr, Fg, Fb, Frh, Fgh, Fbh, Frd, Fgd, Fbd, Fro, Fgo, Fbo, 
      Fru, Fgu, Fbu, Foffs, Foffst, Foffsl: integer; 
  protected 
    procedure setname(const Value: TComponentName); override; 
    procedure Mousedown(Button: TMousebutton; 
      Shift: TShiftState; x, y: integer); override; 
    procedure MouseUp(Button: TMousebutton; 
      Shift: TShiftState; x, y: integer); override; 
    procedure Click; override; 
    procedure maushoch; 
    procedure mehrzeilig; 
    procedure obenhell; 
    procedure untenhell; 
    procedure ifnotenabled; 
    procedure setfarbe(c: TColor); 
    procedure setmove(b: boolean); 
    procedure setlock(b: boolean); 
    procedure setAccel(b: boolean); 
    procedure makefarbe(c: TColor); 
    procedure setoffsl(i: integer); 
    procedure setoffst(i: integer); 
    procedure setdoppel(b: boolean); 
    procedure setverlauf(b: boolean); 
    procedure setschatten(c: TColor); 
    procedure setschrift(sl: TStringList); 
    procedure Verlauf(DC: HDC; x1, y1, x2, y2: integer); 
    procedure MEnter(var EMsg: TMessage); message CM_MouseEnter; 
    procedure MLeave(var LMsg: TMessage); message CM_MouseLeave; 
    procedure CMDialogChar(var aMsg: TWMKey); message CM_DIALOGCHAR; 
  public 
    constructor Create(AOwner: TComponent); override; 
    procedure SetEnabled(Value: Boolean); override; 
    destructor Destroy; override; 
    procedure resize; override; 
    procedure paint; override; 
  published 
    property OnColourChange: TNotifyevent read FOnChange write FOnChange; 
    property OnMouseEnter: TNotifyevent read FOnEnter write FOnEnter; 
    property OnMouseLeave: TNotifyevent read FOnLeave write FOnLeave; 
    property OnMouseMove; 
    property OnMouseDown; 
    property OnMouseUp; 
    property TextShadow: TColor read FSchatten write setschatten; 
    property TextSpacingLeft: integer read Foffsl write setoffsl; 
    property TextSpacingTop: integer read Foffst write setoffst; 
    property Words: TStringlist read FSchrift write setschrift; 
    property ShowAccelChar: boolean read FAccel write setAccel; 
    property Gradient: boolean read FVerlauf write setverlauf; 
    property CaptureFrame: boolean read Frect write Frect; 
    property Text3D: boolean read FDoppel write setdoppel; 
    property TextMove: boolean read FMove write setMove; 
    property Colour: TColor read FFarbe write setfarbe; 
    property FrameColour: TColor read Fcol write Fcol; 
    property Lock: boolean read Flck write setlock; 
    property ParentShowHint; 
    property ParentFont; 
    property ShowHint; 
    property OnClick; 
    property Visible; 
    property Enabled; 
    property Font; 
    property Hint; 
  end; 
 
procedure Register; 
 
implementation 
 
function GradientFill(hdc: HDC; pVertex: PTriVertex; 
  dwNumVertex: DWORD; pMesh: Pointer; 
  dwNumMesh: DWORD; dwMode: DWORD): Boolean; stdcall; 
  external 'gdi32.dll' name 'GdiGradientFill'; 
 
procedure Register; 
begin 
  RegisterComponents('DBR', [TFarbButton]); 
end; 
 
constructor TFarbButton.Create(AOwner: TComponent); 
begin 
  inherited Create(AOwner); 
  FName := false; 
  FBitmap := TBitmap.create; 
  FBitmap.Transparent := true; 
  FSchrift := TStringlist.create; 
  Autosize := false; 
  Transparent := true; 
  Fdown := false; 
  FLck := false; 
  FMove := true; 
  Fdrin := false; 
  Frect := false; 
  Frast := false; 
  Fenabled := true; 
  width := 75; 
  height := 25; 
  FVerlauf := true; 
  makefarbe($FF9999); 
  Fcol := $31B2FF; 
  Foffs := 0; 
  Font.color := $FFFFF0; // für 16 Bit Farbtiefe 
  FFontC := Font.color;
  FFontS := clblack; 
  FSchatten := FFontS; 
  FAlign := DT_Center or DT_Vcenter or DT_Singleline or DT_NOCLIP; 
  Foffsl := 10000; 
  Foffst := 10000; 
  FDoppel := true; 
  FAccel := true; 
end; 
 
destructor TFarbButton.Destroy; 
begin 
  FBitmap.free; 
  inherited Destroy; 
end; 
 
procedure TFarbButton.Verlauf(DC: HDC; x1, y1, x2, y2: integer); 
type 
  TVertex = packed record 
    x, y: Integer; 
    rot, gruen, blau, Alpha: Word; 
  end; 
const 
  VertexCount = 2; 
var 
  Vertex: array[0..VertexCount - 1] of TVertex; 
  TVRect: TGradientRect; 
begin 
  Vertex[0].x := x1; 
  Vertex[0].y := y1; 
  Vertex[0].rot := Fro shl 8; 
  Vertex[0].gruen := Fgo shl 8; 
  Vertex[0].blau := Fbo shl 8; 
  Vertex[0].Alpha := 0; 
  Vertex[1].x := x2; 
  Vertex[1].y := y2; 
  Vertex[1].rot := Fru shl 8; 
  Vertex[1].gruen := Fgu shl 8; 
  Vertex[1].blau := Fbu shl 8; 
  Vertex[1].Alpha := 0; 
  with TVREct do begin 
    UpperLeft := 0; 
    LowerRight := 1; 
  end; 
  GradientFill(DC, @Vertex[0], VertexCount, @TVREct, 1, GRADIENT_FILL_RECT_V); 
end; 
 
procedure TFarbButton.resize; 
begin 
  if height < 15 then height := 15; 
  if width < 20 then width := 20; 
end; 
 
procedure TFarbButton.paint; 
var 
  rec: TRect; 
  i1, i2: integer; 
begin 
  if Foffsl >= 10000 then i1 := 0 else i1 := FOffsl; 
  if Foffst >= 10000 then i2 := 0 else i2 := Foffst; 
  FBitmap.Canvas.Font := Font; 
  FBitmap.width := width; 
  FBitmap.height := height; 
  with FBitmap.Canvas do begin 
    Font.color := colorToRGB(Font.color); 
    if Font.color > $FFFFF0 then Font.color := $FFFFF0; // für 16 Bit Farbtiefe 
    if Fenabled then FFontC := Font.color; 
    rec := Cliprect; 
    pen.width := 1; 
    pen.color := clblack; 
    if FMove then 
      offsetrect(rec, Foffs, Foffs); 
    brush.color := clwhite; 
    fillrect(cliprect); 
    if not FVerlauf and (FDown or Frast) and Fenabled then 
      brush.color := clblack 
    else brush.color := $FFFFF0; 
    roundrect(0, 0, width, height, 5, 5); 
    Verlauf(handle, 2, 2, width - 2, height - 1); 
    brush.style := bsclear; 
    mehrzeilig; 
    if FDoppel then begin 
      offsetrect(rec, i1 + 1, i2 + 1); 
      font.color := FFontS; 
      drawtext(handle, Pchar(Trim(FSchrift.Text)), -1, rec, FAlign); 
      offsetrect(rec, -1, -1); 
    end else offsetrect(rec, i1, i2); 
    if FEnabled then 
      Font.color := self.font.color else 
      Font.color := clblack; 
    drawtext(handle, Pchar(Trim(FSchrift.Text)), -1, rec, FAlign); 
    if Frect and Fdrin and Fenabled then begin 
      pen.width := 2; 
      pen.color := Fcol; 
      moveto(2, 2); 
      lineto(2, height - 3); 
      moveto(2, height - 2); 
      lineto(width - 3, height - 2); 
      moveto(width - 2, 2); 
      lineto(width - 2, height - 3); 
      moveto(1, 2); 
      lineto(width - 3, 2); 
    end; 
  end; 
  canvas.draw(0, 0, FBitmap); 
end; 
 
procedure TFarbButton.makefarbe(c: TColor); 
  function hell(i: integer): integer; 
  asm 
  add eax, $60 
  cmp eax, $FF 
  jle @fertig 
  mov eax, $FF 
 @fertig: 
  end; 
  function dunkel(i: integer): integer; 
  asm 
  sub eax, $60 
  cmp eax, 0 
  jge @fertig 
  xor eax, eax 
 @fertig: 
  end; 
begin 
  FFarbe := c; 
  Fr := getrvalue(c); 
  Fg := getgvalue(c); 
  Fb := getbvalue(c); 
  if Fverlauf then begin 
    Frh := hell(Fr); 
    Fgh := hell(Fg); 
    Fbh := hell(Fb); 
    Frd := dunkel(Fr); 
    Fgd := dunkel(Fg); 
    Fbd := dunkel(Fb); 
    if Frh > $F0 then Frh := $F0; // für 16 Bit Farbtiefe 
  end else begin 
    Frh := Fr; 
    Fgh := Fg; 
    Fbh := Fb; 
    Frd := Fr; 
    Fgd := Fg; 
    Fbd := Fb; 
  end; 
  if Frast and Fenabled then untenhell 
  else obenhell; 
end; 
 
procedure TFarbButton.setfarbe(c: TColor); 
begin 
  if not FEnabled then exit; 
  c := ColorToRGB(c); 
  if c = FFarbe then exit; 
  makefarbe(c); 
  repaint; 
  if assigned(FOnChange) then FOnChange(self); 
end; 
 
procedure TFarbButton.untenhell; 
begin 
  Foffs := 1; 
  Fro := Frd; 
  Fgo := Fgd; 
  Fbo := Fbd; 
  Fru := Frh; 
  Fgu := Fgh; 
  Fbu := Fbh; 
end; 
 
procedure TFarbButton.Mousedown(Button: TMousebutton; 
  Shift: TShiftState; x, y: integer); 
begin 
  Fdown := true; 
  if Flck then Frast := not Frast; 
  untenhell; 
  repaint; 
  inherited; 
end; 
 
procedure TFarbButton.obenhell; 
begin 
  Foffs := 0; 
  if Fenabled then begin 
    Fro := Frh; 
    Fgo := Fgh; 
    Fbo := Fbh; 
    Fru := Frd; 
    Fgu := Fgd; 
    Fbu := Fbd; 
  end else ifnotenabled; 
end; 
 
procedure TFarbButton.maushoch; 
begin 
  if Frast and Fenabled then exit; 
  obenhell; 
  repaint; 
end; 
 
procedure TFarbButton.MouseUp(Button: TMousebutton; 
  Shift: TShiftState; x, y: integer); 
begin 
  Fdown := false; 
  maushoch; 
  inherited; 
end; 
 
procedure TFarbButton.Click; 
begin 
  maushoch; 
  inherited; 
end; 
 
procedure TFarbButton.ifnotenabled; 
begin 
  if FVerlauf then begin 
    Fro := $F0; // für 16 Bit Farbtiefe 
    Fgo := $FF; 
    Fbo := $FF; 
    Fru := $10; 
    Fgu := $10; 
    Fbu := $10; 
  end else begin 
    Fro := $99; 
    Fgo := $99; 
    Fbo := $99; 
    Fru := $99; 
    Fgu := $99; 
    Fbu := $99; 
  end; 
end; 
 
procedure TFarbButton.SetEnabled(Value: Boolean); 
begin 
  inherited; 
  Fenabled := value; 
  if not Value then 
  begin 
    Foffs := 0; 
    ifnotenabled; 
    Font.color := clblack; 
    FFontS := $DDDDDD; 
  end else begin 
    Font.color := FFontC; 
    FFontS := FSchatten; 
    if Frast then untenhell 
    else obenhell; 
  end; 
end; 
 
procedure TFarbButton.mehrzeilig; 
begin 
  if Fschrift.count < 2 then FAlign := FAlign or DT_Singleline 
  else begin 
    FAlign := FAlign and not DT_Singleline; 
    FAlign := FAlign or DT_Wordbreak; 
  end; 
end; 
 
procedure TFarbButton.setschrift(sl: TStringlist); 
begin 
  FSchrift.text := Trim(sl.text); 
  invalidate; 
end; 
 
procedure TFarbButton.setoffsl(i: integer); 
begin 
  i := abs(i); 
  if Foffsl = i then exit; 
  Foffsl := i; 
  if i >= 10000 then FAlign := FAlign or DT_center 
  else FAlign := FAlign and not DT_center; 
  invalidate; 
end; 
 
procedure TFarbButton.setoffst(i: integer); 
begin 
  i := abs(i); 
  if Foffst = i then exit; 
  Foffst := i; 
  if i >= 10000 then FAlign := FAlign or DT_Vcenter 
  else FAlign := FAlign and not DT_Vcenter; 
  invalidate; 
end; 
 
procedure TFarbButton.setname(const Value: TComponentName); 
begin 
  inherited; 
  if not FName and (csDesigning in ComponentState) 
    and not (csReading in Componentstate) 
    and not (csLoading in Componentstate) 
    then FSchrift.add(Value); 
  FName := true; 
end; 
 
procedure TFarbButton.setdoppel(b: boolean); 
begin 
  if b = FDoppel then exit; 
  FDoppel := b; 
  invalidate; 
end; 
 
procedure TFarbButton.setschatten(c: TColor); 
begin 
  if not Fenabled then exit; 
  c := colorTORGB(c); 
  if c > $FFFFF0 then c := $FFFFF0; // für 16 Bit Farbtiefe 
  if c = FSchatten then exit; 
  FSchatten := c; 
  FFontS := c; 
  invalidate; 
end; 
 
procedure TFarbButton.setverlauf(b: boolean); 
begin 
  if b = FVerlauf then exit; 
  FVerlauf := b; 
  makefarbe(FFarbe); 
  repaint; 
end; 
 
procedure TFarbButton.MEnter(var EMsg: TMessage); 
begin 
  Fdrin := true; 
  repaint; 
  if assigned(FOnEnter) then FOnEnter(self); 
end; 
 
procedure TFarbButton.MLeave(var LMsg: TMessage); 
begin 
  Fdrin := false; 
  repaint; 
  if assigned(FOnLeave) then FOnLeave(self); 
end; 
 
procedure TFarbButton.setAccel(b: boolean); 
begin 
  if b = FAccel then exit; 
  FAccel := b; 
  if not b then FAlign := FAlign or DT_NOPREFIX 
  else FAlign := FAlign and not DT_NOPREFIX; 
  invalidate; 
end; 
 
procedure TFarbButton.CMDialogChar(var aMsg: TWMKey); 
var 
  p: PChar; 
  i: integer; 
begin 
  if not Fenabled or (FSchrift.count = 0) then exit; 
  i := pos('&', FSchrift[0]); 
  if not FAccel or (i = 0) then exit; 
  p := @FSchrift[0][i + 1]; 
  if AnsiUppercase(char(aMsg.CharCode)) = AnsiUppercase(p^) 
    then begin 
    try 
      aMsg.Result := 1; 
      click; 
    except 
    end; 
  end; 
end; 
 
procedure TFarbButton.setlock(b: boolean); 
begin 
  if b = Flck then exit; 
  Flck := b; 
  if not b and FDown then begin 
    Fdown := false; 
    maushoch; 
  end; 
end; 
 
procedure TFarbButton.setmove(b: boolean); 
begin 
  if b = FMove then exit; 
  FMove := b; 
  if FDown then invalidate; 
end; 
 
end.