// Durch einige Mausklicks auf ein TImage kann eine Bézierkurve erzeugt
// werden. Dabei wird bei jedem Klick zunächst ein kleines Image als
// Punkt abgebildet. Wenn die richtige Anzahl für eine Kurve vorhanden
// sind, werden die Punkte entfernt und die Kurve gezeichnet. Der erste
// Punkt ist grün, alle weiteren rot. Wird ein Punkt über einen anderen
// gesetzt, wird er blau.

// Erläuterungen
// 4 Checkboxes:
// Speichern: ... Beim Klick auf "Fertig" werden alle Punkte in "D:\Points.txt"
//                gespeichert
// Bezier sofort: Sind genügend Punkte verhanden, wird sofort gezeichnet
// Gittermodus: . Zeichnet ein Gitter
// Ausrichten: .. Die Punkte werden am Gitter ausgerichtet
// 4 Buttons:
// Start: ....... Muss vor dem ersten Punkt angeklickt werden
// Fertig: ...... Muss angeklickt werden, wenn die Kurve gezeichnet wurde
// Zurück: ...... Kann falsch gesetzte Punkte zurücknehmen, aber keine Kurven
// Zeichnen: .... Wenn "Bezier sofort" nicht angeklickt ist, muss damit
//                das Zeichnben der Kurve eingeleitet werden

// Getestet mit CE unter Win10

// Querverweis: Strings entlang einer Bézierkurve ausgeben

type 
  TForm1 = class(TForm) 
    Image1: TImage; 
    Button1: TButton; 
    Button2: TButton; 
    Button3: TButton; 
    Button4: TButton; 
    CheckBox1: TCheckBox; 
    CheckBox2: TCheckBox; 
    CheckBox3: TCheckBox; 
    CheckBox4: TCheckBox; 
    Label1: TLabel; 
    Label2: TLabel; 
    procedure FormCreate(Sender: TObject); 
    procedure Button1Click(Sender: TObject); 
    procedure Button2Click(Sender: TObject); 
    procedure FormDestroy(Sender: TObject); 
    procedure Image1MouseDown(Sender: TObject; Button: TMouseButton; 
      Shift: TShiftState; X, Y: Integer); 
    procedure Button3Click(Sender: TObject); 
    procedure CheckBox2Click(Sender: TObject); 
    procedure Button4Click(Sender: TObject); 
    procedure Image1MouseMove(Sender: TObject; Shift: TShiftState; 
      X, Y: Integer); 
    procedure Image1MouseLeave(Sender: TObject); 
  private 
    { Private-Deklarationen } 
    procedure PunktMouseMove(Sender: TObject; Shift: TShiftState; 
      X, Y: Integer); 
    procedure PunktMouseDown(Sender: TObject; Button: TMouseButton; 
      Shift: TShiftState; X, Y: Integer); 
  public 
    { Public-Deklarationen } 
    procedure auswahl(const X, Y: Integer; out zx, zy: Integer); 
    procedure ausrichten(var X, Y: Integer); 
    procedure anzeige(X, Y: Integer); 
    procedure grundstellung; 
    procedure makeImg; 
    procedure anfang; 
    procedure kurve; 
    procedure leer; 
    procedure area; 
    procedure B4e; 
  end; 
 
var 
  Form1: TForm1; 
 
implementation 
 
{$R *.dfm} 
 
var 
  zahl: Integer = 1; 
  // --- Beispiel-Werte --- 
  gr: Integer = 9; 
  grund: TColor = $EEFFFF; 
  gitter: TColor = $C0D0D0; 
  gitterD: TColor = $98A8A8; 
  erster: TColor = $48DD48; 
  farbe: TColor = clRed; 
  doppelt: TColor = clBlue; 
  step: Integer = 10; 
  pfad: string = 'D:\'; 
  // ----------------------- 
 
  pt, pg: array of TPoint; 
  img: array of TImage; 
  gestartet: boolean = false; 
  stp2, lt, lg, gr2: Integer; 
 
