unit RButton; 
 
interface 
 
uses 
  Windows, Buttons, sysutils, Messages, Classes, Controls, Graphics; 
 
type 
  TRButton = class(TGraphicControl) 
  private 
    farb, nec, neb: TColor; 
    r, fl, flz, rz, heb, trans, pc, dwn, dr, zwb, mrke, im, alu: boolean; 
    unten, frm, vfrm: UINT; 
    txt: string; 
    v, h, l, bv, sp, tb, links, twi, mg, oben, ctop, gtop, gri: integer; 
    welch, merk: byte; 
    anz, mbld: TNumGlyphs; 
    bild: TBitmap; 
    teil: array[0..3] of TBitmap; 
    FOnEnter, FOnLeave: TNotifyevent; 
    rec, rct: TRect; 
  protected 
    procedure immer(b: boolean); 
    procedure feststellen(pct: TBitmap); 
    procedure setgri(i: integer); 
    procedure setctop(i: integer); 
    procedure setgtop(i: integer); 
    procedure setnec(c: Tcolor); 
    procedure setneb(c: Tcolor); 
    procedure setmargin(i: integer); 
    procedure textplatz; 
    procedure setspace(s: integer); 
    procedure rechnen; 
    procedure enBild; 
    procedure bildcreate; 
    procedure setnum(b: TNumGlyphs); 
    procedure laden(pct: TBitmap); 
    procedure runter; 
    procedure rauf; 
    procedure setdown(b: boolean); 
    procedure setpc(b: boolean); 
    procedure setfarb(c: TColor); 
    procedure setenabled(value: boolean); override; 
    procedure MouseDown(Button: TMouseButton; 
      Shift: TShiftState; X, Y: Integer); override; 
    procedure MouseUp(Button: TMouseButton; 
      Shift: TShiftState; X, Y: Integer); override; 
    procedure Resize; override; 
    procedure setfl(b: boolean); 
    procedure setr(b: boolean); 
    procedure settrans(b: boolean); 
    procedure setcpt(s: string); 
    procedure MEnter(var EMsg: TMessage); message CM_MouseEnter; 
    procedure MLeave(var LMsg: TMessage); message CM_MouseLeave; 
    procedure paint; override; 
    procedure loaded; override; 
  public 
    constructor create(aowner: tcomponent); override; 
    destructor Destroy; override; 
    property MausIstDrauf: boolean read dr; 
  published 
    property OnMouseEnter: TNotifyevent read FOnEnter write FOnEnter; 
    property OnMouseLeave: TNotifyevent read FOnLeave write FOnLeave; 
    property OnMouseMove; 
    property OnMousedown; 
    property OnMouseUp; 
    property OnResize; 
    property OnClick; 
    property Font; 
    property ParentFont; 
    property Color; 
    property ParentColor; 
    property Enabled; 
    property Visible; 
    property Hint; 
    property ShowHint; 
    property ParentShowHint; 
    property Margin: integer read mg write setmargin; 
    property Spacing: integer read sp write setspace; 
    property Down: boolean read dwn write setdown; 
    property Transparent: boolean read trans write settrans; 
    property Flat: boolean read fl write setfl; 
    property Caption: string read txt write setcpt; 
    property Rahmen: boolean read r write setr; 
    property Anheben: boolean read heb write heb; 
    property RahmenFarbe: TColor read farb write setfarb; 
    property ParentColorR: boolean read pc write setpc; 
    property Glyph: TBitmap read bild write laden; 
    property NumGlyphs: TNumGlyphs read anz write setnum; 
    property CaptionTop: integer read ctop write setctop; 
    property GlyphTop: integer read gtop write setgtop; 
    property NotEnabledColor: TColor read nec write setnec; 
    property NotEnabledBild: TColor read neb write setneb; 
    property GroupIndex: integer read gri write setgri; 
    property NotEnabledSelbst: boolean read im write immer; 
    property AllowAllUp: boolean read alu write alu; 
  end; 
 
procedure Register; 
 
implementation 
 
