// Eine Bild (Beispiel 1) / eine Schrift (Beispiel 2) als
// Bitmap kippt nach hinten. Das kann auch auf einem
// Untergrund mit anderen Bildern geschehen, ohne diese
// zu beeinflussen.


// Getestet mit D2010 unter Win7

Beispiel 1	Beispiel 2

type 
  TForm1 = class(TForm) 
    Button1: TButton; 
    Button2: TButton; 
    Image1: TImage; 
    procedure Button1Click(Sender: TObject); 
    procedure Button2Click(Sender: TObject); 
    procedure FormCreate(Sender: TObject); 
    procedure FormDestroy(Sender: TObject); 
  private 
    { Private-Deklarationen } 
  public 
    procedure kipp(Cnv: TCanvas; X, Y: integer; Bild, Hig: TBitmap; 
      Img: TImage); 
    procedure Kippen(Cnv: TCanvas; X, Y: integer; Bmp: TBitmap); 
  end; 
 
var 
  Form1: TForm1; 
 
implementation 
 
{$R *.DFM} 
 
var 
  Image: TImage; 
 
  function dunkel(A, B: integer): integer; 
  asm 
    sub eax, b 
    cmp eax, 0 
    jge @fertig 
    xor eax, eax 
    @fertig: 
  end; 
 
  procedure TForm1.FormCreate(Sender: TObject); 
  begin 
    DoubleBuffered := True; 
    Image := TImage.Create(Self); 
    Image.AutoSize := True; 
    Image.Parent := Self; 
  end; 
 
  procedure TForm1.FormDestroy(Sender: TObject); 
  begin 
    Image.Free; 
  end; 
 
  procedure Parallelograma(dc: HDC; X, Y, diffX1, diffY1, diffX2, 
    diffY2: integer; Bmp: TBitmap); 
  var 
    I: integer; 
    Punkte: array [0 .. 2] of TPoint; 
  begin 
    I := 0; 
    Punkte[0] := point(X, Y); 
    Punkte[1] := point(X + Bmp.Width + diffX1, Y + diffY1); 
    Punkte[2] := point(X + diffX2, Y + Bmp.Height + diffY2); 
    PlgBlt(dc, Punkte, Bmp.Canvas.handle, 0, 0, Bmp.Width, Bmp.Height, I, 0, 0); 
  end; 
 
  procedure TForm1.kipp(Cnv: TCanvas; X, Y: integer; Bild, Hig: TBitmap; 
    Img: TImage); 
  var 
    K, I, R, U, S, B, D: integer; 
    Hlp, Pl: TBitmap; 
    F: single; 
    Zeit: cardinal; 
 
    function Berechne(Angle: single): integer; 
    var 
      RY: integer; 
      SA: single; 
    begin 
      RY := Hlp.Height - 1; 
      SA := Angle * Pi / 180; 
      Result := Round(RY - cos(SA) * RY); 
    end; 
 
    procedure Licht; 
    var 
      pba: PByteArray; 
      W, J, A: integer; 
    begin 
      A := I * 2; 
      for J := K to Hlp.Height - 1 do 
      begin 
        W := 0; 
        pba := Hlp.ScanLine[J]; 
        while W < B do 
        begin 
          pba[W] := dunkel(pba[W], A); 
          pba[W + 1] := dunkel(pba[W + 1], A); 
          pba[W + 2] := dunkel(pba[W + 2], A); 
          inc(W, 3); 
        end; 
      end; 
    end; 
 
  begin 
    Hlp := TBitmap.Create; 
    Pl := TBitmap.Create; 
    Hlp.Canvas.Brush.Color := Img.Picture.Bitmap.Canvas.Brush.Color; 
    Pl.Canvas.Brush.Color := Hlp.Canvas.Brush.Color; 
    Pl.TransparentColor := Hlp.Canvas.Brush.Color; 
    Pl.Transparent := True; 
    Hlp.PixelFormat := pf24Bit; 
    Hlp.Width := Img.Width; 
    Hlp.Height := Img.Height; 
    Pl.Width := Hlp.Width; 
    Pl.Height := Hlp.Height; 
    B := Bild.Width * 3; 
    U := Y + Bild.Height; 
    R := Round((X + Bild.Height) * 10); 
    S := Round(1000 / sqrt((R * U))); 
    S := S + Ord(S = 0); 
    F := 0.0; 
    K := 0; 
    Img.Visible := false; 
    Application.ProcessMessages; 
    Hig.assign(GetFormImage); 
    Img.Picture.Bitmap.Canvas.CopyRect(rect(0, 0, Img.Width, Img.Height), 
      Hig.Canvas, rect(X, Y, X + Img.Width, Y + Img.Height)); 
    Hig.assign(Img.Picture.Bitmap); 
 
    // --- Original 200 Millisekunden zeigen --- 
    Img.Canvas.Draw(0, 0, Hig); 
    Img.Canvas.Draw(0, 0, Bild); 
    Img.Visible := True; 
    Zeit := GetTickCount + 200; 
    repeat 
      Application.ProcessMessages; 
      if Application.Terminated then 
        exit; 
    until GetTickCount >= Zeit; 
    // ---------------------------------------- 
 
    with Hlp.Canvas do 
    begin 
      I := 0; 
      while K < Bild.Height * 0.9 do 
      begin 
        K := Berechne(I * 3); 
        FillRect(ClipRect); 
        SetStretchBltMode(Hlp.Canvas.handle, HALFTONE); 
        StretchDraw(rect(0, K, Bild.Width, Hlp.Height), Bild); 
        Licht; 
        D := Trunc(K * F); 
        Pl.Canvas.FillRect(Pl.Canvas.ClipRect); 
        SetStretchBltMode(Pl.Canvas.handle, HALFTONE); 
        Parallelograma(Pl.Canvas.handle, D, 0, 0, 0, -D, 0, Hlp); 
        Img.Canvas.Draw(0, 0, Hig); 
        Img.Canvas.Draw(0, 0, Pl); 
        inc(I, S); 
        F := F + 0.02; 
        Zeit := GetTickCount + 15; 
        repeat 
          Application.ProcessMessages; 
          if Application.Terminated then 
            exit; 
        until GetTickCount >= Zeit; 
      end; 
    end; 
    Pl.Free; 
    Hlp.Free; 
  end; 
 
  procedure TForm1.Kippen(Cnv: TCanvas; X, Y: integer; Bmp: TBitmap); 
  var 
    Hig: TBitmap; 
  begin 
    Image.Visible := false; 
    Hig := TBitmap.Create; 
    With Image.Picture.Bitmap do 
    begin 
      Brush.Color := Self.Color; 
      Width := Round(Bmp.Width * 1.25); 
      Height := Bmp.Height; 
    end; 
    Image.Left := X; 
    Image.Top := Y; 
    kipp(Cnv, X, Y, Bmp, Hig, Image); 
    Hig.Free; 
  end; 
 
 
 
// Beispiel 1 
  procedure TForm1.Button1Click(Sender: TObject); 
  var 
    X, Y: integer; 
    bm: TBitmap; 
  begin 
    X := 200; 
    Y := 100; 
    bm := TBitmap.Create; 
    bm.LoadFromFile('D:\Bilder\bernd.bmp'); 
    Kippen(Canvas, X, Y, bm); 
    bm.Free; 
  end; 
 

// Beispiel 2 
  procedure TForm1.Button2Click(Sender: TObject); 
  var 
    X, Y: integer; 
    bm: TBitmap; 
    Txt: string; 
    Sz: TSize; 
  begin 
    X := 400; 
    Y := 100; 
    Txt := ' DELPHI '; 
    bm := TBitmap.Create; 
    with bm, Canvas do 
    begin 
      Brush.Color := clred; 
      Font.Color := clYellow; 
      Font.Name := 'Courier New'; 
      Font.Size := 48; 
      Font.Style := [fsBold]; 
      Sz := TextExtent(Txt); 
      Width := Sz.cx; 
      Height := Sz.cy; 
      TextOut(0, 0, Txt); 
    end; 
    Kippen(Canvas, X, Y, bm); 
    bm.Free; 
  end;