unit Unit1; 
 
interface 
 
uses 
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, 
  StdCtrls, ExtCtrls; 
 
type 
  TForm1 = class(TForm) 
    Button1: TButton; 
    { im Objektinspektor durch Doppelklick erzeugen -------------- } 
    procedure FormCreate(Sender: TObject); 
    procedure FormDestroy(Sender: TObject); 
    procedure FormMouseDown(Sender: TObject; Button: TMouseButton; 
      Shift: TShiftState; X, Y: Integer); 
    procedure FormMouseUp(Sender: TObject; Button: TMouseButton; 
      Shift: TShiftState; X, Y: Integer); 
    procedure FormResize(Sender: TObject); 
    procedure FormPaint(Sender: TObject); 
    procedure Button1Click(Sender: TObject); 
    { ------------------------------------------------------------ } 
  private 
    { Private-Deklarationen } 
  public 
    procedure WMNChittest(var msg: TWMNChittest); message WM_NChittest; 
    procedure WMSyscolor(var msg: TMessage); message WM_SysColorChange; 
    procedure NCActive(var msg: TMessage); message WM_NCACTIVATE; 
    procedure WMNCPaint(var Msg: TMessage); message WM_NCPAINT; 
    procedure umriss(b: TBitmap; rf, pf: TColor); 
    procedure deaktiv(Sender: TObject); 
    procedure linksrechnen; 
    procedure festlegen; 
    procedure zeichnen; 
    procedure breite; 
    procedure bilder; 
  end; 
 
var 
  Form1: TForm1; 
 
function TransparentBlt(DC: HDC; p2, p3, p4, p5: Integer; 
  DC6: HDC; p7, p8, p9, p10: Integer; p11: UINT): BOOL; stdcall; 
external 'msimg32.dll' name 'TransparentBlt'; 
 
implementation 
 
{$R *.DFM} 
{$R  XPSTYLE.RES} // siehe: http://www.dbrsoftware.de/delphi/xpstyle.php 
 
var 
  links, bwidth, bheight, rando, randr: integer; 
  transpfarb: TColor = clyellow; 
  bttn: array[0..3] of TBitmap; 
  bdown: boolean = false; 
  drin: boolean = false; 
  nein: boolean = false; 
  buttonzahl: integer; 
  H: HDC; 
 
procedure TForm1.FormCreate(Sender: TObject); 
var 
  x: integer; 
begin 
  Application.OnDeactivate := deaktiv; 
  for x := 0 to high(bttn) do bttn[x] := TBitmap.create; 
end; 
 
procedure TForm1.breite; 
var 
  ts: TSize; 
begin 
  // Damit die Form nicht zu sehr zusammengeschoben werden kann: 
  GetTextExtentPoint32A(H, PChar(Caption), length(Caption), ts); 
  constraints.minwidth := succ(buttonzahl) * (bwidth + randr) + ts.cx; 
  //----------------------------------------------------------- 
end; 
 
procedure TForm1.deaktiv(Sender: TObject); 
begin 
  zeichnen; 
end; 
 
procedure TForm1.NCActive(var Msg: TMessage); 
begin 
  inherited; 
  zeichnen; 
end; 
 
procedure TForm1.WMNCPaint(var Msg: TMessage); 
begin 
  inherited; 
  zeichnen; 
end; 
 
procedure TForm1.WMSyscolor(var msg: TMessage); 
begin 
  nein := true; 
  inherited; 
  showmessage('Aufgrund Ihrer Änderung am System'#13#10 + 
    'muss das Programm neu gestartet werden.'); 
end; 
 
procedure TForm1.WMNChittest(var msg: TWMNChittest); 
var 
  x, y: SmallInt; 
begin 
  DefaultHandler(msg); 
  x := msg.xpos - left; 
  y := msg.ypos - top; 
  if (x >= links + 3) and (x <= links + bwidth + 2) 
    and (y > rando + 1) and (y < rando + bheight + 2) 
    then begin 
    drin := true; 
    msg.result := htclient; 
    zeichnen; 
  end else begin 
    drin := false; 
    zeichnen; 
  end; 
end; 
 
procedure TForm1.umriss(b: TBitmap; rf, pf: TColor); 
begin 
  with b, canvas do begin 
    width := bwidth; 
    height := bheight; 
    pen.color := rf; 
    brush.style := bsclear; 
    roundrect(0, 0, width, height, 5, 5); 
    pixels[0, 0] := transpfarb; 
    pixels[width - 1, 0] := transpfarb; 
    pixels[0, height - 1] := transpfarb; 
    pixels[width - 1, height - 1] := transpfarb; 
    pixels[1, 0] := pf; 
    pixels[0, 1] := pf; 
    pixels[width - 2, 0] := pf; 
    pixels[width - 1, 1] := pf; 
    pixels[1, height - 1] := pf; 
    pixels[0, height - 2] := pf; 
    pixels[width - 2, height - 1] := pf; 
    pixels[width - 1, height - 2] := pf; 
  end; 
end; 
 
procedure TForm1.linksrechnen; 
begin 
  links := width - buttonzahl * (bwidth + randr); 
  case buttonzahl of 
    1: dec(links, randr); 
    2: dec(links, 3); 
    4: inc(links); 
  else dec(links); 
  end; 
end; 
 
