// Der nachfolgende
Code erzeugt das Bild eines horizontal drehenden // Getestet mit D2010 unter Win7 // Variante 1
unit Unit1; interface uses Windows, Classes, Graphics, Forms, SysUtils, Controls, StdCtrls, ExtCtrls; type TForm1 = class(TForm) Button1: TButton; Button2: TButton; Timer1: TTimer; procedure Button1Click(Sender: TObject); procedure Timer1Timer(Sender: TObject); procedure FormCreate(Sender: TObject); procedure Button2Click(Sender: TObject); procedure FormDestroy(Sender: TObject); private { Private-Deklarationen } public procedure config; procedure Zeichnen; end; var Form1: TForm1; implementation {$R *.DFM} const Basis = 15; var Stop: Boolean = True; Draht: Boolean = False; // undurchsichtig Mittex, Mittey, Breite, Hoehe, Groesse, Fase: Integer; Step, Sng, P2, PG, Smm: Single; Img: TImage; Grund: TColor; Rahmen: TColor = clBlack; Farbe1: TColor = clFuchsia; Farbe2: TColor = clYellow; Farbe3: TColor = clLime; Farbe4: TColor = clAqua; Farbe5: TColor = $99FF; procedure TForm1.FormCreate(Sender: TObject); const Rand = 20; begin DoubleBuffered := True; Button1.Caption := 'Start'; Button2.Caption := 'Ansicht'; Button2.Enabled := False; Img := TImage.Create(self); Img.Parent := self; Img.AutoSize := True; config; ClientWidth := Breite + Rand * 2; Img.Top := Rand; Button1.Top := Img.BoundsRect.Bottom + Rand; Button2.Top := Button1.BoundsRect.Bottom + Rand; Img.Left := (ClientWidth - Img.Width) div 2; Button1.Left := (ClientWidth - Button1.Width) div 2; Button2.Left := (ClientWidth - Button2.Width) div 2; ClientHeight := Button2.BoundsRect.Bottom + Rand; Img.Transparent := True; Zeichnen; end; procedure TForm1.FormDestroy(Sender: TObject); begin Img.Free; end; procedure TForm1.config; function FPrf: Boolean; begin Result := (Grund = Farbe1) or (Grund = Farbe2) or (Grund = Farbe3) or (Grund = Farbe4) or (Grund = Farbe5) or (Grund = Rahmen); end; function SPrf: Boolean; var F: Single; begin F := frac(Basis / Step); Result := (F <> 0.0) or (Step > 2.5) or (Step < 0.5); end; begin Grund := ColorToRGB(Color); if FPrf then begin raise Exception.Create( 'Übereinstimmung von Farben mit dem Untergrund ist nicht erlaubt!'); exit; end; Groesse := 100; // z.B. Breite := round(Groesse * 1.4); Hoehe := Breite div 3; Step := 0.75; if SPrf then begin raise Exception.Create(Format('%.2f', [Step]) + ' für "Step" ist nicht erlaubt!'); exit; end; P2 := pi / 2; PG := pi / (Basis * 2); Mittex := Breite div 2; Mittey := Hoehe div 2; Smm := 0; Fase := 0; with Img.Picture.Bitmap, Canvas do begin Brush.Color := Grund; Pen.Color := Rahmen; Width := Breite + 1; Height := Hoehe + Groesse; end; end; procedure TForm1.Zeichnen; var Pt: array [0 .. 3] of TPoint; function px(W, B: Single): Integer; begin Result := trunc(cos(PG * W - P2) * (B / 2) + Mittex); end; function py(W, H: Single): Integer; begin Result := trunc(sin(PG * W - P2) * (H / 2) + Mittey); end; function Stelle(grd: Single): TPoint; begin Result.X := px(grd, Breite); Result.Y := py(grd, Hoehe); end; procedure Senkrecht(W: Integer; i: Single); begin Pt[W] := Stelle(i); if ((i < 7.5) or (i > 52.5)) and not Draht then exit; // Linie nicht sichtbar Img.Canvas.moveto(Pt[W].X, Pt[W].Y); Img.Canvas.lineto(Pt[W].X, Pt[W].Y + Groesse); end; procedure Komplettieren; var G, H: Integer; begin G := Groesse - 1; H := Hoehe + 1; Img.Canvas.moveto(Pt[0].X, Pt[0].Y + G); if (Smm > 7.5) or Draht then // Linie sichtbar Img.Canvas.lineto(Pt[1].X, Pt[1].Y + G) else Img.Canvas.moveto(Pt[1].X, Pt[1].Y + G); Img.Canvas.lineto(Pt[2].X, Pt[2].Y + G); if (Smm < 7.5) or Draht then // Linie sichtbar Img.Canvas.lineto(Pt[3].X, Pt[3].Y + G) else Img.Canvas.moveto(Pt[3].X, Pt[3].Y + G); if Draht then // Linie sichtbar Img.Canvas.lineto(Pt[0].X, Pt[0].Y + G); Img.Canvas.moveto(Pt[0].X, Pt[0].Y); Img.Canvas.lineto(Pt[1].X, Pt[1].Y); Img.Canvas.lineto(Pt[2].X, Pt[2].Y); Img.Canvas.lineto(Pt[3].X, Pt[3].Y); Img.Canvas.lineto(Pt[0].X, Pt[0].Y); if Draht then exit; case Fase of 0: begin if (Smm < 7.5) then begin Img.Canvas.Brush.Color := Farbe3; Img.Canvas.floodfill(Pt[0].X + 1, H, Grund, fsSurface); Img.Canvas.Brush.Color := Farbe2; Img.Canvas.floodfill(Pt[3].X + 1, H, Grund, fsSurface); end else begin Img.Canvas.Brush.Color := Farbe3; Img.Canvas.floodfill(Pt[3].X + 1, H, Grund, fsSurface); end; if Smm >= 8 then begin Img.Canvas.Brush.Color := Farbe4; Img.Canvas.floodfill(Pt[1].X + 1, H, Grund, fsSurface); end; end; 1: begin if (Smm < 7.5) then begin Img.Canvas.Brush.Color := Farbe3; Img.Canvas.floodfill(Pt[3].X + 1, H, Grund, fsSurface); end; Img.Canvas.Brush.Color := Farbe4; Img.Canvas.floodfill(Pt[2].X + 1, H, Grund, fsSurface); if (Smm >= 8) then begin Img.Canvas.Brush.Color := Farbe5; Img.Canvas.floodfill(Pt[1].X + 1, H, Grund, fsSurface); end; end; 2: begin Img.Canvas.Brush.Color := Farbe5; Img.Canvas.floodfill(Pt[2].X + 1, H, Grund, fsSurface); if (Smm > 7.5) then begin Img.Canvas.Brush.Color := Farbe2; Img.Canvas.floodfill(Pt[1].X + 1, H, Grund, fsSurface); end else if (Smm < 7.5) then begin Img.Canvas.Brush.Color := Farbe4; Img.Canvas.floodfill(Pt[3].X + 1, H, Grund, fsSurface); Img.Canvas.Brush.Color := Farbe5; Img.Canvas.floodfill(Pt[0].X + 1, H, Grund, fsSurface); end; end; 3: begin if (Smm > 7.5) then begin Img.Canvas.Brush.Color := Farbe3; Img.Canvas.floodfill(Pt[1].X + 1, H, Grund, fsSurface); Img.Canvas.Brush.Color := Farbe2; Img.Canvas.floodfill(Pt[3].X + 1, H, Grund, fsSurface); end else begin Img.Canvas.Brush.Color := Farbe2; Img.Canvas.floodfill(Pt[2].X + 1, H, Grund, fsSurface); Img.Canvas.Brush.Color := Farbe5; Img.Canvas.floodfill(Pt[3].X + 1, H, Grund, fsSurface); end; end; end; Img.Canvas.Brush.Color := Farbe1; Img.Canvas.floodfill(Mittex, Mittey, Grund, fsSurface); end; begin Sng := Smm; Senkrecht(0, Sng); Sng := Basis + Smm; Senkrecht(1, Sng); Sng := Basis * 2 + Smm; Senkrecht(2, Sng); Sng := Basis * 3 + Smm; Senkrecht(3, Sng); Komplettieren; end; procedure TForm1.Timer1Timer(Sender: TObject); begin Img.Canvas.Brush.Color := Grund; Img.Canvas.FillRect(Img.Canvas.ClipRect); Smm := Smm + Step; if Smm = Basis then begin Smm := 0; inc(Fase); if Fase = 4 then Fase := 0; end; Zeichnen; if Stop then Timer1.Interval := 0; end; // Beispielaufruf procedure TForm1.Button1Click(Sender: TObject); begin if Stop then begin Stop := False; Timer1.Interval := 20; Button2.Enabled := True; Button1.Caption := 'Stop'; end else begin Stop := True; Button2.Enabled := False; Button1.Caption := 'Start'; end; end; procedure TForm1.Button2Click(Sender: TObject); begin Draht := not Draht; end; end. //--------------------------------------------------- // Variante 2
unit Unit2; interface uses Windows, Classes, Graphics, Forms, SysUtils, Controls, StdCtrls, ExtCtrls; type TForm2 = class(TForm) Button1: TButton; Button2: TButton; Button3: TButton; Timer1: TTimer; procedure Button1Click(Sender: TObject); procedure Timer1Timer(Sender: TObject); procedure FormCreate(Sender: TObject); procedure Button2Click(Sender: TObject); procedure FormDestroy(Sender: TObject); procedure Button3Click(Sender: TObject); private { Private-Deklarationen } public procedure config; procedure Zeichnen; end; var Form2: TForm2; implementation {$R *.DFM} const Basis = 15; var b0, b1, b2, b3, b4: TBitmap; Stop: Boolean = True; Mittex, Mittey, Breite, Hoehe, Fase: Integer; Step, P2, PG, Smm: Single; Richtung: Boolean = True; Grund: TColor; Img: TImage; procedure TForm2.FormCreate(Sender: TObject); const Rand = 20; begin DoubleBuffered := True; Button1.Caption := 'Start'; Button2.Caption := 'Schritt'; Button3.Caption := 'nach Links'; Img := TImage.Create(self); Img.Parent := self; Img.AutoSize := True; b0 := TBitmap.Create; // b0.LoadFromFile('bernd.bmp'); b0.Handle := LoadBitmap(Hinstance, 'bernd'); b1 := TBitmap.Create; // b1.LoadFromFile('kh.bmp'); b1.Handle := LoadBitmap(Hinstance, 'kh'); b2 := TBitmap.Create; // b2.LoadFromFile('frau.bmp'); b2.Handle := LoadBitmap(Hinstance, 'frau'); b3 := TBitmap.Create; // b3.LoadFromFile('linda.bmp'); b3.Handle := LoadBitmap(Hinstance, 'linda'); b4 := TBitmap.Create; // b4.LoadFromFile('peter.bmp'); b4.Handle := LoadBitmap(Hinstance, 'peter'); config; ClientWidth := Breite + Rand * 2; Img.Top := Rand; Button1.Top := Img.BoundsRect.Bottom + Rand; Button2.Top := Button1.BoundsRect.Bottom + Rand; Button3.Top := Button2.BoundsRect.Bottom + Rand; Img.Left := (ClientWidth - Img.Width) div 2; Button1.Left := (ClientWidth - Button1.Width) div 2; Button2.Left := Button1.Left; Button3.Left := Button1.Left; ClientHeight := Button3.BoundsRect.Bottom + Rand + 1; Img.Transparent := True; Zeichnen; end; procedure TForm2.FormDestroy(Sender: TObject); begin b0.Free; b1.Free; b2.Free; b3.Free; b4.Free; Img.Free; end; procedure TForm2.config; function SPrf: Boolean; var F: Single; begin F := frac(Basis / Step); Result := (F <> 0.0) or (Step > 2.5) or (Step < 0.5); end; function BPrf: Boolean; begin Result := (b0.Width <> b0.Height) or (b0.Width <> b1.Width) or (b0.Width <> b1.Height) or (b0.Width <> b2.Width) or (b0.Width <> b2.Height) or (b0.Width <> b3.Width) or (b0.Width <> b3.Height) or (b0.Width <> b4.Width) or (b0.Width <> b4.Height); end; begin Grund := ColorToRGB(Color); if BPrf then begin raise Exception.Create( 'Alle Bilder müssen in Breite und Höhe das selbe Maß haben!'); exit; end; Step := 0.5; if SPrf then begin raise Exception.Create(Format('%.2f', [Step]) + ' für "Step" ist nicht erlaubt!'); exit; end; Breite := round(b0.Height * 1.4); Hoehe := Breite div 3; P2 := Pi / 2; PG := Pi / (Basis * 2); Mittex := Breite div 2; Mittey := Hoehe div 2; with Img.Picture.Bitmap, Canvas do begin Brush.Color := Grund; Width := Breite + 1; Height := Hoehe + b0.Height + 1; end; Fase := 0; Smm := Step; Img.Canvas.Brush.Color := Grund; end; procedure TForm2.Zeichnen; var V: Integer; Pt: array [0 .. 3] of TPoint; pt2: array [0 .. 2] of TPoint; procedure plgrmm(ba: TBitmap); begin SetStretchBltMode(Img.Canvas.Handle, STRETCH_HALFTONE); PlgBlt(Img.Canvas.Handle, pt2, ba.Canvas.Handle, 0, 0, ba.Width, ba.Height, 0, 0, 0); end; function px(W, B: Single): Integer; begin Result := round(cos(PG * W - P2) * (B / 2) + Mittex); end; function py(W, H: Single): Integer; begin Result := round(sin(PG * W - P2) * (H / 2) + Mittey); end; procedure Rechnen(W: Integer; I: Single); function Stelle(grd: Single): TPoint; begin Result.X := px(grd, succ(Breite)); Result.Y := py(grd, succ(Hoehe)); end; begin Pt[W] := Stelle(I); end; procedure Komplettieren; begin case Fase of 0: begin if (Smm < 7.5) then begin pt2[0] := Pt[2]; pt2[1] := Pt[1]; pt2[2] := point(Pt[2].X, Pt[2].Y + b0.Height); plgrmm(b1); pt2[0] := Pt[3]; pt2[1] := Pt[2]; pt2[2] := point(Pt[3].X, Pt[3].Y + b0.Height); plgrmm(b2); end else begin pt2[0] := Pt[2]; pt2[1] := Pt[1]; pt2[2] := point(Pt[2].X, Pt[2].Y + b0.Height); plgrmm(b1); end; if Smm > 7.5 then begin pt2[0] := Pt[1]; pt2[1] := Pt[0]; pt2[2] := point(Pt[1].X, Pt[1].Y + b0.Height); plgrmm(b3); end; pt2[0] := Pt[3]; pt2[1] := Pt[0]; pt2[2] := Pt[2]; plgrmm(b0); end; 1: begin if (Smm < 7.5) then begin pt2[0] := Pt[3]; pt2[1] := Pt[2]; pt2[2] := point(Pt[3].X, Pt[3].Y + b0.Height); plgrmm(b1); end; pt2[0] := Pt[2]; pt2[1] := Pt[1]; pt2[2] := point(Pt[2].X, Pt[2].Y + b0.Height); plgrmm(b3); if (Smm > 7.5) then begin pt2[0] := Pt[1]; pt2[1] := Pt[0]; pt2[2] := point(Pt[1].X, Pt[1].Y + b0.Height); plgrmm(b4); end; pt2[0] := Pt[0]; pt2[1] := Pt[1]; pt2[2] := Pt[3]; plgrmm(b0); end; 2: begin pt2[0] := Pt[2]; pt2[1] := Pt[1]; pt2[2] := point(Pt[2].X, Pt[2].Y + b0.Height); plgrmm(b4); if (Smm > 7.5) then begin pt2[0] := Pt[1]; pt2[1] := Pt[0]; pt2[2] := point(Pt[1].X, Pt[1].Y + b0.Height); plgrmm(b2); end else if (Smm < 7.5) then begin pt2[0] := Pt[3]; pt2[1] := Pt[2]; pt2[2] := point(Pt[3].X, Pt[3].Y + b0.Height); plgrmm(b3); end; pt2[0] := Pt[1]; pt2[1] := Pt[2]; pt2[2] := Pt[0]; plgrmm(b0); end; 3: begin if (Smm > 7.5) then begin pt2[0] := Pt[1]; pt2[1] := Pt[0]; pt2[2] := point(Pt[1].X, Pt[1].Y + b0.Height); plgrmm(b1); pt2[0] := Pt[2]; pt2[1] := Pt[1]; pt2[2] := point(Pt[2].X, Pt[2].Y + b0.Height); plgrmm(b2); end else begin pt2[0] := Pt[2]; pt2[1] := Pt[1]; pt2[2] := point(Pt[2].X, Pt[2].Y + b0.Height); plgrmm(b2); pt2[0] := Pt[3]; pt2[1] := Pt[2]; pt2[2] := point(Pt[3].X, Pt[3].Y + b0.Height); plgrmm(b4); end; pt2[0] := Pt[2]; pt2[1] := Pt[3]; pt2[2] := Pt[1]; plgrmm(b0); end; end; end; begin for V := 0 to 3 do Rechnen(V, Basis * V + Smm); Komplettieren; end; procedure TForm2.Timer1Timer(Sender: TObject); begin Img.Canvas.FillRect(Img.Canvas.ClipRect); if Richtung then begin if Smm < Basis then Smm := Smm + Step; if Smm = Basis then begin Smm := 0; inc(Fase); if Fase = 4 then Fase := 0; end; end else begin if Smm > 0 then Smm := Smm - Step; if Smm = 0 then begin Smm := Basis; dec(Fase); if Fase < 0 then Fase := 3; end; end; Zeichnen; if Stop then Timer1.Interval := 0; end; // Beispielaufruf procedure TForm2.Button1Click(Sender: TObject); begin if Stop then begin Stop := False; Timer1.Interval := 50; Button1.Caption := 'Stop'; Button2.Enabled := False; end else begin Stop := True; Button1.Caption := 'Start'; Button2.Enabled := True; end; end; procedure TForm2.Button2Click(Sender: TObject); begin Timer1Timer(Sender); end; procedure TForm2.Button3Click(Sender: TObject); begin Richtung := not Richtung; if Richtung then Button3.Caption := 'nach Links' else Button3.Caption := 'nach Rechts'; end; end.
|
Zugriffe seit 6.9.2001 auf Delphi-Ecke