unit Unit1; 
 
interface 
 
uses 
  Windows, 
  Messages, 
  SysUtils, 
  Classes, 
  Graphics, 
  Controls, 
  Forms, 
  ExtCtrls; 
 
type 
  TForm1 = class(TForm) 
    Timer1: TTimer; 
    procedure FormCreate(Sender: TObject); 
    procedure FormDestroy(Sender: TObject); 
    procedure FormMouseUp(Sender: TObject; Button: TMouseButton; 
      Shift: TShiftState; X, Y: Integer); 
    procedure FormMouseDown(Sender: TObject; Button: TMouseButton; 
      Shift: TShiftState; X, Y: Integer); 
    procedure FormShow(Sender: TObject); 
    procedure FormPaint(Sender: TObject); 
    procedure Timer1Timer(Sender: TObject); 
  private 
    s1, s2: string; 
    ms: MEMORYSTATUS; 
    r1, r2, r3: HRGN; 
    bm, hlp: TBitmap; 
    fname: TFontname; 
    ersteFarbe, zweiteFarbe: TColor; 
    fsize, links, zweiteZeile, Stellen: integer; 
    AusgabeBei: TPoint; 
    procedure ZahlRegion; 
    procedure StaticRegion; 
    function AbfrageUser: string; 
    function AbfrageGesamt: string; 
    function BuildRegion(bmp: TBitmap; rgn: HRGN): HRGN; 
  public 
    { Public-Deklarationen } 
  end; 
 
var 
  Form1: TForm1; 
 
implementation 
 
{$R *.DFM} 
 
function TForm1.AbfrageGesamt: string; 
begin 
  GlobalMemoryStatus(ms); 
  result := inttostr(trunc(ms.dwTotalPhys / 1024)); 
  result := stringofchar(#32, Stellen - length(result)) + result; 
end; 
 
function TForm1.AbfrageUser: string; 
begin 
  GlobalMemoryStatus(ms); 
  result := inttostr(trunc(ms.dwAvailPhys / 1024)); 
  result := stringofchar(#32, Stellen - length(result)) + result; 
end; 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  scaled := false; 
  AusgabeBei := point(55, 1); 
  ersteFarbe := $10; // clBlack ist für den Hintergrund reserviert 
  zweiteFarbe := clRed; 
  bm := TBitmap.create; 
  hlp := TBitmap.create; 
  borderstyle := bsNone; 
  cursor := crHandpoint; 
  ms.dwlength := sizeof(MEMORYSTATUS); 
  Stellen := 7; 
  fsize := 12; 
  fname := 'Courier New'; 
  s2 := 'Freier Arbeitsspeicher:' + Stringofchar(#32, Stellen + 2) + 'KB'; 
  s1 := 'Arbeitsspeicher gesamt: '; 
  with canvas do begin 
    font.name := fname; 
    font.size := fsize; 
    zweiteZeile := textheight(s1) + 2; 
    clientheight := zweiteZeile + textheight(s2) + 2; 
    clientwidth := textwidth(s2) + 2; 
    links := textwidth(s1); 
    brush.color := zweiteFarbe; 
  end; 
  s1 := s1 + AbfrageGesamt + ' KB'; 
  setwindowpos(handle, HWND_TOPMOST, 
    screen.width - clientwidth - AusgabeBei.x, AusgabeBei.y, 0, 0, 
    SWP_SHOWWINDOW or SWP_NOSIZE); 
  StaticRegion; 
  ZahlRegion; 
  Timer1.interval := 1000; 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject); 
begin 
  hlp.free; 
  bm.free; 
end; 
 
function TForm1.BuildRegion(bmp: TBitmap; rgn: HRGN): HRGN; 
var p: PBytearray; 
  y, x: integer; 
  hr: HRGN; 
  function kombine(a: integer): integer; 
  var b: integer; 
  begin 
    b := -1; 
    while a <= bmp.width * 3 - 1 do begin 
      if (p[a] <> 0) or (p[a + 1] <> 0) or (p[a + 2] <> 0) 
        then begin 
        b := a div 3; 
        break; 
      end; 
      inc(a, 3); 
    end; 
    result := a; 
    if b < 0 then exit; 
    while a <= bmp.width * 3 - 1 do begin 
      if (p[a] = 0) and (p[a + 1] = 0) and (p[a + 2] = 0) 
        then break; 
      inc(a, 3); 
    end; 
    result := a; 
    a := a div 3; 
    hr := CreateRectRgn(b, y, a, y + 1); 
    CombineRgn(rgn, rgn, hr, RGN_OR); 
    DeleteObject(hr); 
  end; 
begin 
  rgn := CreateRectRgn(0, 0, 0, 0); 
  for y := 0 to bmp.height - 1 do begin 
    p := bmp.ScanLine[y]; 
    x := 0; 
    while x <= bmp.width * 3 - 1 do x := kombine(x); 
  end; 
  result := rgn; 
end; 
 
procedure TForm1.StaticRegion; 
begin 
  with bm do begin 
    width := clientwidth; 
    height := clientheight; 
    pixelformat := pf24bit; 
    with canvas do begin 
      brush.color := clblack; 
      fillrect(cliprect); 
      font.name := fname; 
      font.size := fsize; 
      font.color := ersteFarbe; 
      textout(1, 1, s1); 
      font.color := zweiteFarbe; 
      textout(1, zweiteZeile, s2); 
    end; 
  end; 
  brush.bitmap := bm; 
  with hlp do begin 
    width := bm.width; 
    height := bm.height; 
    pixelformat := pf24bit; 
    with canvas do begin 
      brush.color := clblack; 
      font.color := zweiteFarbe; 
      font.name := fname; 
      font.size := fsize; 
    end; 
  end; 
  r1 := BuildRegion(bm, r1); 
  bm.dormant; 
end; 
 
procedure TForm1.ZahlRegion; 
begin 
  with hlp.canvas do begin 
    fillrect(cliprect); 
    textout(links, zweiteZeile, AbfrageUser); 
  end; 
  r2 := BuildRegion(hlp, r2); 
  r3 := CreateRectRgn(0, 0, 0, 0); 
  CombineRgn(r3, r1, r2, RGN_OR); 
  setwindowRgn(handle, r3, true); 
end; 
 
procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton; 
  Shift: TShiftState; X, Y: Integer); 
begin 
  if button = mbleft then begin 
    releaseCapture; 
    perform(WM_SysCommand, $F012, 0); 
  end; 
end; 
 
procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton; 
  Shift: TShiftState; X, Y: Integer); 
begin 
  if button = mbright then close; 
end; 
 
procedure TForm1.Timer1Timer(Sender: TObject); 
begin 
  ZahlRegion; 
end; 
 
procedure TForm1.FormPaint(Sender: TObject); 
begin 
  canvas.fillrect(rect(links, zweiteZeile, clientwidth, clientheight)); 
end; 
 
procedure TForm1.FormShow(Sender: TObject); 
begin 
  showWindow(application.handle, sw_hide); 
end; 
 
end.