DBR Delphi-Ecke

// Der nachfolgende Code erzeugt das Bild eines horizontal drehenden
// Würfels. Um den Code so einfach wie möglich zu halten, sind an die
// Variable "Step" Bedingungen geknüpft: Der Wert muss zwischen 0.5
// und 2.5 liegen und die Konstante "Basis" (15) muss ohne Rest durch
// Step teilbar sein.

// Getestet mit D2010 unter Win7

// Variante 1
// Würfel mit verschiedenfarbigen Flächen. Setzt man die Variable
// "Draht" auf TRUE, wird das Ganze als Drahtmodell gezeigt.

DEMO download

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
// Mit kleinen Änderungen ergibt sich ein Würfel mit Bildern.
// Alle Bilder müssen quadratisch sein und die gleichen Abmaße
// haben. Dieser Würfel kann links oder rechts herum laufen.

DEMO2 download

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.