unit PictBtn; 
 
interface 
 
uses 
  Windows, SysUtils, Classes, Graphics, Messages, Controls; 
 
type 
  TPicts = (pbOne, pbOver, pbNotEnabled, pbAll); 
 
  TPictBtn = class(TCustomControl) 
  private 
    Fgrafted, FAccel, FDown, FTrans, FRast, FZ, FDrin, FDesp, FYes, FMove, 
      FF: boolean; 
    Fleft, FG, Fp, FCaptLeft, FCaptTop: integer; 
    FBu, FBo, FBy: TBitmap; 
    FTc, FNot: TColor; 
    FGlyph: TPicts; 
    FRect: TRect; 
    Flags: Uint; 
    FGrup: byte; 
    FTs: TSize; 
  protected 
    procedure MouseMove(Shift: TShiftState; X, Y: integer); override; 
    procedure CMDialogChar(var aMsg: TWMKey); message CM_DIALOGCHAR; 
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; 
      X, Y: integer); override; 
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; 
      X, Y: integer); override; 
    procedure MLeave(var LMsg: TMessage); message CM_MouseLeave; 
    procedure MFont(var Msg: TWMSETFONT); message WM_SETFONT; 
    procedure WMText(var M: TMessage); message WM_SetText; 
    procedure SetEnabled(Value: boolean); override; 
    function TestFTc(X, Y: integer): boolean; 
    function testen(X, Y: integer): TColor; 
    procedure setcaptLeft(i: integer); 
    procedure DoDrawText(rct: TRect); 
    procedure setcaptTop(i: integer); 
    procedure builddown(b: boolean); 
    procedure makedown(b: boolean); 
    procedure setTrans(b: boolean); 
    procedure setAccel(b: boolean); 
    procedure setDown(b: boolean); 
    procedure setGlyph(g: TPicts); 
    procedure setRast(b: boolean); 
    procedure setBo(b: TBitmap); 
    procedure setBu(b: TBitmap); 
    procedure setBy(b: TBitmap); 
    procedure gross(b: TBitmap); 
    procedure setNot(c: TColor); 
    procedure setFTc(c: TColor); 
    procedure NoMaus(b: boolean); 
    procedure setGrup(b: byte); 
    procedure Resize; override; 
    procedure Loaded; override; 
    procedure Paint; override; 
    procedure Click; override; 
    procedure kalkulate; 
    procedure setleft; 
    procedure prf; 
    procedure XEnter(X, Y: integer); 
    procedure XExit; 
    procedure myEnter(var Msg: TMessage); message CM_ENTER; 
    procedure myExit(var Msg: TMessage); message CM_EXIT; 
  public 
    constructor Create(AOwner: TComponent); override; 
    destructor Destroy; override; 
  published 
    property CaptionLeft: integer read FCaptLeft write setcaptLeft; 
    property CaptionTop: integer read FCaptTop write setcaptTop; 
    property ShowAccelChar: boolean read FAccel write setAccel; 
    property Transparency: boolean read FTrans write setTrans; 
    property PictType: TPicts read FGlyph write setGlyph; 
    property DisabledFont: TColor read FNot write setNot; 
    property CaptionMove: boolean read FMove write FMove; 
    property AllowUp: boolean read FDesp write FDesp; 
    property Down: boolean read FDown write NoMaus; 
    property Snap: boolean read FRast write setRast; 
    property PictDown: TBitmap read FBu write setBu; 
    property PictDownX: TBitmap read FBy write setBy; 
    property PictUp: TBitmap read FBo write setBo; 
    property Group: byte read FGrup write setGrup; 
    property ParentShowHint; 
    property OnMouseMove; 
    property OnMouseDown; 
    property ParentFont; 
    property OnMouseUp; 
    property ShowHint; 
    property OnClick; 
    property Visible; 
    property Enabled; 
    property Caption; 
    property Color; 
    property Font; 
    property Tabstop; 
    property Taborder; 
    property OnEnter; 
    property OnKeyDown; 
    property OnKeyUp; 
    property OnKeyPress; 
  end; 
 
procedure Register; 
 
implementation 
 
procedure Register; 
begin 
  RegisterComponents('DBR', [TPictBtn]); 
end; 
 
procedure TPictBtn.myEnter(var Msg: TMessage); 
begin 
  inherited; 
  Fgrafted := true; 
  XEnter(0, 0); 
