// Ein Bild wird in die Form einer Ellipse gezwängt. Die Berechnung
// ist an den Algorithmus von Jack Bresenham angelehnt. Zusätzlich
// kann das Bild gestreckt werden (siehe Button 6).
// Mittels Button4 kann man im Vorfeld die benötigte Größe ermitteln

// Getestet mit RS 10.4 unter Win11

Ausgangsbild	Button 1
Button 2	Button 3
Button 5	Button 6

const 
  mindest = 25; 
 
type 
  rcd = Record 
    cx, cy: Integer; 
  end; 
 
  prz = 10 .. 200; // ein Zehntel bis doppelt so hoch wie breit 
  brt = mindest .. 1000; 
 
function DrawEllipse(source: TGraphic; cnv: TCanvas; x0, y0: Integer; 
  breit: brt; hoch: prz; rand: Integer = 0; farbe: TColor = 0; 
  streckung: Word = 0): rcd; 
var 
  rx2, ry2, rx4, ry4, F, Fx, Fy, ry, x, y, yy, dff, rnd: Integer; 
  bm: TBitmap; 
  xx: single; 
 
  procedure spalte(x, y, z: Integer); 
  begin 
    cnv.copyrect(rect(x - 1, y, x, z + streckung), bm.Canvas, 
      rect(x - bm.width - 1 + dff, 0, x - bm.width + dff, bm.height)); 
  end; 
 
  procedure doit; 
  begin 
    SetStretchBltMode(cnv.handle, STRETCH_HALFTONE); 
    spalte(x0 - x, y0 - y, y0 + y); 
    spalte(x0 + x, y0 - y, y0 + y); 
  end; 
 
  procedure DrawArc(R: TRect; StartAngle, EndAngle: single); 
  var 
    MX, MY, RX, YR, SA, EA, P2: single; 
    SX, SY, EX, EY: Integer; 
  begin 
    P2 := PI / 180; 
    RX := (R.Right - R.Left) / 2; 
    YR := (R.Bottom - R.Top) / 2; 
    MX := R.Left + RX; 
    MY := R.Top + YR; 
    SA := StartAngle * P2; 
    EA := EndAngle * P2; 
    SX := Round(MX + sin(SA) * RX); 
    SY := Round(MY - cos(SA) * YR); 
    EX := Round(MX + sin(EA) * RX); 
    EY := Round(MY - cos(EA) * YR); 
    Arc(cnv.handle, R.Left, R.Top, R.Right, R.Bottom, EX, EY, SX, SY); 
  end;
 
begin 
  bm := TBitmap.create(breit, breit + streckung); 
  Result.cy := -1; 
  try 
    rand := rand + ord(rand = 1); // muss zwecks Randabdeckung ungleich 1 sein 
    if rand > breit div 4 then 
      rand := breit div 4; 
    ry := Round(breit * (hoch / 200)); 
    Result.cy := ry * 2 + rand * 2 + streckung; 
    Result.cx := breit + rand * 2; 
    if source = nil then 
      exit; 
    dff := breit - x0 - rand; 
    with bm.Canvas do 
    begin 
      SetStretchBltMode(handle, STRETCH_HALFTONE); 
      stretchdraw(cliprect, source); 
    end; 
    breit := Round(breit * 0.5); 
    inc(x0, breit + rand); 
    inc(y0, ry + rand); 
    rx2 := breit * breit; 
    ry2 := ry * ry; 
    rx4 := rx2 + rx2; 
    ry4 := ry2 + ry2; 
    F := Round(ry2 - rx2 * ry + 0.25 * breit); 
    Fx := 0; 
    Fy := rx4 * ry; 
    x := 0; 
    y := ry; 
    doit; 
    while Fx < Fy do 
    begin 
      if F >= 0 then 
      begin 
        dec(y); 
        Fy := Fy - rx4; 
        F := F - Fy; 
      end; 
      inc(x); 
      Fx := Fx + ry4; 
      F := F + Fx + ry2; 
      doit; 
    end; 
    xx := x + 0.5; 
    yy := pred(y); 
    F := Round(ry2 * xx * xx + rx2 * yy * yy - rx2 * ry2); 
    while y > 0 do 
    begin 
      if F <= 0 then 
      begin 
        inc(x); 
        Fx := Fx + ry4; 
        F := F + Fx; 
      end; 
      dec(y); 
      Fy := Fy - rx4; 
      F := F + rx2 - Fy; 
      doit; 
    end; 
    if rand > 0 then 
      with cnv do 
      begin 
        rnd := rand div 2; 
        brush.Style := bsClear; 
        pen.width := rand; 
        pen.Color := farbe; 
        DrawArc(rect(x0 - breit - rnd, y0 - rnd - ry + streckung, 
          x0 + breit + rnd, y0 + ry + rnd + streckung), 90, 270); 
        DrawArc(rect(x0 - breit - rnd, y0 - rnd - ry, x0 + breit + rnd, 
          y0 + ry + rnd), 270, 90); 
        moveto(x0 - breit - rnd, y0); 
        lineto(x0 - breit - rnd, y0 + streckung); 
        moveto(x0 + breit + rnd, y0); 
        lineto(x0 + breit + rnd, y0 + streckung); 
      end; 
  except 
    Result.cx := -1 
  end; 
  bm.Free; 
