![]() // Hier habe ich
den Code für eine Color-Button-Komponente // Wenn die Maus
nicht auf dem Button ist, entfällt die Vorsilbe "Hot", 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.
//
----------------------------------------------------------------- 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; |
Zugriffe seit 6.9.2001 auf Delphi-Ecke