end; 
 
procedure TPictBtn.myExit(var Msg: TMessage); 
begin 
  inherited; 
  Fgrafted := false; 
  XExit; 
end; 
 
procedure TPictBtn.Paint; 
  procedure zeigen(b: TBitmap); 
  begin 
    b.transparentcolor := testen(0, 0); 
    b.transparent := FTrans; 
    canvas.draw(-Fleft, 0, b); 
  end; 
  procedure ohne; 
  begin 
    if FTrans then 
      canvas.brush.Color := Color 
    else 
      canvas.brush.Color := clwhite; 
    canvas.fillrect(canvas.cliprect); 
  end; 
 
begin 
  canvas.brush.Color := Color; 
  canvas.fillrect(canvas.cliprect); 
  if FDown then 
  begin 
    if not FBu.empty then 
    begin 
      if not Fgrafted and not FBy.empty then 
        zeigen(FBy) 
      else 
        zeigen(FBu); 
    end 
    else if not FBy.empty then 
    begin 
      if Fgrafted and not FBu.empty then 
        zeigen(FBu) 
      else 
        zeigen(FBy); 
    end 
    else if not FBo.empty then 
      zeigen(FBo) 
    else 
      ohne; 
  end 
  else 
  begin 
    if not FBo.empty then 
      zeigen(FBo) 
    else if not FBu.empty then 
      zeigen(FBu) 
    else if not FBy.empty then 
      zeigen(FBy) 
    else 
      ohne; 
  end; 
  if Caption <> '' then 
    DoDrawText(FRect); 
end; 
 
procedure TPictBtn.DoDrawText(rct: TRect); 
begin 
  setbkmode(canvas.handle, transparent); 
  if not Enabled then 
    canvas.Font.Color := FNot 
  else 
  begin 
    canvas.Font.Color := Font.Color; 
    if FDown and FMove then 
      offsetrect(rct, 1, 1); 
  end; 
  DrawText(canvas.handle, PChar(Caption), -1, rct, Flags); 
end; 
 
constructor TPictBtn.Create(AOwner: TComponent); 
begin 
  inherited Create(AOwner); 
  ControlStyle := [csCaptureMouse, csOpaque, csClickEvents]; 
  Fgrafted := false; 
  width := 70; 
  height := 20; 
  Flags := DT_SINGLELINE; 
  FBo := TBitmap.Create; 
  FBu := TBitmap.Create; 
  FBy := TBitmap.Create; 
  FCaptLeft := -1000; 
  FCaptTop := -1000; 
  FGlyph := pbOne; 
  setFTc(clwhite); 
  FAccel := true; 
  FNot := clGray; 
  FMove := true; 
  FZ := false; 
  setGrup(0); 
  FG := 1; 
end; 
 
destructor TPictBtn.Destroy; 
begin 
  FBu.free; 
  FBo.free; 
  FBy.free; 
  inherited Destroy; 
end; 
 
procedure TPictBtn.setBo(b: TBitmap); 
begin 
  FBo.assign(b); 
  Resize; 
end; 
 
procedure TPictBtn.setBu(b: TBitmap); 
begin 
  FBu.assign(b); 
  Resize; 
end; 
 
procedure TPictBtn.setBy(b: TBitmap); 
begin 
  FBy.assign(b); 
  Resize; 
end; 
 
procedure TPictBtn.NoMaus(b: boolean); 
begin 
  FF := false; 
  setDown(b); 
end; 
 
procedure TPictBtn.setDown(b: boolean); 
begin 
  if b = FDown then 
    exit; 
  builddown(b); 
  if b and (FGrup > 0) then 
    prf; 
end; 
 
procedure TPictBtn.makedown(b: boolean); 
begin 
  FF := false; 
  if b <> FDown then 
    builddown(b); 
end; 
 
procedure TPictBtn.builddown(b: boolean); 
begin 
  FDown := b; 
  if FRast then 
    FZ := FDown and FF; 
  repaint; 
end; 
 
procedure TPictBtn.gross(b: TBitmap); 
begin 
  width := b.width div FG; 
  height := b.height; 
  setFTc(testen(0, 0)); 
  kalkulate; 
  setleft; 
end; 
 
