// Getestet mit D4 unter XP

unit XButton; 
 
interface 
 
uses 
  Windows, Messages, Sysutils, Classes, Graphics, Controls, Stdctrls; 
 
type 
  TXShading = (xbtnBlue, xbtnBrown, xbtnGray, xbtnGreen, 
    xbtnOrange, xbtnPurple, xbtnRed, xbtnYellow); 
  TXDirection = (xbtnHorizontal, xbtnVertical); 
  TXArray = array[0..2] of Integer; 
  TXButton = class(TButton) 
  private 
    FBm: TBitmap; 
    FShd: TXShading; 
    FWinkel: Integer; 
    FDrct: TXDirection; 
    FCol1, FCol2, FCol3: TXArray; 
    FRh, FRd, FRm, FRCh, FRCd, FRCm: TColor; 
    Fdis, Ffoc, FFRect, FCRect, FTM, Fdown, FMerk, FCapt, 
      Fdef, FDrin, Fstand, FBright: boolean; 
  protected 
    procedure Capchg(var LMsg: TMessage); message WM_CAPTURECHANGED; 
    procedure CreateParams(var Params: TCreateParams); override; 
    procedure MEnter(var EMsg: TMessage); message CM_MouseEnter; 
    procedure MLeave(var LMsg: TMessage); message CM_MouseLeave; 
    procedure Paint(var Msg: TWMDrawItem); message CN_DRAWITEM; 
    procedure SetFont(var Msg: TWMSETFONT); message WM_SETFONT; 
    procedure setbuttonstyle(ADefault: Boolean); override; 
    procedure setDirection(d: TXDirection); 
    procedure setFFRect(b: boolean); 
    procedure setFCRect(b: boolean); 
    procedure setBright(b: boolean); 
    procedure setStand(b: boolean); 
    procedure setshd(s: TXShading); 
    procedure setFTM(b: boolean); 
    procedure zeichnebutton; 
    procedure RotateFont; 
    procedure faerbenR; 
    procedure faerbenF; 
    procedure faerben; 
    procedure prfFont; 
    procedure hoch; 
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; 
      x, y: Integer); override; 
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; 
      x, y: Integer); override; 
  public 
    constructor Create(Owner: TComponent); override; 
    destructor Destroy; override; 
    procedure Click; override; 
  published 
    property Color; 
    property ParentColor; 
    property TextMoving: boolean read FTM write setFTM; 
    property Shading: TXShading read FShd write setshd; 
    property Bright: boolean read FBright write setbright; 
    property Kind: TXDirection read FDrct write setDirection; 
    property FocusFrame: boolean read FFRect write setFFRect; 
    property CaptureFrame: boolean read FCRect write setFCRect; 
    property DefaultFrames: boolean read Fstand write setStand; 
  end; 
 
procedure Register; 
 
implementation 
 
procedure Register; 
begin 
  RegisterComponents('DBR', [TXButton]); 
end; 
 
procedure TXButton.CreateParams(var Params: TCreateParams); 
begin 
  inherited CreateParams(Params); 
  with Params do style := style or BS_OWNERDRAW; 
end; 
 
constructor TXButton.Create(Owner: TComponent); 
var x: integer; 
begin 
  FBm := TBitmap.create; 
  FShd := xbtnGray; 
  FFRect := true; 
  FCRect := true; 
  FTM := true; 
  for x := 0 to 2 do begin 
    FCol1[x] := $FF; 
    FCol3[x] := $B0; 
  end; 
  FDrct := xbtnHorizontal; 
  Fstand := true; 
  FBright := true; 
  inherited Create(Owner); 
  Font.Color := clBlack; 
  Constraints.MinHeight := 10; 
  Constraints.MinWidth := 10; 
  height := 25; 
  width := 75; 
  faerben; 
end; 
 
destructor TXButton.Destroy; 
begin 
  FBm.free; 
  inherited Destroy; 
end; 
 
