DBR Delphi-Ecke

// Hier habe ich den Code für eine Color-Button-Komponente
// zusammengestrickt. Wird mit dem Mauspfeil darübergestrichen, können
// zusätzliche Farben angezeigt werden

// Wenn die Maus nicht auf dem Button ist, entfällt die Vorsilbe "Hot",
// d.h. das Aussehen wird beispielsweise nicht von HotColor sondern von
// Color bestimmt, und der helle Rand hat dann die Farbe von Highlight
// und nicht mehr von HotHiglight. Das Überstreichen mit der Maus zeigt
// zwar die Farben des Hot-Zustandes an, schaltet den Button aber nicht um
// (siehe dazu weiter unten: Change).

// Erläuterung der (zusätzlichen) Eigenschaften:

// Angleichen(b: boolean) (Procedure)
// Der Button hat einen Normalzustand und einen Hot-Zustand, welche sich
// (in der Regel) durch unterschiedliche Farben und Captions bemerkbar
// machen. Durch Aufruf dieser Prozedur werden Farben und Caption des einen
// Zustands dem anderen ebenfalls zugewiesen. Ist b = True wird der
// Hot-Zustand geändert, ist b = False der Normalzustand. Dadurch erfolgt
// beim Überstreichen mit der Maus kein Farbwechsel mehr
// (siehe dazu aber: Permission).

// Caption2 (String)
// Wenn mittels Change oder Normal (siehe weiter unten) umgeschaltet wird,
// wird abwechselnd Caption und Caption2 angezeigt. Es sei denn, Caption2
// hat keinen Wert, dann wird immer Caption angezeigt. Das Übersteichen des
// Buttons mit der Maus hat keinen Einfluß auf die Captions, sondern nur
// auf die Farben. Wenn ein Zeichen in Caption unterstrichen dargestellt
// wird (also ein "&" davor stehen hat), darf bei Caption2 nur das gleiche
// Zeichen unterstrichen sein. Wird ein anderes angewählt, wird die
// Eingabe abgewiesen und es ertönt ein "Beep".

// Change (Procedure)
// Der Button hat einen Normalzustand und einen Hot-Zustand, welche sich
// (in der Regel) durch unterschiedliche Farben und Captions bemerkbar
// machen. Durch Aufruf dieser Prozedur werden die Zustände hin- und
// hergewechselt, quasi der Button umgeschaltet (siehe auch: OnChange).

// DkShadow (TColor)
// Legt im Normalzustand die Farbe der ganz dunklen Kante fest.

// Flat (Boolean)
// Schaltet zwischen der 3D- und der 2D-Darstellung des Buttons um.

// FocusRect (Boolean)
// Bestimmt, ob ein gestricheltes "Focus-Rectangle" gezeichnet wird, wenn
// der Button zum aktiven Element wird.

// Highlight (TColor)
// Legt die Farbe der hellen Kante im Normalzustand fest.

// HotColor (TColor)
// Bestimmt im Hot-Zustand die Farbe der Fläche (im Normalzustand Color).

// HotDkColor (TColor)
// Legt im Hot-Zustand die Farbe der ganz dunklen Kante fest.

// HotFontColor (TColor)
// Bestimmt im Hot-Zustand die Farbe der Buchstaben
// (im Normalzustand Font.Color).

// HotHighlight (TColor)
// Bestimmt im Hot-Zustand die Farbe der hellen Kante.

// HotShadow (TColor)
// Bestimmt im Hot-Zustand die Farbe der Schattenkante.

// Lifting (Boolean)
// Legt fest, ob sich bei der 2D-Darstellung der Button anhebt, wenn man
// ihn mit der Maus überstreicht.

// Normal (Boolean)
// Gibt Auskunft, ob die Zustände des Buttons gewechselt wurden
// (siehe dazu auch: Change) und kann einen bestimmten Zustand einstellen.

// OnChange (Event)
// Wird ausgelöst, wenn der Button die Zustände wechselt (siehe Change).

// OnMouseEnter (Event)
// Wird ausgelöst, wenn die Mauspfeil auf den Button kommt.

// OnMouseLeave (Event)
// Wird ausgelöst, wenn die Mauspfeil den Button verlässt.

// Permission (Boolean)
// Erteilt bzw. verweigert die Erlaubnis zum Farbwechsel bei Überstreichen
// mit der Maus. Im Gegensatz zu Angleichen (siehe dort) bleiben aber die
// Farben erhalten.

// Shadow (TColor)
// Bestimmt im Normalzustand die Farbe der Schattenkante.