end; 
 
function dimensions(Breite: brt; Prozent: prz; rand: Integer; 
  streckung: Word): rcd; 
begin 
  Result := DrawEllipse(nil, nil, 0, 0, Breite, Prozent, rand, 0, streckung); 
end; 
 
 
// --- Beispiele --- 
 
procedure TForm1.Button1Click(Sender: TObject); 
var 
  Quelle: TGraphic; 
  Ziel: TCanvas; 
  x, y: Integer; 
  Prozent: prz; 
  Breite: brt; 
begin 
  x := 0; 
  y := 0; 
  Breite := 250; 
  Prozent := 100; // Kreisförmig 
  Ziel := Canvas; // z.B. 
  Quelle := Image1.Picture.Graphic; 
  if DrawEllipse(Quelle, Ziel, x, y, Breite, Prozent).cx < mindest then 
    ShowMessage('Fehler'); 
end; 
 
procedure TForm1.Button2Click(Sender: TObject); 
var 
  Quelle: TGraphic; 
  Ziel: TCanvas; 
  x, y: Integer; 
  Prozent: prz; 
  Breite: brt; 
begin 
  x := 280; 
  y := 10; 
  Breite := 156; 
  Prozent := 200; // doppelt so hoch wie breit 
  Ziel := Canvas; 
  Quelle := Image1.Picture.Graphic; 
  DrawEllipse(Quelle, Ziel, x, y, Breite, Prozent); 
end; 
 
procedure TForm1.Button3Click(Sender: TObject); 
var 
  Quelle: TGraphic; 
  Ziel: TCanvas; 
  x, y: Integer; 
  Prozent: prz; 
  Breite: brt; 
begin 
  x := 20; 
  y := 320; 
  Breite := 300; 
  Prozent := 50; // halb so hoch wie breit 
  Ziel := Canvas; 
  Quelle := Image1.Picture.Graphic; 
  DrawEllipse(Quelle, Ziel, x, y, Breite, Prozent); 
end; 
 
// ---------------------------------------------- 
 
// zuerst Abmaße ermitteln 
 
var 
  Mass: rcd; 
  Breite: brt = 265; 
  Prozent: prz = 67; 
  rand: Integer = 6; 
  streckung: Word = 0; 
 
procedure TForm1.Button4Click(Sender: TObject); 
begin 
  Mass := dimensions(Breite, Prozent, rand, streckung); 
  ShowMessage('Breite: ' + InttoStr(Mass.cx) + #13 + 'Höhe: ' + 
    InttoStr(Mass.cy)); 
end; 
 
// dann mit roter Umrandung zeichnen 
 
procedure TForm1.Button5Click(Sender: TObject); 
begin 
  DrawEllipse(Image1.Picture.Graphic, Canvas, 10, 10, Breite, Prozent, 
    rand, clRed); 
end; 
 
// ---------------------------------------------- 
 
// blaue Umrandung und Streckung 
 
procedure TForm1.Button6Click(Sender: TObject); 
const 
  dehnung = 100; 
begin 
  DrawEllipse(Image1.Picture.Graphic, Canvas, 10, 10, 250, 33, 5, 
    clblue, dehnung); 
end;

Zugriffe seit 6.9.2001 auf Delphi-Ecke