procedure TXButton.zeichnebutton; 
var 
  s: string; 
  wm1, hm1, wm2, hm2, p: integer; 
  cob, cunt: TXArray; 
  cpen: TColor; 
  sz: TSize; 
 
  procedure DrawGradient(C1, C2: TXArray); 
  var 
    D: TXArray; 
    Y, H: Integer; 
    procedure rechne; 
      function erg(i: integer): byte; 
      begin 
        result := Round(C1[i] + (D[i] * Y / H)); 
      end; 
    begin 
      FBm.canvas.Brush.Color := RGB(erg(0), erg(1), erg(2)); 
    end; 
  begin 
    for H := 0 to 2 do D[H] := C2[H] - C1[H]; 
    if Fdrct = xbtnVertical then begin 
      H := pred(width); 
      for y := 0 to H do begin 
        rechne; 
        FBm.canvas.FillRect(Rect(Y, 0, succ(Y), height)); 
      end; 
    end else begin 
      H := pred(height); 
      for y := 0 to H do begin 
        rechne; 
        FBm.canvas.FillRect(Rect(0, Y, width, succ(Y))); 
      end; 
    end; 
  end; 
 
  procedure drwtxt(i: integer); 
  begin 
    with Fbm.canvas do begin 
      if FDrct = xbtnVertical then 
        TextOut(i + (width - sz.cy) shr 1, 
          i + height - (height - sz.cx) shr 1, s) 
      else TextOut(i + (width - sz.cx) shr 1, i + 
          (height - sz.cy) shr 1, s); 
    end; 
  end; 
 
  procedure striche(r: TColor; v: byte); 
  var a, b, c, d: integer; 
  begin 
    a := 2 - v; 
    b := height - 3 + v; 
    c := width - 3 + v; 
    d := 3 - v; 
    with FBm.Canvas do begin 
      pen.color := r; 
      if FDrct = xbtnHorizontal then begin 
        moveto(a, 3); 
        lineto(a, b); 
        moveto(c, 3); 
        lineto(c, b); 
      end else begin 
        moveto(d, a); 
        lineto(c, a); 
        moveto(d, b); 
        lineto(c, b); 
      end; 
    end; 
  end; 
 
  procedure rahmen(r1, r2, r3, r4: TColor); 
  begin 
    with FBm.Canvas do begin 
      pen.color := r2; 
      if FDrct = xbtnHorizontal then begin 
        rectangle(1, 2, wm1, hm2); 
        pen.color := r3; 
        moveto(2, hm2); 
        lineto(wm1, hm2); 
        pen.color := r1; 
        moveto(1, 1); 
        lineto(wm1, 1); 
        striche(r4, 0); 
      end else begin 
        rectangle(2, 1, wm2, hm1); 
        pen.color := r3; 
        moveto(wm2, 2); 
        lineto(wm2, hm2); 
        pen.color := r1; 
        moveto(1, 2); 
        lineto(1, hm2); 
        striche(r4, 0); 
      end; 
    end; 
  end; 
 
begin 
  FBm.width := width; 
  FBm.height := height; 
  if FDis then begin 
    cob := FCol1; 
    cunt := FCol3; 
    cpen := clgray; 
  end else begin 
    cpen := $484848; 
    if FDown then begin 
      cob := FCol2; 
      cunt := FCol1; 
    end else begin 
      cob := FCol1; 
      cunt := FCol2; 
    end; 
  end; 
  DrawGradient(cob, cunt); 
  wm1 := pred(width); 
  wm2 := width - 2; 
  hm1 := pred(height); 
  hm2 := height - 2; 
  with FBm.canvas do begin 
    brush.color := Color; 
    fillrect(rect(0, 0, 2, 2)); 
    fillrect(rect(0, hm2, 2, height)); 
    fillrect(rect(wm2, 0, width, 2)); 
    fillrect(rect(wm2, hm2, width, height)); 
    brush.style := bsclear; 
    p := pos('&', Caption); 
    if p = length(Caption) then p := 0; 
    s := copy(Caption, 1, p - 1) + copy(Caption, p + 1, maxint); 
    sz := textextent(s); 
    if Fdis then begin 
      font.color := clWhite; 
      drwtxt(1); 
      font.color := clGray; 
    end else if (FCapt or FMerk and not FDown) and FCRect 
      then begin 
      rahmen(FRCh, FRCm, FRCd, FRCm) 
    end else if not FDown then begin 
      if (Ffoc or FDef) and FFRect then 
        rahmen(FRh, FRm, FRd, clwhite) 
      else striche(clwhite, 1); 
    end else begin 
      pen.color := clwhite; 
      roundrect(1, 1, wm1, hm1, 5, 5); 
    end; 
    drwtxt(ord(FTM and FDown)); 
    pen.color := cpen; 
    roundrect(0, 0, width, height, 5, 5); 
  end; 