// StartColors(b: boolean) (Procedure)
// Durch den Aufruf werden die Originalfarben wieder hergestellt.
// Ist b = True für den Hot-Zustand, ist b = False für den Normalzustand.

// Getestet mit D4 unter WinME

// ACHTUNG!
// Wenn man zur Entwicklerzeit doppelt auf den Button klickt, wird
// nicht wie beim TButton das Ereignis ButtonClick erstellt,
// sondern ButtonChange.

// Siehe auch: Komponente für einen grafischen Button erstellen

unit CButton; 
 
interface 
 
uses 
  Windows, 
  SysUtils, 
  Messages, 
  Classes, 
  Graphics, 
  Controls, 
  StdCtrls; 
 
type 
  TCButton = class(TButton) 
  private 
    c2: string; 
    bmp: TBitmap; 
    hig, drk, shd, hot, hof, hod, hos, hoh: TColor; 
    focrec, drauf, flt, chg, prm, drn, anh: Boolean; 
    FOnEnter, FOnLeave, FOnChange: TNotifyevent; 
    procedure Paint(var Msg: TWMDrawItem); message CN_DRAWITEM; 
    procedure EnabledChanged(var Msg: TMessage); message CM_ENABLEDCHANGED; 
  protected 
    procedure sethot(c: TColor); 
    procedure sethos(c: TColor); 
    procedure sethod(c: TColor); 
    procedure sethoh(c: TColor); 
    procedure sethof(c: TColor); 
    procedure sethig(c: TColor); 
    procedure setdrk(c: TColor); 
    procedure setshd(c: TColor); 
    procedure MouseUP(Button: TMouseButton; 
      Shift: TShiftState; X, Y: Integer); override; 
    procedure CreateParams(var Params: TCreateParams); override; 
    procedure MEnter(var EMsg: TMessage); message CM_MouseEnter; 
    procedure MLeave(var LMsg: TMessage); message CM_MouseLeave; 
    procedure setbuttonstyle(ADefault: Boolean); override; 
    procedure setfocrec(b: boolean); 
    procedure setflt(b: boolean); 
    procedure standardcolors; 
    procedure standardhotcolors; 
    procedure setchg(b: boolean); 
    procedure setprm(b: boolean); 
    procedure setanh(b: boolean); 
    procedure setc2(s: string); 
  public 
    constructor Create(AOwner: TComponent); override; 
    destructor Destroy; override; 
    procedure angleichen(b: boolean); 
    procedure startcolors(b: boolean); 
    procedure change; 
  published 
    property OnMouseEnter: TNotifyevent read FOnEnter write FOnEnter; 
    property OnMouseLeave: TNotifyevent read FOnLeave write FOnLeave; 
    property OnChange: TNotifyevent read FOnChange write FOnChange; 
    property FocusRect: boolean read focrec write setfocrec; 
    property HotHighlight: TColor read hoh write sethoh; 
    property Highlight: TColor read hig write sethig; 
    property HotDkShadow: TColor read hod write sethod; 
    property DkShadow: TColor read drk write setdrk; 
    property HotShadow: TColor read hos write sethos; 
    property Shadow: TColor read shd write setshd; 
    property HotFontColor: TColor read hof write sethof; 
    property HotColor: TColor read hot write sethot; 
    property Flat: boolean read flt write setflt; 
    property Normal: boolean read chg write setchg; 
    property Permission: boolean read prm write setprm; 
    property Caption2: string read c2 write setc2; 
    property Lifting: boolean read anh write setanh; 
    property Color; 
  end; 
 
procedure Register; 
 
implementation 
 
constructor TCButton.Create(AOwner: TComponent); 
begin 
  inherited Create(AOwner); 
  bmp := Tbitmap.create; 
  focrec := true; 
  prm := true; 
  anh := true; 
  chg := true; 
  standardcolors; 
  standardhotcolors; 
end; 
 
destructor TCButton.Destroy; 
begin 
  bmp.free; 
  inherited Destroy; 
end; 
 
procedure TCButton.MouseUP(Button: TMouseButton; 
  Shift: TShiftState; X, Y: Integer); 
var h: THandle; 
  p: TPoint; 
begin 
  inherited; 
  p := self.clienttoscreen(point(x, y)); 
  h := windowfrompoint(p); 
  if (h <> self.handle) and self.visible then begin 
    sendmessage(h, CM_MouseEnter, 0, 0); 
  end; 
end; 
 
procedure TCButton.standardcolors; 
begin 
  font.color := clwindowtext; 
  color := clbtnface; 
  hig := clBtnHighlight; 
  shd := clBtnShadow; 
  drk := cl3dDkShadow; 
end; 
 
