DBR Delphi-Ecke

// Es wird ein Rubbel-Los nachgebildet. Mit gedrücktgehaltener linker
// Maustaste werden Teile einer grauen Fläche weggearbeitet und darunter
// kommt ein Bild (eine Schrift) zum Vorschein.

// Getestet mit D4 unter XP

// Variante 1: Mit 2 Timage und kreisförmigen Abtragen,
aber "DoubleBuffered" muss TRUE sein

const 
  unten: boolean = false; 
  radius: integer = 7; 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  doublebuffered := true; 
  Image1.Picture.bitmap.loadfromfile('d:\bilder\auto.bmp'); 
  Image2.boundsrect := Image1.boundsrect; 
  Image2.picture.bitmap.width := Image1.width; 
  Image2.picture.bitmap.height := Image1.height; 
  Image2.picture.bitmap.canvas.brush.color := clgray; 
  Image2.picture.bitmap.canvas.fillrect 
    (Image2.picture.bitmap.canvas.cliprect); 
  Image2.picture.bitmap.transparentcolor := clred; 
  Image2.picture.bitmap.canvas.brush.color := clred; 
  Image2.picture.bitmap.canvas.pen.style := psclear; 
  Image2.transparent := true; 
end; 
 
procedure TForm1.Image2MouseDown(Sender: TObject; Button: TMouseButton; 
  Shift: TShiftState; X, Y: Integer); 
begin 
  unten := true; 
end; 
 
procedure TForm1.Image2MouseUp(Sender: TObject; Button: TMouseButton; 
  Shift: TShiftState; X, Y: Integer); 
begin 
  unten := false; 
end; 
 
procedure TForm1.Image2MouseMove(Sender: TObject; Shift: TShiftState; X, 
  Y: Integer); 
begin 
  if unten then Image2.picture.bitmap.canvas.ellipse(x - radius, y - radius, 
      x + radius, y + radius); 
end;

// ---------------------------------------------------------

// Variante 2: Mit 1 Timage und 1 TBitmap, quadratischem Abtragen,
DoubleBuffered bleibt FALSE

const 
  unten: boolean = false; 
  halb: integer = 5; 
 
var 
  bild: TBitmap; 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  bild := TBitmap.create; 
  bild.loadfromfile('d:\bilder\auto.bmp'); 
  Image1.picture.bitmap.width := bild.width; 
  Image1.picture.bitmap.height := bild.height; 
  Image1.picture.bitmap.canvas.brush.color := clgray; 
  Image1.picture.bitmap.canvas.fillrect 
    (Image1.picture.bitmap.canvas.cliprect); 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject); 
begin 
  bild.free; 
end; 
 
procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton; 
  Shift: TShiftState; X, Y: Integer); 
begin 
  unten := true; 
end; 
 
procedure TForm1.Image1MouseUp(Sender: TObject; Button: TMouseButton; 
  Shift: TShiftState; X, Y: Integer); 
begin 
  unten := false; 
end; 
 
procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X, 
  Y: Integer); 
var r: TRect; 
begin 
  if unten then begin 
    r := rect(x - halb, y - halb, x + halb, y + halb); 
    Image1.Picture.bitmap.canvas.copyrect(r, bild.canvas, r); 
  end; 
end;

// ---------------------------------------------------------

// Variante 3: Mit 1 Timage und 2 TBitmap. Ein Bitmap stellte eine Maske dar,
was im Beispiel einen zackigen Rand ergibt und einer echten
"Rubbelei" dadurch näher kommt

Beispiel-Schablone

const 
  unten: boolean = false; 
 
var 
  bild, schablone: TBitmap; 
  halb: integer; 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  bild := TBitmap.create; 
  schablone := TBitmap.create; 
  bild.loadfromfile('d:\bilder\auto.bmp'); 
  schablone.loadfromfile('d:\bilder\stern.bmp'); 
  halb := schablone.width div 2; 
  Image1.autosize := true; 
  schablone.monochrome := true; 
  Image1.picture.bitmap.width := bild.width; 
  Image1.picture.bitmap.height := bild.height; 
  Image1.picture.bitmap.canvas.brush.color := clgray; 
  Image1.picture.bitmap.canvas.fillrect 
    (Image1.picture.bitmap.canvas.cliprect); 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject); 
begin 
  bild.free; 
  schablone.free; 
end; 
 
procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton; 
  Shift: TShiftState; X, Y: Integer); 
begin 
  unten := true; 
end; 
 
procedure TForm1.Image1MouseUp(Sender: TObject; Button: TMouseButton; 
  Shift: TShiftState; X, Y: Integer); 
begin 
  unten := false; 
end; 
 
procedure doit(im: TImage; x, y: integer); 
begin 
  maskblt(im.picture.bitmap.canvas.handle, x - halb, y - halb, schablone.width, 
    schablone.height, bild.canvas.handle, x - halb, y - halb, schablone.handle, 
    0, 0, MAKEROP4(srcand, srccopy)); 
  im.refresh; 
end; 
 
procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X, 
  Y: Integer); 
begin 
  if unten then doit(Image1, x, y); 
end;