end; 
 
procedure TXButton.paint(var Msg: TWMDrawItem); 
begin 
  with Msg.DrawItemStruct^ do begin 
    Fdis := itemState and ODS_DISABLED > 0; 
    Ffoc := itemState and ODS_FOCUS > 0; 
    if not Fdis then FBm.canvas.font.color := Font.color; 
    zeichnebutton; 
    bitblt(hdc, 0, 0, width, height, FBm.canvas.handle, 0, 0, srcCopy); 
  end; 
  Msg.Result := 1; 
end; 
 
procedure TXButton.MEnter(var EMsg: TMessage); 
begin 
  inherited; 
  FDown := FMerk; 
  FCapt := not FDown; 
  FDrin := true; 
  repaint; 
end; 
 
procedure TXButton.MLeave(var LMsg: TMessage); 
begin 
  inherited; 
  FDrin := false; 
  hoch; 
end; 
 
procedure TXButton.hoch; 
begin 
  Fdown := false; 
  FCapt := FDrin; 
  repaint; 
end; 
 
procedure TXButton.Click; 
begin 
  hoch; 
  inherited; 
end; 
 
procedure TXButton.MouseUp(Button: TMouseButton; Shift: TShiftState; 
  x, y: Integer); 
begin 
  if Button = mbLeft then hoch; 
  inherited; 
end; 
 
procedure TXButton.MouseDown(Button: TMouseButton; Shift: TShiftState; 
  x, y: Integer); 
begin 
  if Button = mbLeft then begin 
    FDown := true; 
    FMerk := true; 
    FCapt := false; 
    repaint; 
  end; 
  inherited; 
end; 
 
procedure TXButton.SetButtonStyle(ADefault: Boolean); 
begin 
  FDef := ADefault; 
  repaint; 
end; 
 
procedure TXButton.setFFRect(b: boolean); 
begin 
  if b = FFRect then exit; 
  FFRect := b; 
  repaint; 
end; 
 
procedure TXButton.setFCRect(b: boolean); 
begin 
  if b = FCRect then exit; 
  FCRect := b; 
  repaint; 
end; 
 
procedure TXButton.setFTM(b: boolean); 
begin 
  if b = FTM then exit; 
  FTM := b; 
  repaint; 
end; 
 
procedure TXButton.capchg(var LMsg: TMessage); 
begin 
  inherited; 
  FMerk := false; 
  hoch; 
end; 
 
procedure TXButton.faerbenF; 
var x: integer; 
 
  function dunkel(a: integer): integer; 
  asm 
  sub eax, $60 
  cmp eax, 0 
  jge @fertig 
  xor eax, eax 
 @fertig: 
  end; 
 
begin 
  case FShd of 
    xbtnGreen: begin 
        FCol2[0] := $A5; 
        FCol2[1] := $E5; 
        FCol2[2] := $A5; 
      end; 
    xbtnRed: begin 
        FCol2[0] := $FF; 
        FCol2[1] := $AE; 
        FCol2[2] := $AE; 
      end; 
    xbtnBrown: begin 
        FCol2[0] := $D0; 
        FCol2[1] := $B0; 
        FCol2[2] := $80; 
      end; 
    xbtnOrange: begin 
        FCol2[0] := $FF; 
        FCol2[1] := $DA; 
        FCol2[2] := $95; 
      end; 
    xbtnYellow: begin 
        FCol2[0] := $D8; 
        FCol2[1] := $D8; 
        FCol2[2] := $99; 
      end; 
    xbtnPurple: begin 
        FCol2[0] := $E8; 
        FCol2[1] := $BB; 
        FCol2[2] := $E8; 
      end; 
    xbtnBlue: begin 
        FCol2[0] := $C5; 
        FCol2[1] := $C5; 
        FCol2[2] := $FF; 
      end; 
  else begin 
      FCol2[0] := $BF; 
      FCol2[1] := $BF; 
      FCol2[2] := $BF; 
    end; 
  end; 
  if not FBright then 
    for x := 0 to 2 do 
      FCol2[x] := dunkel(FCol2[x]); 
end; 
 