procedure TForm1.area; 
var 
  X, d: Integer; 
begin 
  with Image1, Canvas do 
  begin 
    Brush.Color := grund; 
    fillrect(Image1.Canvas.cliprect); 
    if CheckBox2.Checked then 
    begin 
      d := 0; 
      for X := 1 to width div step do 
      begin 
        inc(d); 
        if d mod 5 = 0 then // d, falls step durch 5 teilbar 
          pen.Color := gitterD 
        else 
          pen.Color := gitter; 
        moveto(0, X * step); 
        lineto(width, X * step); 
      end; 
      d := 0; 
      for X := 1 to height div step do 
      begin 
        inc(d); 
        if d mod 5 = 0 then 
          pen.Color := gitterD 
        else 
          pen.Color := gitter; 
        moveto(X * step, 0); 
        lineto(X * step, height); 
      end; 
    end; 
    pen.Color := farbe; 
  end; 
end; 
 
procedure TForm1.grundstellung; 
begin 
  lt := 0; 
  lg := 0; 
  setlength(pt, lt); 
  setlength(pg, lg); 
  area; 
  gestartet := true; 
end; 
 
procedure TForm1.anfang; 
begin 
  gestartet := false; 
  Button1.Enabled := true; 
  Button2.Enabled := false; 
  Button3.Enabled := false; 
  Button4.Enabled := false; 
  CheckBox1.Enabled := true; 
  CheckBox2.Enabled := true; 
  CheckBox4.Enabled := true; 
end; 
 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
  grundstellung; 
  Button1.Enabled := false; 
  Button2.Enabled := true; 
  CheckBox1.Enabled := false; 
  CheckBox2.Enabled := false; 
  CheckBox4.Enabled := false; 
end; 
 
procedure TForm1.Button2Click(Sender: TObject); 
const 
  bez = 'pkt'; 
var 
  i, dffx, dffy: Integer; 
  sl: TStringlist; 
begin 
  anfang; 
  setlength(pg, lg - length(img)); 
  for i := Low(img) to High(img) do 
    img[i].free; 
  setlength(img, 0); 
  CheckBox1.Enabled := true; 
  CheckBox2.Enabled := true; 
  CheckBox4.Enabled := true; 
  if CheckBox3.Checked then 
  begin 
    dffx := maxint; 
    dffy := dffx; 
    for i := Low(pg) to High(pg) do 
    begin 
      if pg[i].X < dffx then 
        dffx := pg[i].X; 
      if pg[i].Y < dffy then 
        dffy := pg[i].Y; 
    end; 
    sl := TStringlist.Create; 
    if length(pg) = 0 then 
      sl.Add('Es waren keine Punkte vorhanden') 
    else 
    begin 
      sl.Add('var'); 
      sl.Add(#32#32 + bez + ': array[0..' + inttostr(high(pg)) + 
        '] of TPoint;'); 
      sl.Add(''); 
      sl.Add('procedure Points;'); 
      sl.Add('var'); 
      sl.Add('  dffx : Integer = 0; // zum waagerechten Positionieren'); 
      sl.Add('  dffy : Integer = 0; // zum senkrechten Positionieren'); 
      sl.Add('begin'); 
      for i := Low(pg) to High(pg) do 
      begin 
        sl.Add(#32#32 + bez + '[' + inttostr(i) + '] := Point(' + 
          inttostr(pg[i].X - dffx) + ' + dffx,' + inttostr(pg[i].Y - dffy) + 
          ' + dffy);'); 
      end; 
      sl.Add('end;'); 
    end; 
    if copy(pfad, length(pfad), 1) <> '\' then 
      pfad := pfad + '\'; 
    if not DirectoryExists(pfad) then 
    begin 
      CheckBox3.Checked := false; 
      showmessage('Fehler bei der Pfad-Angabe'); 
    end 
    else 
      sl.SaveToFile(pfad + 'Points.txt'); 
    sl.free; 
  end; 
end; 
 
