DBR Delphi-Ecke

// Getestet mit D4 unter XP

// mit dem folgenden Code wird durch Ziehen mit gedrückt gehaltener linken
// Maustaste ein Markierungsrahmen auf einem Formular (Form1) erzeugt.
// Bei Loslassen der Maustaste verschwindet der Rahmen wieder.
// Weiter unten wird das Erstellen eines bleibenden (bewegten) Rahmens
// auf einem TImage erläutert.

type 
  TForm1 = class(TForm) 
     procedure FormCreate(Sender: TObject); 
     procedure FormMouseDown(Sender: TObject; Button: TMouseButton; 
      Shift: TShiftState; X, Y: Integer); 
    procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X, 
      Y: Integer); 
    procedure FormMouseUp(Sender: TObject; Button: TMouseButton; 
      Shift: TShiftState; X, Y: Integer); 
  private 
    procedure zeichnen(_anfang, _ende: TPoint);
  public 
    { Public-Deklarationen } 
  end;

var 
  isdown: Boolean; 
  anfang, ende: TPoint; 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  with Canvas do begin 
    Brush.Style := bsClear; 
    Pen.Mode := pmNotXor; 
    Pen.Color := clBlack; 
    Pen.Style := psDot; 
    Pen.Width := 1; 
  end; 
end; 
 
procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton; 
  Shift: TShiftState; X, Y: Integer); 
begin 
  if Button = mbLeft then begin 
    isdown := True; 
    anfang := Point(X, Y); 
    ende := Point(X, Y); 
    zeichnen(anfang, ende); 
  end; 
end; 
 
procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: 
  Integer); 
begin 
  if isdown = True then begin 
    zeichnen(anfang, ende); 
    zeichnen(anfang, Point(X, Y)); 
    ende := Point(X, Y); 
  end; 
end; 
 
procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton; 
  Shift: TShiftState; X, Y: Integer); 
begin 
  if isdown = True then begin 
    isdown := False; 
    zeichnen(anfang, Point(X, Y)); 
    ende := Point(X, Y); 
  end; 
end; 
 
procedure TForm1.zeichnen(_anfang, _ende: TPoint); 
begin 
  Canvas.Rectangle(_anfang.X, _anfang.Y, _ende.X, _ende.Y); 
end;

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

// Im Folgenden kann man auf ein TImage einen Markierungsrahmen zeichnen, unter
// der Bedingung, dass eine Bitmap oder ein Jpeg in das Image geladen wurde.
// Entfernt wird der Rahmen durch einfaches Anklicken des Image oder mit der
// Esc-Taste. Über Button1 kann man einstellen, ob nach Loslassen der linken
// Maustaste die kleinen Striche des Rahmens wandern oder still stehen.
// Mit Button2 kann man die Rahmenform umschalten und Button3 stellt den
// Inhalt des Rahmens in eine Bitmap.

type 
  TForm1 = class(TForm) 
    Image1: TImage; 
    Timer1: TTimer; 
    Button1: TButton; 
    Button2: TButton; 
    Button3: TButton; 
    procedure FormCreate(Sender: TObject); 
    procedure FormDestroy(Sender: TObject); 
    procedure Timer1Timer(Sender: TObject); 
    procedure Button1Click(Sender: TObject); 
    procedure Button2Click(Sender: TObject); 
    procedure Button3Click(Sender: TObject); 
    procedure Image1MouseDown(Sender: TObject; Button: TMouseButton; 
      Shift: TShiftState; X, Y: Integer); 
    procedure Image1MouseMove(Sender: TObject; Shift: TShiftState; X, 
      Y: Integer); 
    procedure Image1MouseUp(Sender: TObject; Button: TMouseButton; 
      Shift: TShiftState; X, Y: Integer); 
    procedure FormKeyPress(Sender: TObject; var Key: Char); 
  private 
    procedure weg; 
    procedure zeichnen(x1, y1, x2, y2: integer); 
  public 
    { Public-Deklarationen } 
  end; 
 
var 
  Form1: TForm1; 
 
implementation 
 
{$R *.DFM} 
 
uses JPeg; 
 
type 
  was = (aRectangle, aRoundrect, aEllipse); 
 
var 
  xx, yy, xxx, yyy: integer; 
  unten, da: boolean; 
  gr, bm: TBitmap; 
  art: was = aRectangle; 
  bewegung: boolean = true; 
 