procedure TXButton.faerbenR; 
begin 
  if Fstand then begin 
    FRh := $F0D8B8; 
    FRd := $EE8269; 
    FRm := $ECBEA0; 
    FRCh := $CFF0FF; 
    FRCd := $0097E5; 
    FRCm := $71CEFC 
  end else 
    case FShd of 
      xbtnBlue: begin 
          FRh := $F0D8B8; 
          FRd := $EE8269; 
          FRm := $ECBEA0; 
          FRCh := $FFA5A5; 
          FRCd := $E85050; 
          FRCm := $FF8080; 
        end; 
      xbtnGreen: begin 
          FRh := $80FF80; 
          FRd := $00C000; 
          FRm := $66E066; 
          FRCh := $00F000; 
          FRCd := $008000; 
          FRCm := $00C000; 
        end; 
      xbtnRed: begin 
          FRh := $BABAFF; 
          FRd := $3333F0; 
          FRm := $9999FF; 
          FRCh := $9999FF; 
          FRCd := $3333B0; 
          FRCm := $6666EF; 
        end; 
      xbtnBrown: begin 
          FRh := $B0C0E0; 
          FRd := $444499; 
          FRm := $A0A0C0; 
          FRCh := $70A0C0; 
          FRCd := $505080; 
          FRCm := $9090A0; 
        end; 
      xbtnOrange: begin 
          FRh := $A8BFFF; 
          FRd := $0875F0; 
          FRm := $7898F9; 
          FRCh := $6699FF; 
          FRCd := $0066B0; 
          FRCm := $7080D8; 
        end; 
      xbtnYellow: begin 
          FRh := $00E0E0; 
          FRd := $009999; 
          FRm := $22C0C0; 
          FRCh := $00C0C0; 
          FRCd := $006666; 
          FRCm := $00A0A0; 
        end; 
      xbtnPurple: begin 
          FRh := $F0B0F0; 
          FRd := $C022C0; 
          FRm := $FF80FF; 
          FRCh := $D099D0; 
          FRCd := $A833A8; 
          FRCm := $DA40DA; 
        end; 
    else begin 
        FRh := $C8C8C8; 
        FRd := $909090; 
        FRm := $B4B4B4; 
        FRCh := $B0B0B0; 
        FRCd := $666666; 
        FRCm := $909090; 
      end; 
    end; 
end; 
 
procedure TXButton.faerben; 
begin 
  faerbenF; 
  faerbenR; 
end; 
 
procedure TXButton.setshd(s: TXShading); 
begin 
  if FShd = s then exit; 
  FShd := s; 
  faerben; 
  repaint; 
end; 
 
procedure TXButton.RotateFont; 
var 
  Logfont: TLogFont; 
begin 
  GetObject(FBm.canvas.Font.Handle, sizeof(Logfont), @Logfont); 
  Logfont.lfEscapement := FWinkel; 
  Logfont.lfOrientation := Logfont.lfEscapement; 
  Fbm.canvas.Font.Handle := CreateFontIndirect(Logfont); 
end; 
 
procedure TXButton.prfFont; 
var tm: TTextMetric; 
begin 
  GetTextMetrics(FBm.canvas.Handle, tm); 
  if tm.tmPitchAndFamily and TMPF_TRUETYPE = 0 
    then FBm.Canvas.Font.Name := 'Arial'; 
end; 
 
procedure TXButton.setDirection(d: TXDirection); 
var h: integer; 
begin 
  if d = FDrct then exit; 
  FDrct := d; 
  if FDrct = xbtnHorizontal then begin 
    FWinkel := 0; 
    FBm.canvas.Font.Name := Font.Name; 
  end else begin 
    FWinkel := 900; 
    prfFont; 
  end; 
  if not (csReading in componentstate) 
    then begin 
    h := height; 
    height := width; 
    width := h; 
  end; 
  RotateFont; 
  repaint; 
end; 
 
procedure TXButton.setStand(b: boolean); 
begin 
  if Fstand = b then exit; 
  Fstand := b; 
  faerbenR; 
  repaint; 
end; 
 
procedure TXButton.setBright(b: boolean); 
begin 
  if Fbright = b then exit; 
  FBright := b; 
  faerbenF; 
  repaint; 
end; 
 
procedure TXButton.SetFont(var Msg: TWMSETFONT); 
begin 
  FBm.canvas.Font := Font; 
  if FDrct = xbtnVertical then begin 
    prfFont; 
    RotateFont; 
  end; 
  repaint; 
end; 
 
end.