// Durch einige
Mausklicks auf ein TImage kann eine Bézierkurve erzeugt // 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;
|
Zugriffe seit 6.9.2001 auf Delphi-Ecke