procedure TCButton.standardhotcolors; 
begin 
  hot := $4080FF; 
  hof := clmaroon; 
  hoh := $ADD7FC; 
  hos := $5BB7; 
  hod := $5E; 
end; 
 
procedure TCButton.startcolors(b: boolean); 
begin 
  if b then standardhotcolors 
  else standardcolors; 
  invalidate; 
end; 
 
procedure TCButton.MEnter(var EMsg: TMessage); 
begin 
  if prm then drauf := not drauf; 
  drn := true; 
  invalidate; 
  if assigned(FOnEnter) then FOnEnter(self); 
end; 
 
procedure TCButton.MLeave(var LMsg: TMessage); 
begin 
  if prm then drauf := not drauf; 
  drn := false; 
  invalidate; 
  if assigned(FOnLeave) then FOnLeave(self); 
end; 
 
procedure TCButton.Paint(var Msg: TWMDrawItem); 
var 
  rec, frec: TRect; 
  dwn, fcs: byte; 
  fhig, fshd, fdrk: TColor; 
  procedure drwtxt; 
  var p: pchar; 
  begin 
    if (not chg) and (c2 <> '') then p := pchar(c2) 
    else p := pchar(caption); 
    DrawText(bmp.canvas.handle, p, -1, 
      rec, DT_SINGLELINE or DT_CENTER or DT_VCENTER); 
  end; 
begin 
  with Msg.DrawItemStruct^ do begin 
    dwn := ord(itemState and ODS_SELECTED <> 0); 
    fcs := ord(itemState and ODS_FOCUS <> 0); 
    bmp.width := width; 
    bmp.height := height; 
    bmp.canvas.brush.style := bssolid; 
    rec := rect(6 + dwn, 6 + dwn, width - 5 + dwn, height - 5 + dwn); 
    frec := rect(4, 4, width - 4, height - 4); 
    with bmp do begin 
      canvas.font := font; 
      with canvas do begin 
        if not enabled then begin 
          fdrk := cl3dDkShadow; 
          fhig := clbtnhighlight; 
          fshd := clbtnshadow; 
          brush.color := clbtnface; 
        end else begin 
          if drauf then begin 
            fdrk := hod; 
            fhig := hoh; 
            fshd := hos; 
            brush.color := hot; 
          end else begin 
            fdrk := drk; 
            fhig := hig; 
            fshd := shd; 
            brush.color := color; 
          end; 
        end; 
        if enabled or (not flt) then 
          pen.color := fdrk else 
          pen.color := fshd; 
        rectangle(0, 0, width, height); 
        if flt and (not (drn and anh)) then begin 
          if dwn = 1 then begin 
            pen.color := fshd; 
            moveto(1, height - 2); 
            lineto(1, 1); 
            lineto(width - 1, 1); 
            moveto(2, height - 2); 
            lineto(2, 2); 
            lineto(width - 1, 2); 
          end; 
        end else begin 
          if (fcs = 1) and (dwn = 0) then begin 
            moveto(1, height - 2); 
            lineto(width - 2, height - 2); 
            lineto(width - 2, 0); 
          end; 
          pen.color := fshd; 
          if dwn = 1 then 
            rectangle(1, 1, width - 1, height - 1) 
          else begin 
            moveto(1, height - 2 - fcs); 
            lineto(width - 2 - fcs, height - 2 - fcs); 
            lineto(width - 2 - fcs, 0); 
            pen.color := fhig; 
            moveto(fcs, height - 2 - fcs); 
            lineto(fcs, fcs); 
            lineto(width - 1 - fcs, fcs); 
          end; 
        end; 
        if (fcs = 1) and focrec then DrawFocusRect(frec); 
      end; 
    end; 
    bmp.canvas.brush.style := bsclear; 
    if enabled then begin 
      if drauf then 
        bmp.canvas.font.color := hof 
    end else begin 
      if not flt then begin 
        bmp.canvas.font.color := fhig; 
        drwtxt; 
      end; 
      bmp.canvas.font.color := fshd; 
    end; 
    offsetrect(rec, -1, -1); 
    drwtxt; 
    bitblt(hdc, 0, 0, width, height, bmp.canvas.handle, 0, 0, srccopy); 
  end; 
  Msg.Result := 1; 
end; 
 
procedure TCButton.CreateParams(var Params: TCreateParams); 
begin 
  inherited CreateParams(Params); 
  with Params do style := style or BS_OWNERDRAW; 
end; 
 
procedure TCButton.SetButtonStyle(ADefault: Boolean); 
begin 
  invalidate; 
end; 
 
procedure TCButton.sethig(c: TColor); 
begin 
  if c = hig then exit; 
  hig := c; 
  invalidate; 