procedure TForm1.weg; 
begin 
  timer1.enabled := false; 
  da := false; 
  unten := false; 
  image1.picture.bitmap.assign(gr); 
end; 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  bm := TBitmap.create; 
  gr := TBitmap.create; 
  gr.assign(Image1.picture.graphic); 
  image1.picture.bitmap.assign(gr); // nötig, falls JPEG 
  unten := false; 
  da := false; 
  with Image1.canvas do begin 
    pen.mode := pmNotXor; 
    pen.width := 1; 
    pen.color := clBlack; 
    pen.style := psDot; 
    brush.style := bsclear; 
  end; 
  keypreview := true; 
  timer1.interval := 150; 
  timer1.enabled := false; 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject); 
begin 
  gr.free; 
  bm.free; 
end; 
 
procedure TForm1.zeichnen(x1, y1, x2, y2: integer); 
begin 
  with Image1.canvas do 
    case art of 
      aRectangle: rectangle(x1, y1, x2, y2); 
      aRoundrect: roundrect(x1, y1, x2, y2, 20, 20); 
      aEllipse: ellipse(x1, y1, x2, y2); 
    end; 
end; 
 
procedure TForm1.Timer1Timer(Sender: TObject); 
begin 
  with Image1.canvas do begin 
    pen.Style := psSolid; 
    zeichnen(xx, yy, xxx, yyy); 
    pen.Style := psDot; 
  end; 
end; 
 
procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X, 
  Y: Integer); 
begin 
  if not unten then exit; 
  with Image1.canvas do begin 
    zeichnen(xx, yy, xxx, yyy); 
    xxx := X; yyy := Y; 
    zeichnen(xx, yy, xxx, yyy); 
  end; 
  da := true; 
end; 
 
procedure TForm1.Image1MouseUp(Sender: TObject; Button: TMouseButton; 
  Shift: TShiftState; X, Y: Integer); 
begin 
  unten := false; 
  if not da then exit; 
  timer1.enabled := bewegung; 
end; 
 
procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton; 
  Shift: TShiftState; X, Y: Integer); 
begin 
  weg; 
  if button = mbleft then begin 
    unten := true; 
    xx := X; yy := Y; 
    xxx := X; yyy := Y; 
  end; 
end; 
 
// mit Escape kann der Rahmen entfernt werden 
 
procedure TForm1.FormKeyPress(Sender: TObject; var Key: Char); 
begin 
  if (key = #27) and da and not unten then weg; 
end; 
 
// Einstellung, ob die Rahmenstriche wandern 
 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
  bewegung := not bewegung; 
  Timer1.enabled := da and bewegung; 
end; 
 
// Rahmenform umschalten 
 
procedure TForm1.Button2Click(Sender: TObject); 
begin 
  weg; 
  case art of 
    aRectangle: art := aRoundrect; 
    aRoundrect: art := aEllipse; 
    aEllipse: art := aRectangle; 
  end; 
end; 
 
// das Innere des Rahmens wird in ein Bitmap gestellt 
 
procedure TForm1.Button3Click(Sender: TObject); 
var farbe: TColor; 
begin 
  if (not da) or unten then exit; 
  farbe := colorToRGB(clBtnFace); 
  bm.width := xxx - xx; 
  bm.height := yyy - yy; 
  bm.canvas.copyrect(rect(0, 0, bm.width, bm.height), 
    image1.canvas, rect(xx, yy, xxx, yyy)); 
  with bm, canvas do begin 
    pen.color := Farbe; 
    pen.width := 1; 
    brush.style := bsClear; 
    case art of 
      aRectangle: rectangle(0, 0, width, height); 
      aRoundrect: roundrect(0, 0, width, height, 20, 20); 
      aEllipse: ellipse(0, 0, width, height); 
    end; 
    brush.color := Farbe; 
    floodfill(0, 0, Farbe, fsBorder); 
    floodfill(width - 1, 0, Farbe, fsBorder); 
    floodfill(width - 1, height - 1, Farbe, fsBorder); 
    floodfill(0, height - 1, Farbe, fsBorder); 
  end; 
  bm.transparentcolor := Farbe; 
  bm.transparent := true;
  // anschließend kann man das Bitmap je nach Bedarf weiterverwenden, 
  // z.B. in doppelter Größe auf die Form zeichnen 
  canvas.stretchdraw(rect(400, 150, 400 + bm.width * 2, 
    150 + bm.height * 2), bm); 
end;