procedure TPictBtn.Resize; 
begin 
  if not FBo.empty then 
    gross(FBo) 
  else if not FBu.empty then 
    gross(FBu) 
  else 
  begin 
    if width < 20 then 
      width := 20; 
    if height < 10 then 
      height := 10; 
    setFTc(clwhite); 
    kalkulate; 
    setleft; 
  end; 
end; 
 
function TPictBtn.TestFTc(X, Y: integer): boolean; 
begin 
  result := (testen(X, Y) <> FTc) or not FTrans; 
end; 
 
procedure TPictBtn.MouseDown(Button: TMouseButton; Shift: TShiftState; 
  X, Y: integer); 
begin 
  if (Button = mbLeft) and TestFTc(X, Y) and Enabled or (FBo.empty and FBu.empty) 
  then 
  begin 
    FF := true; 
    setDown(true); 
    repaint; 
    inherited; 
    setfocus; 
  end; 
end; 
 
procedure TPictBtn.MouseUp(Button: TMouseButton; Shift: TShiftState; 
  X, Y: integer); 
begin 
  if (Button = mbLeft) and (FDrin or not FRast) and FDown and Enabled and 
    TestFTc(X, Y) and ((FGrup = 0) or FDesp) or (FBo.empty and FBu.empty) then 
  begin 
    FF := true; 
    setDown(FZ); 
    if FRast then 
      FZ := not FZ; 
    repaint; 
    FYes := FDrin; 
    Fgrafted := true; 
    Click; 
    inherited; 
  end; 
end; 
 
procedure TPictBtn.MouseMove(Shift: TShiftState; X, Y: integer); 
begin 
  XEnter(X, Y); 
end; 
 
procedure TPictBtn.XEnter(X, Y: integer); 
  procedure setzen(b: boolean); 
  begin 
    FDrin := b; 
    setleft; 
  end; 
 
begin 
  if not Enabled then 
    exit; 
  if (X < 0) or (X > abs(width)) or (Y < 0) or (Y > height) then 
  begin 
    if FDrin then 
      setzen(false); 
  end 
  else 
  begin 
    if (FBo.empty and FBu.empty) then 
    begin 
      if not FDrin then 
        setzen(true); 
      inherited; 
      exit; 
    end; 
    if testen(X, Y) <> FTc then 
    begin 
      if not FDrin then 
        setzen(true); 
    end 
    else 
    begin 
      if FTrans then 
      begin 
        if FDrin then 
          setzen(false) 
      end 
      else if not FDrin then 
        setzen(true); 
    end; 
  end; 
  if FDrin then 
    inherited; 
end; 
 
procedure TPictBtn.setTrans(b: boolean); 
begin 
  if b = FTrans then 
    exit; 
  FTrans := b; 
  if not b then 
    ControlStyle := ControlStyle + [csOpaque] 
  else 
    ControlStyle := ControlStyle - [csOpaque]; 
  invalidate; 
end; 
 
procedure TPictBtn.setRast(b: boolean); 
begin 
  if b = FRast then 
    exit; 
  FRast := b; 
  if not b then 
  begin 
    FGrup := 0; 
    FZ := false; 
    FDown := false; 
  end; 
  invalidate; 
end; 
 
procedure TPictBtn.setleft; 
begin 
  if FGlyph = pbOne then 
    Fleft := 0 
  else if Enabled then 
  begin 
    case FGlyph of 
      pbAll, pbOver: 
        if FDrin then 
          Fleft := abs(width) 
        else 
          Fleft := 0; 
      pbNotEnabled: 
        Fleft := 0; 
    end; 
  end 
  else 
  begin 
    case FGlyph of 
      pbAll: 
        Fleft := abs(width) * 2; 
      pbOver: 
        Fleft := 0; 
      pbNotEnabled: 
        Fleft := abs(width); 
    end; 
  end; 
  invalidate; 
end; 
 
procedure TPictBtn.SetEnabled(Value: boolean); 
begin 
  inherited; 
  setleft; 
end; 
 
procedure TPictBtn.prf; 
var 
  X: integer; 
begin 
  if FGrup > 0 then 
    for X := 0 to owner.componentcount - 1 do 
      if (owner.components[X] is TPictBtn) and (componentindex <> X) and 
        (TPictBtn(owner.components[X]).FGrup = FGrup) then 
        TPictBtn(owner.components[X]).makedown(false); 
end; 
 
