// Mit dem folgenden Code kann man Bilder nach oben und/oder unten biegen.
// Der Wert der Variablen "Kruemmung" (Bogen) bestimmt die Krümmung und deren
// Richtung. Die Variable "beides" (ObenUnten) legt fest, ob einseitig oder
// beidseitig gekrümmt werden soll. Die Variable "Y" (oben) legt dabei immer
// den obersten Punkt des gekrümmten Bildes fest. Wenn man im Vorfeld nur die
// künftig benötigte Fläche ermitten will, kann man das, wie unten unter
// "Button2Click" aufgeführt ist, einfach nur berechnen lassen. Die Variable
// "Wiederholung" legt die Anzahl der Wellenbäuche und -täler fest, und mit
// "Sart" wird der Wellenbeginn festgelegt.


// Getestet mit RS 10.4 unter Win11

 

Ausgangsbild

Bogen = -20 ObenUnten = false Wiederholung = 1 Start = 0	Bogen = 20 ObenUnten = false Wiederholung = 1 Start = 0
Bogen = -20 ObenUnten = true Wiederholung = 1 Start = 0	Bogen = 20 ObenUnten = true Wiederholung = 1 Start = 0
Bogen = 20 Wiederholung = 3 ObenUnten = true Start = 0	Bogen = 20 Wiederholung = 3 ObenUnten = false Start = 0
Bogen = -20 Wiederholung = 2 ObenUnten = false Start = 50	Bogen = 20 Wiederholung = 4 ObenUnten = false Start = 200

// uses Vcl.Imaging.PngImage,  UITypes; 
  
var 
  png: TPngImage; 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  png := TPngImage.Create; 
  png.LoadFromFile('D:\Bilder\Lands.png'); // z.B. 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject); 
begin 
  FreeAndNil(png); 
end; 
 
function Curved(gr: TGraphic; Kruemmung: Shortint; beides: Boolean; 
  Wiederholung: byte = 1; Start: Integer = 0; Ziel: TCanvas = nil; 
  x: Integer = 0; y: Integer = 0; Grund: PColor = nil): Integer; 
var 
  I, Zo, Zu, Dff, H, F, W, T, O: Integer; 
  bmp: TBitmap; 
  C: TColor; 
  function Offs(S: Single): Integer; 
  begin 
    Result := Round(Kruemmung * sin(Wiederholung * pi * (I + Start) / S)); 
  end; 
 
begin 
  bmp := TBitmap.Create; 
  F := ord(not beides) * 2 - 1; 
  W := ord(Wiederholung > 1); 
  T := y + Kruemmung * W; 
  if Ziel <> nil then 
  begin 
    SetStretchBltMode(Ziel.handle, STRETCH_HALFTONE); 
    if Grund <> nil then 
      C := Grund^ 
    else 
      C := Ziel.Brush.Color; 
    // für alle Typen; auch Icons 
    bmp.PixelFormat := pf32Bit; 
    bmp.SetSize(gr.width, gr.height); 
    bmp.Canvas.Brush.Color := C; 
    bmp.Canvas.FillRect(bmp.Canvas.cliprect); 
    bmp.Canvas.Draw(0, 0, gr); 
    // ----------------------- 
  end; 
  H := 0; 
  if (Kruemmung < 0) then 
    Dff := Kruemmung 
  else 
    Dff := 0; 
  for I := 0 to pred(gr.width) do 
  begin 
    if beides and (T < 0) then 
    begin 
      O := Offs(gr.width); 
      Zo := O - Dff * 2; 
      Zu := -O + Dff; 
    end 
    else 
    begin 
      Zo := Offs(gr.width + Start) - Dff * (W + 1); 
      Zu := Zo * F; 
    end; 
    if (Zo > H) and (not beides or (W = 1)) then 
      H := Zo; 
    if Ziel <> nil then 
      Ziel.CopyRect(rect(I + x, Zo + T, succ(I) + x, bmp.height + Zu + T), 
        bmp.Canvas, rect(I, 0, succ(I), bmp.height)) 
  end; 
  Result := gr.height; 
  if beides and (T < 0) then 
    Result := Result + Round(H * pi / 10) 
  else 
  begin 
    if beides or (T > 0) then 
      Result := Result + H * 2 
    else 
    begin 
      if T = 0 then 
        Result := Result + Round(H) 
      else 
        Result := Result + Round(H * 0.667) 
    end; 
  end; 
  bmp.Free; 
end; 
 
 
// --- Beispiele --- 
 
// Darstellung eines transparenten Bildes mit 
// blauer Freifläche 
procedure TForm1.Button1Click(Sender: TObject); 
var 
  Links, Oben, Start: Integer; 
  Bogen: Shortint; 
  Grund: TColor; 
  ObenUnten: Boolean; 
  Wdrhlng: byte; 
begin 
  Grund := clBlue; 
  Links := 100; 
  Oben := 50; 
  Bogen := -20; 
  Wdrhlng := 1; 
  Start := 0; 
  ObenUnten := false; 
  Curved(png, Bogen, ObenUnten, Wdrhlng, Start, Canvas, Links, Oben, @Grund); 
end; 
 
// Beispiel für nur Berechnung 
procedure TForm1.Button2Click(Sender: TObject); 
var 
  Bogen: Shortint; 
  Start, Hoehe: Integer; 
  ObenUnten: Boolean; 
  Wdrhlng: byte; 
begin 
  Wdrhlng := 1; 
  Start := 0; 
  Bogen := -20; 
  ObenUnten := false; 
  Hoehe := Curved(png, Bogen, ObenUnten, Wdrhlng, Start); 
  showmessage('Original =  ' + inttostr(png.width) + ' x ' + 
    inttostr(png.height) + ' Pixel' + #13#10 + 'Benötigte Fläche = ' + 
    inttostr(png.width) + ' x ' + inttostr(Hoehe) + ' Pixel'); 
end; 
 
// Bild scheinbar transparent, 
// weil gleiche Farbe wie Canvas.Brush.Color 
procedure TForm1.Button3Click(Sender: TObject); 
begin 
  Curved(png, 20, true, 1, 0, Canvas, 100, 50); 
end; 
 
// Mehrfach Wellenbauch und -tal mit einer Ausdehnung 
procedure TForm1.Button4Click(Sender: TObject); 
var 
  Bogen: Shortint; 
  ObenUnten: Boolean; 
  Wdrhlng: byte; 
  Grund: TColor; 
  Start: Integer; 
begin 
  Bogen := 20; 
  Wdrhlng := 3; 
  Grund := $FF8080; 
  ObenUnten := false; 
  Start := 200; 
  Curved(png, Bogen, ObenUnten, Wdrhlng, Start, Canvas, 100, 50, @Grund); 
end; 
 
// Mehrfach Wellenbauch und -tal mit Ausdehnung nach oben und unten 
procedure TForm1.Button5Click(Sender: TObject); 
var 
  Bogen: Shortint; 
  ObenUnten: Boolean; 
  Wdrhlng: byte; 
  Start: Integer; 
begin 
  Bogen := 20; 
  Wdrhlng := 3; 
  Start := 0; 
  ObenUnten := true; 
  Curved(png, Bogen, ObenUnten, Wdrhlng, Start, Canvas, 100, 50); 
end;

Zugriffe seit 6.9.2001 auf Delphi-Ecke