procedure TForm1.bilder; 
var 
  f, rf, pf, rf2, pf2: TColor; 
  bf, b4, h4, i: integer; 
  hlp: TBitmap; 
  h: THandle; 
  d: HDC; 
  procedure symbol(b: TBitmap; frb: TColor); 
  begin 
    with b.canvas do begin 
      // -- Symbol zeichnen (hier: einfacher Kreis) ---------------- 
      b4 := bwidth div 4; 
      h4 := bheight div 4; 
      brush.color := frb; 
      pen.style := psClear; 
      ellipse(b4, h4, bwidth - b4, bheight - h4); 
      pen.style := psSolid; 
      pen.color := clwhite; 
      arc(b4, h4, bwidth - b4, bheight - h4, bwidth, 0, 0, bheight); 
      pen.color := $555555; 
      arc(b4, h4, bwidth - b4, bheight - h4, 0, bheight, bwidth, 0); 
      // ----------------------------------------------------------- 
    end; 
  end; 
begin 
  h := findwindow(pchar('Shell_TrayWnd'), nil); 
  d := getwindowdc(h); 
  f := colortorgb(getpixel(d, 0, 0)); 
  deletedc(d); 
  bf := getbvalue(f); 
  if bf > 190 
    then begin 
    rf := $8F756B; 
    pf := $A88888; 
    rf2 := $AFA5A5; 
    pf2 := $B5B5B5; 
  end else begin 
    rf := clwhite; 
    if bf > 180 then begin 
      pf := $EFAFAF; 
      rf2 := $DFD5D5; 
      pf2 := $E5B0B0; 
    end else begin 
      pf := $F0F5F0; 
      rf2 := $F8FFF8; 
      pf2 := $F5F8F5; 
    end; 
  end; 
  for i := 0 to high(bttn) do begin 
    bttn[i].width := bwidth + randr; 
    bttn[i].height := bheight + rando; 
  end; 
  hlp := TBitmap.create; 
  // -------------------------------------------------------------- 
  hlp.loadfromfile('TasteO.bmp'); 
  bttn[0].canvas.StretchDraw(rect(0, 0, bwidth, bheight), hlp); 
  hlp.loadfromfile('TasteU.bmp'); 
  bttn[1].canvas.StretchDraw(rect(0, 0, bwidth, bheight), hlp); 
  hlp.loadfromfile('TasteH.bmp'); 
  bttn[2].canvas.StretchDraw(rect(0, 0, bwidth, bheight), hlp); 
  hlp.loadfromfile('TasteD.bmp'); 
  bttn[3].canvas.StretchDraw(rect(0, 0, bwidth, bheight), hlp); 
  // ----- besser wäre, die Bitmaps aus einer Ressource holen ----- 
  hlp.free; 
  for i := 0 to 2 do umriss(bttn[i], rf, pf); 
  umriss(bttn[3], rf2, pf2); 
  for i := 0 to 1 do symbol(bttn[i], clgray); 
  symbol(bttn[2], clsilver); 
  symbol(bttn[3], $E0E0E0); 
end; 
 
procedure TForm1.festlegen; 
begin 
  rando := GetSystemMetrics(SM_CYFRAME); 
  randr := GetSystemMetrics(SM_CXFRAME); 
  bheight := GetSystemMetrics(SM_CYSIZE) - rando; 
  bwidth := GetSystemMetrics(SM_CXSIZE) - randr; 
  if biSystemMenu in BorderIcons then begin 
    if (biMinimize in BorderIcons) or (biMaximize in BorderIcons) then 
      buttonzahl := 4 else if (biHelp in BorderIcons) then buttonzahl := 3 
    else buttonzahl := 2; 
  end else buttonzahl := 1; 
end; 
 
procedure TForm1.zeichnen; 
var 
  i: integer; 
begin 
  if application.terminated or nein then exit; 
  if drin then i := ord(not bdown) + 1 
  else i := ord(handle <> getactivewindow) * 3; 
  TransparentBlt(H, links + 3, rando + 2, bwidth, bheight, 
    bttn[i].canvas.handle, 0, 0, bwidth, bheight, transpfarb); 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject); 
var 
  x: integer; 
begin 
  for x := 0 to high(bttn) do bttn[x].free; 
  deletedc(H); 
end; 
 
procedure TForm1.FormResize(Sender: TObject); 
begin 
  linksrechnen; 
end; 
 
procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton; 
  Shift: TShiftState; X, Y: Integer); 
begin 
  if drin then begin 
    bdown := true; 
    zeichnen; 
  end; 
end; 
 
procedure TForm1.FormPaint(Sender: TObject); 
begin 
  H := GetWindowDC(handle); 
  festlegen; 
  linksrechnen; 
  breite; 
  bilder; 
  zeichnen; 
end; 
 
procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton; 
  Shift: TShiftState; X, Y: Integer); 
begin 
  if bdown then begin 
    bdown := false; 
    zeichnen; 
    Application.processmessages; 
    if drin then 
    // Hier alles, was beim Anklicken des Buttons passieren soll, z.B.: 
 
      beep; 
 
    // ----------------------------------------------------------------- 
  end; 
end; 
 
 
// zum Testen: 
 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
  BorderIcons := [biSystemMenu]; 
end; 
 
end.