constructor TRButton.create(aowner: tcomponent); 
var x: byte; 
begin 
  inherited create(aowner); 
  bild := TBitmap.create; 
  for x := 0 to 3 do 
    teil[x] := TBitmap.create; 
  width := 25; 
  height := 25; 
  r := true; 
  v := 4; 
  h := 5; 
  fl := true; 
  flz := true; 
  rz := true; 
  pc := true; 
  sp := -1; 
  mg := -1; 
  farb := cl3DDkShadow; 
  unten := BDR_RAISEDINNER or BDR_RAISEDOUTER; 
  ctop := -1; 
  gtop := -1; 
  nec := clbtnface; 
  vfrm := DT_VCENTER; 
  mrke := enabled; 
  neb := clBtnShadow; 
end; 
 
destructor TRButton.Destroy; 
var x: byte; 
begin 
  for x := 3 downto 0 do 
    teil[x].free; 
  bild.free; 
  inherited Destroy; 
end; 
 
procedure TRButton.setgri(i: integer); 
begin 
  if i = gri then exit; 
  gri := i; 
  if (i = 0) and dwn then down := false; 
end; 
 
procedure TRButton.MEnter(var EMsg: TMessage); 
begin 
  dr := true; 
  if fl and enabled then begin 
    flz := not heb; 
    if flz and (not r) then rz := true; 
    textplatz; 
  end; 
  paint; 
  if assigned(FOnEnter) then FOnEnter(self); 
end; 
 
procedure TRButton.MLeave(var LMsg: TMessage); 
begin 
  dr := false; 
  flz := fl; 
  rz := r; 
  textplatz; 
  paint; 
  if assigned(FOnLeave) then FOnLeave(self); 
end; 
 
procedure TRButton.setr(b: boolean); 
begin 
  if b = r then exit; 
  r := b; 
  rz := b; 
  invalidate; 
end; 
 
procedure TRButton.setcpt(s: string); 
begin 
  if s = txt then exit; 
  txt := s; 
  l := length(txt); 
  if txt = '' then twi := 0 
  else twi := canvas.textwidth(txt); 
  textplatz; 
  invalidate; 
end; 
 
procedure TRButton.setfl(b: boolean); 
begin 
  if b = fl then exit; 
  fl := b; 
  flz := fl; 
  invalidate; 
end; 
 
procedure TRButton.settrans(b: boolean); 
begin 
  if b = trans then exit; 
  trans := b; 
  zwb := dwn; 
  invalidate; 
end; 
 
procedure TRButton.runter; 
var x: integer; 
begin 
  unten := BDR_SUNKENINNER or BDR_SUNKENOUTER; 
  v := 5; 
  h := 4; 
  bv := 1; 
  welch := 2; 
  dwn := true; 
  textplatz; 
  if gri <> 0 then 
    for x := 0 to owner.componentcount - 1 do begin 
      if (self.componentindex <> x) then begin 
        if (owner.components[x] is TRButton) 
          then begin 
          if TRButton(owner.components[x]).gri = self.gri then 
            TRButton(owner.components[x]).down := false; 
        end; 
      end; 
    end; 
  if not enabled then welch := 1; 
  invalidate; 
end; 
 
procedure TRButton.MouseDown(Button: TMouseButton; 
  Shift: TShiftState; X, Y: Integer); 
begin 
  if button = mbleft then begin 
    if gri <> 0 then zwb := not zwb; 
    runter; 
  end; 
  if assigned(onmousedown) then onmousedown(self, button, shift, x, y); 
end; 
 
procedure TRButton.rauf; 
begin 
  unten := BDR_RAISEDINNER or BDR_RAISEDOUTER; 
  v := 4; 
  h := 5; 
  bv := 0; 
  welch := 0; 
  dwn := false; 
  textplatz; 
  if not enabled then welch := 1; 
  invalidate; 
end; 
 
procedure TRButton.MouseUp(Button: TMouseButton; 
  Shift: TShiftState; X, Y: Integer); 
begin 
  if button = mbleft then 
    if (not zwb) and (alu) or (gri = 0) then rauf else begin 
      welch := 3; 
      invalidate; 
    end; 
  if assigned(onmouseup) then onmouseup(self, button, shift, x, y); 
end; 
 