procedure TForm1.Button3Click(Sender: TObject); 
begin 
  dec(lt); 
  dec(lg); 
  img[high(img)].free; 
  setlength(pt, lt); 
  setlength(pg, lg); 
  setlength(img, high(img)); 
  if (lt = 0) or (lt = 1) and (lg > 1) then 
    TButton(Sender).Enabled := false; 
  B4e; 
end; 
 
procedure TForm1.Button4Click(Sender: TObject); 
begin 
  Button4.Enabled := false; 
  Button4.Font.Style := []; 
  kurve; 
end; 
 
procedure TForm1.CheckBox2Click(Sender: TObject); 
begin 
  if visible then 
    area; 
end; 
 
procedure TForm1.makeImg; 
begin 
  setlength(img, succ(length(img))); 
  img[high(img)] := TImage.Create(self); 
  with img[high(img)] do 
  begin 
    Onmousemove := PunktMouseMove; 
    Onmousedown := PunktMouseDown; 
    autosize := true; 
    visible := false; 
    parent := self; 
    autosize := true; 
    with picture.Bitmap, Canvas do 
    begin 
      Brush.Color := grund; 
      width := gr; 
      height := gr; 
      pen.Color := gitter; 
      if lt = 1 then 
        Brush.Color := erster 
      else 
        Brush.Color := farbe; 
      ellipse(0, 0, gr, gr); 
    end; 
    transparent := true; 
  end; 
end; 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  // --- Beispiel-Einstellungen --- 
  Caption := 'Bezier-Demo'; 
  Button1.Caption := 'Start'; 
  Button2.Caption := 'Fertig'; 
  Button3.Caption := 'Zurück'; 
  Button4.Caption := 'Zeichnen'; 
  Button2.Enabled := false; 
  Button3.Enabled := false; 
  Button4.Enabled := false; 
  Image1.width := step * 80; 
  Image1.height := step * 80; 
  Image1.Left := 10; 
  Image1.Top := 10; 
  Image1.transparent := false; 
  clientwidth := Image1.width + CheckBox1.width + 20; 
  clientheight := Image1.height + 10; 
  Button1.Top := Image1.Top; 
  Button1.Left := Image1.BoundsRect.Right + 10; 
  Button2.Top := Button1.BoundsRect.Bottom; 
  Button3.Top := Button2.BoundsRect.Bottom; 
  Button4.Top := Button3.BoundsRect.Bottom; 
  Button2.Left := Button1.Left; 
  Button3.Left := Button1.Left; 
  Button4.Left := Button1.Left; 
  CheckBox3.Top := Button4.BoundsRect.Bottom; 
  CheckBox1.Top := CheckBox3.BoundsRect.Bottom; 
  CheckBox2.Top := CheckBox1.BoundsRect.Bottom; 
  CheckBox4.Top := CheckBox2.BoundsRect.Bottom; 
  CheckBox1.Left := Button1.Left; 
  CheckBox1.Checked := true; 
  CheckBox2.Left := Button1.Left; 
  CheckBox2.Checked := true; 
  CheckBox3.Left := Button1.Left; 
  CheckBox3.Checked := false; 
  CheckBox4.Left := Button1.Left; 
  CheckBox4.Checked := true; 
  CheckBox1.Caption := 'Bezier sofort'; 
  CheckBox2.Caption := 'Gittermodus'; 
  CheckBox3.Caption := 'Speichern'; 
  CheckBox4.Caption := 'Ausrichten'; 
  Label1.Left := Button1.Left; 
  Label2.Left := Button1.Left; 
  Label1.Top := CheckBox4.BoundsRect.Bottom + 5; 
  Label2.Top := Label1.BoundsRect.Bottom + 2; 
  Position := poScreenCenter; 
  BorderStyle := bsSingle; 
  BorderIcons := [biSystemMenu, biMinimize]; 
  // ----------------------------- 
 
  leer; 
  stp2 := round(step / 2); 
  gr2 := round(gr / 2); 
  area; 
  Doublebuffered := true; 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject); 