end; 
 
procedure TCButton.setshd(c: TColor); 
begin 
  if c = shd then exit; 
  shd := c; 
  invalidate; 
end; 
 
procedure TCButton.setdrk(c: TColor); 
begin 
  if c = drk then exit; 
  drk := c; 
  invalidate; 
end; 
 
procedure TCButton.sethot(c: TColor); 
begin 
  if c = hot then exit; 
  hot := c; 
  invalidate; 
end; 
 
procedure TCButton.sethof(c: TColor); 
begin 
  if c = hof then exit; 
  hof := c; 
  invalidate; 
end; 
 
procedure TCButton.sethod(c: TColor); 
begin 
  if c = hod then exit; 
  hod := c; 
  invalidate; 
end; 
 
procedure TCButton.sethos(c: TColor); 
begin 
  if c = hos then exit; 
  hos := c; 
  invalidate; 
end; 
 
procedure TCButton.sethoh(c: TColor); 
begin 
  if c = hoh then exit; 
  hoh := c; 
  invalidate; 
end; 
 
procedure TCButton.setfocrec(b: boolean); 
begin 
  if b = focrec then exit; 
  focrec := b; 
  invalidate; 
end; 
 
procedure TCButton.setanh(b: boolean); 
begin 
  if b = anh then exit; 
  anh := b; 
  invalidate; 
end; 
 
procedure TCButton.setflt(b: boolean); 
begin 
  if b = flt then exit; 
  flt := b; 
  invalidate; 
end; 
 
procedure TCButton.setprm(b: boolean); 
begin 
  if b = prm then exit; 
  prm := b; 
  if ((not chg) xor drn) then begin 
    drauf := not drauf; 
    invalidate; 
  end; 
end; 
 
procedure TCButton.setchg(b: boolean); 
begin 
  if b = chg then exit; 
  chg := b; 
  drauf := not drauf; 
  invalidate; 
  if assigned(FOnChange) then FOnChange(self); 
end; 
 
procedure TCButton.change; 
begin 
  setchg(not chg); 
end; 
 
procedure TCButton.EnabledChanged(var Msg: TMessage); 
begin 
  inherited; 
  invalidate; 
end; 
 
procedure TCButton.setc2(s: string); 
var 
  ps, pc: integer; 
begin 
  if s = c2 then exit; 
  ps := pos('&', s); 
  if ps > 0 then begin 
    pc := pos('&', caption); 
    if (pc = 0) or 
      (ansilowercase(caption[pc + 1]) <> ansilowercase(s[ps + 1])) 
      then begin 
      beep; 
      exit; 
    end; 
  end; 
  c2 := s; 
  if not chg then invalidate; 
end; 
 
procedure TCButton.angleichen(b: boolean); 
begin 
  if b then begin 
    hot := color; 
    hof := font.color; 
    hoh := hig; 
    hod := drk; 
    hos := shd; 
    c2 := caption; 
  end else begin 
    color := hot; 
    font.color := hof; 
    hig := hoh; 
    drk := hod; 
    shd := hos; 
    caption := c2; 
  end; 
  invalidate; 
end; 
 
procedure Register; 
begin 
  RegisterComponents('DBR', [TCButton]); 
end; 
 
end.

// -----------------------------------------------------------------

// Beispiel: Ein Button wechselt jedesmal beim Anklicken seine Farbe
// sowie seine Aufschrift und dient somit als Umschalter

procedure TForm1.FormCreate(Sender: TObject); 
begin 
// diese Einstellungen können auch im Objektinspektor erfolgen:  
  cbutton1.caption := 'EIN'; 
  cbutton1.color := clred; 
  cbutton1.font.color := $AAAAFF; 
  cbutton1.highlight := $B0B0FF; 
  cbutton1.DkShadow := $33; 
  cbutton1.Shadow := $B0; 
  cbutton1.caption2 := 'AUS'; 
  cbutton1.hotcolor := cllime; 
  cbutton1.hotfontcolor := clgreen; 
  cbutton1.hothighlight := $CCFFBB; 
  cbutton1.hotDkShadow := $4000; 
  cbutton1.hotShadow := $B000; 
  cbutton1.FocusRect := false; 
  cbutton1.Permission := false; 
// -------------------------------------------------------------- 
  cbutton1change(sender); 
end; 
 
procedure TForm1.CButton1Click(Sender: TObject); 
begin 
  CButton1.Change; 
end; 
 
procedure TForm1.CButton1Change(Sender: TObject); 
begin 
  if cbutton1.normal then label1.caption := 'Zustand 1' 
  else label1.caption := 'Zustand 2'; 
end;