procedure TRButton.setdown(b: boolean); 
begin 
  if b = dwn then exit; 
  if b then begin if gri <> 0 then zwb := true; 
    runter; 
  end else begin zwb := false; 
    rauf; 
  end; 
end; 
 
procedure TRButton.setfarb(c: TColor); 
begin 
  if c = farb then exit; 
  farb := c; 
  canvas.Pen.color := farb; 
  pc := false; 
  invalidate; 
end; 
 
procedure TRButton.setpc(b: boolean); 
begin 
  if pc = b then exit; 
  pc := b; 
  if b then begin 
    farb := cl3DDkShadow; 
    canvas.pen.color := farb; 
  end; 
  invalidate; 
end; 
 
procedure TRButton.setenabled(value: boolean); 
begin 
  inherited; 
  if mrke = enabled then exit; 
  if not enabled then begin 
    welch := 1; 
    mrke := false; 
  end else begin 
    canvas.pen.color := farb; 
    mrke := true; 
    if merk = 1 then 
      if dwn then merk := 3 else merk := 0; 
    welch := merk; 
  end; 
  invalidate; 
end; 
 
procedure TRButton.setmargin(i: integer); 
begin 
  if i < -1 then i := -1; 
  if i = mg then exit; 
  mg := i; 
  textplatz; 
  invalidate; 
end; 
 
procedure TRButton.setctop(i: integer); 
begin 
  if i = ctop then exit; 
  ctop := i; 
  textplatz; 
  invalidate; 
end; 
 
procedure TRButton.setgtop(i: integer); 
begin 
  if i = gtop then exit; 
  gtop := i; 
  textplatz; 
  invalidate; 
end; 
 
procedure TRButton.setneb(c: TColor); 
begin 
  if c = neb then exit; 
  neb := c; 
  bildcreate; 
  invalidate; 
end; 
 
procedure TRButton.setnec(c: TColor); 
begin 
  if c = nec then exit; 
  nec := c; 
  if not enabled then invalidate; 
end; 
 
procedure TRButton.textplatz; 
var spcz, coben, cunten: integer; 
  procedure spac; 
  begin 
    if (mg = -1) or (tb = 0) then begin 
      if tb = 0 then links := v + bv else 
        links := bv + (width - tb - spcz - twi) div (2 + ord((sp = -1) 
          and (twi > 0))) 
    end else links := mg + bv; 
  end; 
begin 
  if (sp = -1) or (twi = 0) then begin 
    spcz := 0; 
    spac; 
    frm := DT_CENTER; 
  end else begin 
    spcz := sp; 
    spac; 
    frm := DT_LEFT; 
  end; 
  if gtop = -1 then 
    oben := bv + (height - teil[welch].height) div 2 
  else 
    oben := gtop + bv; 
  if ctop = -1 then begin 
    coben := v; 
    cunten := height - h; 
    vfrm := DT_VCENTER; 
  end else begin 
    coben := ctop + bv; 
    cunten := coben + height; 
    vfrm := DT_top; 
  end; 
  rct := rect(links + spcz + tb, coben + 1, width - h, cunten); 
end; 
 
procedure TRButton.rechnen; 
begin 
  rec := rect(0, 0, width, height); 
  textplatz; 
end; 
 
procedure TRButton.setspace(s: integer); 
begin 
  if s = sp then exit; 
  sp := s; 
  rechnen; 
  invalidate; 
end; 
 
procedure TRButton.Resize; 
begin 
  rechnen; 
  inherited; 
end; 
 
procedure TRButton.loaded; 
begin 
  inherited; 
  bildcreate; 
  zwb := dwn; 
end; 
 
procedure TRButton.enBild; 
var 
  fb: TColor; 
  x, y: integer; 
begin 
  teil[1].width := teil[0].width; 
  teil[1].height := teil[0].height; 
  fb := teil[0].canvas.pixels[0, teil[0].height - 1]; 
  for x := 0 to teil[1].width - 1 do 
    for y := 0 to teil[1].height - 1 do begin 
      if teil[0].canvas.pixels[x, y] <> fb 
        then teil[1].canvas.pixels[x, y] := neb 
      else teil[1].canvas.pixels[x, y] := fb or $20000000; 
    end; 
  teil[1].transparent := true; 