var 
  i: Integer; 
begin 
  pt := nil; 
  pg := nil; 
  for i := Low(img) to High(img) do 
    img[i].free; 
  img := nil; 
end; 
 
procedure TForm1.kurve; 
var 
  i: Integer; 
  p: TPoint; 
begin 
  p := pg[high(pg)]; 
  Button3.Enabled := false; 
  Image1.Canvas.PolyBezier(pt); 
  lt := 1; 
  for i := Low(img) to High(img) do 
    img[i].free; 
  setlength(pt, lt); 
  setlength(img, 0); 
  pt[0] := p; 
end; 
 
procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton; 
  Shift: TShiftState; X, Y: Integer); 
var 
  p: TPoint; 
begin 
  if gestartet then 
  begin 
    ausrichten(X, Y); 
    inc(lt); 
    inc(lg); 
    makeImg; 
    with img[high(img)] do 
    begin 
      Left := TImage(Sender).Left + X - gr2; 
      Top := TImage(Sender).Top + Y - gr2; 
      visible := true; 
    end; 
    setlength(pg, lg); 
    p := point(X, Y); 
    pg[pred(lg)] := p; 
    setlength(pt, lt); 
    pt[pred(lt)] := p; 
    B4e; 
    if (lt = 4) and CheckBox1.Checked then 
      kurve 
    else 
      Button3.Enabled := true; 
  end 
  else 
    showmessage('Sie müssen zuerst auf "Start" klicken'); 
end; 
 
procedure TForm1.Image1MouseLeave(Sender: TObject); 
begin 
  leer; 
end; 
 
procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; 
  X, Y: Integer); 
begin 
  anzeige(X, Y); 
end; 
 
procedure TForm1.anzeige(X, Y: Integer); 
begin 
  if gestartet then 
  begin 
    ausrichten(X, Y); 
    Label1.Caption := 'X = ' + inttostr(X); 
    Label2.Caption := 'Y = ' + inttostr(Y); 
  end 
end; 
 
procedure TForm1.B4e; 
begin 
  Button4.Enabled := (high(pg) mod 3 = 0) and (lg > 1) and 
    not CheckBox1.Checked; 
  if Button4.Enabled then 
    Button4.Font.Style := [fsbold] 
  else 
    Button4.Font.Style := []; 
end; 
 
procedure TForm1.leer; 
begin 
  Label1.Caption := ''; 
  Label2.Caption := ''; 
end; 
 
procedure TForm1.ausrichten(var X, Y: Integer); 
begin 
  if CheckBox4.Checked then 
  begin 
    X := ((X + stp2) div step) * step; 
    Y := ((Y + stp2) div step) * step; 
  end; 
end; 
 
procedure TForm1.auswahl(const X, Y: Integer; out zx, zy: Integer); 
begin 
  if CheckBox4.Checked then 
  begin 
    zx := gr2; 
    zy := gr2; 
  end 
  else 
  begin 
    zx := X; 
    zy := Y; 
  end; 
end; 
 
procedure TForm1.PunktMouseMove(Sender: TObject; Shift: TShiftState; 
  X, Y: Integer); 
var 
  zx, zy: Integer; 
begin 
  auswahl(X, Y, zx, zy); 
  anzeige(TImage(Sender).Left + zx - Image1.Left, TImage(Sender).Top + zy - 
    Image1.Top); 
end; 
 
procedure TForm1.PunktMouseDown(Sender: TObject; Button: TMouseButton; 
  Shift: TShiftState; X, Y: Integer); 
var 
  zx, zy: Integer; 
begin 
  auswahl(X, Y, zx, zy); 
  Image1MouseDown(Image1, Button, Shift, TImage(Sender).Left + zx - Image1.Left, 
    TImage(Sender).Top + zy - Image1.Top); 
  if length(img) > 0 then 
    with img[high(img)].Canvas do 
    begin 
      Brush.Color := doppelt; 
      FloodFill(zx, zy, farbe, fsSurface); 
    end; 
end;