procedure TPictBtn.setGrup(b: byte); 
begin 
  if b = FGrup then 
    exit; 
  FGrup := b; 
  FRast := b > 0; 
  if FDown then 
    prf; 
end; 
 
procedure TPictBtn.setGlyph(g: TPicts); 
begin 
  if g = FGlyph then 
    exit; 
  FGlyph := g; 
  case g of 
    pbOne: 
      FG := 1; 
    pbOver, pbNotEnabled: 
      FG := 2; 
    pbAll: 
      FG := 3; 
  end; 
  Resize; 
end; 
 
procedure TPictBtn.MLeave(var LMsg: TMessage); 
begin 
  if not Fgrafted then 
    XExit; 
end; 
 
procedure TPictBtn.XExit; 
begin 
  if FDrin then 
  begin 
    FDrin := false; 
    setleft; 
  end; 
  inherited; 
end; 
 
procedure TPictBtn.Loaded; 
begin 
  inherited; 
  canvas.Font.assign(Font); 
  Resize; 
end; 
 
function TPictBtn.testen(X, Y: integer): TColor; 
begin 
  if not FBo.empty then 
    result := FBo.canvas.pixels[X, Y] 
  else if not FBu.empty then 
    result := FBu.canvas.pixels[X, Y] 
  else 
    result := clwhite; 
end; 
 
procedure TPictBtn.WMText( 
 
  var M: TMessage); 
begin 
  DefaultHandler(M); 
  kalkulate; 
end; 
 
procedure TPictBtn.MFont( 
 
  var Msg: TWMSETFONT); 
begin 
  if not(csReading in componentstate) then 
  begin 
    canvas.Font.assign(Font); 
    kalkulate; 
  end; 
end; 
 
procedure TPictBtn.kalkulate; 
var 
  s: string; 
begin 
  Fp := pos('&', Caption); 
  if FAccel then 
  begin 
    if Caption = '&' then 
      Caption := Caption + #32; 
    if Fp = 0 then 
      s := Caption 
    else 
      s := copy(Caption, 1, Fp - 1) + copy(Caption, Fp + 1, maxint); 
  end 
  else 
    s := Caption; 
  FTs := canvas.TextExtent(s); 
  if FCaptLeft < -FTs.cx then 
    FTs.cx := (abs(width) - FTs.cx) div 2 
  else 
    FTs.cx := FCaptLeft; 
  if FCaptTop < -FTs.cy then 
    FTs.cy := (height - FTs.cy) div 2 
  else 
    FTs.cy := FCaptTop; 
  FRect := rect(FTs.cx, FTs.cy, FTs.cx + abs(width), FTs.cy + height); 
  invalidate; 
end; 
 
procedure TPictBtn.setcaptLeft(i: integer); 
begin 
  if i = FCaptLeft then 
    exit; 
  FCaptLeft := i; 
  kalkulate; 
end; 
 
procedure TPictBtn.setcaptTop(i: integer); 
begin 
  if i = FCaptTop then 
    exit; 
  FCaptTop := i; 
  kalkulate; 
end; 
 
procedure TPictBtn.setAccel(b: boolean); 
begin 
  if b = FAccel then 
    exit; 
  FAccel := b; 
  if b then 
    Flags := DT_SINGLELINE 
  else 
    Flags := DT_SINGLELINE or DT_NOPREFIX; 
  kalkulate; 
end; 
 
procedure TPictBtn.Click; 
begin 
  if FYes then 
    inherited; 
  FYes := false; 
end; 
 
procedure TPictBtn.CMDialogChar( 
 
  var aMsg: TWMKey); 
var 
  p: PChar; 
begin 
  if not Enabled or not FAccel or (Fp = 0) then 
    exit; 
  p := @Caption[Fp + 1]; 
  if AnsiUppercase(char(aMsg.CharCode)) = AnsiUppercase(p^) then 
  begin 
    try 
      setfocus; 
      aMsg.result := 1; 
      FYes := true; 
      Click; 
    except 
    end; 
  end; 
end; 
 
procedure TPictBtn.setNot(c: TColor); 
begin 
  c := ColorToRGB(c); 
  if c = FNot then 
    exit; 
  FNot := c; 
  if not Enabled then 
    invalidate; 
end; 
 
procedure TPictBtn.setFTc(c: TColor); 
begin 
  FTc := ColorToRGB(c); 
end; 
 
end.