end; 
 
procedure TRButton.bildcreate; 
var y: byte; 
  procedure mach(x: byte); 
  begin 
    teil[x].height := bild.height; 
    teil[x].width := bild.width div mbld; 
    teil[x].canvas.copyrect(teil[x].canvas.cliprect, bild.canvas, 
      rect(teil[x].width * x, 0, teil[x].width * (x + 1), bild.height)); 
    teil[x].transparent := true; 
  end; 
begin 
  feststellen(bild); 
  mach(0); 
  tb := teil[0].width; 
  case anz of 
    1: begin 
        enBild; 
        for y := 2 to 3 do teil[y].assign(teil[0]); 
      end; 
    2: begin 
        if im then enBild else mach(1); 
        for y := 2 to 3 do teil[y].assign(teil[0]); 
      end; 
    3: begin 
        if im then enBild else mach(1); 
        mach(2); 
        teil[3].assign(teil[0]); 
      end; 
    4: begin 
        if im then enBild else mach(1); 
        for y := 2 to 3 do mach(y); 
      end; 
  end; 
  rechnen; 
end; 
 
procedure TRButton.immer(b: boolean); 
begin 
  if b = im then exit; 
  im := b; 
  bildcreate; 
  invalidate; 
end; 
 
procedure TRButton.feststellen(pct: TBitmap); 
begin 
  if bild.width <= bild.height then mbld := 1 
  else mbld := bild.width div bild.height; 
  if mbld > 4 then mbld := 4; 
end; 
 
procedure TRButton.laden(pct: TBitmap); 
var rc: TRect; 
begin 
  bild.assign(pct); 
  if bild.width <= bild.height then anz := 1 
  else anz := bild.width div bild.height; 
  if anz > 4 then begin 
    bild.width := (pct.width div anz) * 4; 
    anz := 4; 
    rc := rect(0, 0, bild.width, bild.height); 
    bild.canvas.copyrect(rc, pct.canvas, rc); 
  end; 
  bildcreate; 
  invalidate; 
end; 
 
procedure TRButton.setnum(b: TNumGlyphs); 
begin 
  if b = anz then exit; 
  anz := b; 
  bildcreate; 
  invalidate; 
end; 
 
procedure TRButton.paint; 
begin 
  if not mrke then begin 
    if trans then canvas.brush.style := bsclear else 
      canvas.Brush.color := nec; 
    if r then begin 
      canvas.pen.style := pssolid; 
      canvas.pen.color := neb 
    end else canvas.pen.style := psclear; 
    canvas.rectangle(0, 0, width, height); 
    if r and not fl then begin 
      if dwn then 
        canvas.pen.color := neb else 
        canvas.pen.color := clbtnhighlight; 
      canvas.moveto(1, height - 2); 
      canvas.lineto(1, 1); 
      canvas.lineto(width - 1, 1); 
    end; 
  end else begin 
    if not trans then begin 
      canvas.pen.style := psclear; 
      canvas.Brush.color := color; 
      canvas.rectangle(ord(dwn), ord(dwn), width, height); 
    end; 
    canvas.pen.style := pssolid; 
    if (r or dr or trans) then 
      canvas.Pen.color := farb 
    else canvas.pen.color := color; 
    canvas.brush.style := bsclear; 
    canvas.rectangle(0, 0, width, height); 
  end; 
  canvas.font := font; 
  if not trans then begin 
    canvas.draw(links, oben + 1, teil[welch]); 
    if not enabled then canvas.Font.color := neb; 
    drawtext(canvas.handle, pchar(txt), l, rct, DT_SINGLELINE or vfrm or frm); 
  end; 
  if not flz then begin 
    if mrke then 
      drawedge(canvas.handle, rec, unten, BF_RECT); 
  end 
  else begin 
    if mrke and rz and dwn then begin 
      canvas.pen.color := cl3DDkShadow; 
      canvas.moveto(1, height - 2); 
      canvas.lineto(1, 1); 
      canvas.lineto(width - 1, 1); 
    end; 
  end; 
end; 
 
procedure Register; 
begin 
  RegisterComponents('DBR', [TRButton]); 
end; 
 
end.