// Componente für einen Button, dessen Aussehen von Bitmaps bestimmt wird.
// Optional kann er mittels "Caption" eine Beschriftung erhalten. Wie die
// unten stehende Tabelle zeigt, kann der Button bei "MouseOver" oder bei
// "not Enabled" eine andere Erscheinung haben.

// Überarbeitet 11.04.2014
 

// Erläuterung der Eigenschaften:

// CaptionLeft (Integer)
// Bestimmt die linke Seite von Caption. Ist der Wert kleiner als Caption
// breit ist, wird die Schrift automatisch in der horizontalen Mitte gezeigt.

// CaptionTop (Integer)
// Bestimmt die obere Kante von Caption. Ist der Wert kleiner als Caption
// hoch ist, wird die Schrift automatisch in der vertikalen Mitte gezeigt.

//
ShowAccelChar (Boolean)
// Die Eigenschaft legt fest, in welcher Form ein kaufmännisches "Und" (&)
// im Beschriftungstext dargestellt wird und ob das Zeichen, das unmittelbar
// auf ein "&" folgt, als Tastenkürzel interpretiert und mit einem Unterstrich
// versehen wird;

//
Transparency (Boolean)
// Pseudo-Transparenz. Das Pixel in der linken oberen Ecke bestimmt dabei
// die Farbe, welche angeblich durchsichtig wird. In Wirklichkeit wird hier
// die Grundfarbe von "Parent" übernommen.

//
PictDown (TBitmap)
// Bitmap für den gedrückten Button. Kann 1 bis 3 Abbildungen enthalten
// Siehe Tabelle.

// PictUp (TBitmap)
// Bitmap für den ungedrückten Button. Kann 1 bis 3 Abbildungen enthalten
// Siehe Tabelle.

//
PictType (TPicts)
// Muss ensprechend der Anzahl der Bilder eingestellt werden (siehe Tabelle).
// pbOne: Nur ein Bild. "MouseOver" oder "not Enabled" wird nicht angezeigt.
// pbOver: Zwei Bilder. "not Enabled" wird nicht angezeigt.
// pbNotEnabled: Zwei Bilder. "MouseOver" wird nicht angezeigt.
// pbAll: Drei Bilder.

//
DisabledFont (TColor)
// Farbe von "Font.Color" wenn der Button "not Enabled" ist.

// Down (Boolean)
// Zeigt an, ob der Button gedrückt ist oder nicht.

// Snap (Boolean)
// Bei "True" rastet der Button ein.

//
Group (Byte)
// Button mit gleichem Wert > 0 reagieren aufeinander.

//
AllowUp (Boolean)
// Bestimmt, ob Buttons innerhalb einer Gruppe selbst ausrasten dürfen,
// oder aber nur ausrasten, wenn ein anderer Button gedrückt wird.

//
CaptionMove (Boolean)
// Bestimmt,ob sich Caption mit absenkt, wenn der Button gedrückt wird.


// Getestet mit D4 unter XP
 

  Die Komponente enhält keinerlei Bilder.
Die hier angezeigten Abbildungen sind
lediglich ein Beispiel!
PictUp
PictDown
  pbOne pbOver pbNotEnabled pbAll
  Achten Sie bitte darauf, dass die Bilder für "Enabled = False"
nicht als gedrückt dargestellt werden sollten!
Beispiel eines Buttons mit "Caption"

 


 

unit PictBtn; 
 
interface 
 
uses 
  Windows, SysUtils, Classes, Graphics, Messages, Controls; 
 
type 
  TPicts = (pbOne, pbOver, pbNotEnabled, pbAll); 
 
  TPictBtn = class(TCustomControl) 
  private 
    FAccel, FDown, FTrans, FRast, FZ, FDrin, FDesp, FYes, FMove, FF: boolean; 
    Fleft, FG, Fp, FCaptLeft, FCaptTop: integer; 
    FTc, FNot: TColor; 
    FBu, FBo: TBitmap; 
    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 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; 
  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 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; 
  end; 
 
procedure Register; 
 
implementation 
 
procedure Register; 
begin 
  RegisterComponents('DBR', [TPictBtn]); 
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 
      zeigen(FBu) 
    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 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]; 
  width := 70; 
  height := 20; 
  Flags := DT_SINGLELINE; 
  FBo := TBitmap.Create; 
  FBu := 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; 
  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.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; 
  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; 
    click; 
    inherited; 
  end; 
end; 
 
procedure TPictBtn.MouseMove(Shift: TShiftState; 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 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.


 

Zugriffe seit 6.9.2001 auf Delphi-Ecke