procedure RotateBitmap(Dest, Source: TBitmap; Winkel: Extended; 
  Hintergrund: TColor; GroesseAnpassen, ImUhrzeigersinn: Boolean); 
var 
  rw: Boolean; 
  Breite: integer; 
type 
  PR = array[0..2] of byte; 
//PR = array[0..3] of byte; 
  FArray = array[0..32768] of PR; 
  procedure WTest; 
  begin 
    while Winkel > 360 do Winkel := Winkel - 360; 
    while Winkel < 0 do Winkel := Winkel + 360; 
    if ImUhrzeigersinn then Winkel := 360 - Winkel; 
  end; 
  procedure SiCo(W: Extended; var S, C: Extended); 
  asm 
        FLD     W 
        FSINCOS 
        FSTP    TBYTE PTR [EDX] 
        FSTP    TBYTE PTR [EAX] 
        FWAIT 
  end; 
  function Maximum(M1, M2: Integer): Integer; 
  begin 
    if M1 > M2 then Result := M1 
    else Result := M2; 
  end; 
  procedure SC(WKL: Extended; var S, C: Extended); 
  begin 
    WKL := WKL * (PI / 180); 
    SiCo(WKL, S, C); 
  end; 
var 
  CT, ST: Extended; 
  I, J, X, Y, DstW, DstH, SrcWD2, SrcHD2: Integer; 
  SrcR, DstR: ^FArray; 
begin 
  Source.PixelFormat := pf24bit; 
//Source.PixelFormat := pf32bit; 
  Dest.PixelFormat := Source.PixelFormat; 
  WTest; 
  rw := frac(Winkel / 90) = 0; 
  SC(Winkel, ST, CT); 
  if GroesseAnpassen then begin 
    if (ST * CT) < 0 then begin 
      Dest.Width := Round(Abs(Source.Width * CT 
        - Source.Height * ST)); 
      Dest.Height := Round(Abs(Source.Width * ST 
        - Source.Height * CT)); 
    end 
    else begin 
      Dest.Width := Round(Abs(Source.Width * CT 
        + Source.Height * ST)); 
      Dest.Height := Round(Abs(Source.Width * ST 
        + Source.Height * CT)); 
    end; 
  end else begin 
    Dest.Width := Source.Width; 
    Dest.Height := Source.Height; 
  end; 
  with Dest.Canvas do begin 
    Brush.Style := bsSolid; 
    Brush.Color := Hintergrund; 
    FillRect(ClipRect); 
  end; 
  SrcWD2 := Source.Width div 2; 
  if CT < 0 then Dec(SrcWD2); 
  SrcHD2 := Source.Height div 2; 
  if ST < 0 then Dec(SrcHD2); 
  Breite := Maximum(Source.Width, Dest.Width) - 1; 
  for J := 0 to Maximum(Source.Height, Dest.Height) - 1 do begin 
    if rw then 
      Y := Trunc(J - Dest.Height / 2 + 0.5) else 
      Y := J - Dest.Height div 2; 
    for I := 0 to Breite do begin 
      if rw then 
        X := Trunc(I - Dest.Width / 2) else 
        X := I - Dest.Width div 2; 
      DstW := Round(X * CT - Y * ST + SrcWD2); 
      DstH := Round(X * ST + Y * CT + SrcHD2); 
      if (DstH >= 0) and (DstH < Source.Height) and 
        (J >= 0) and (J < Dest.Height) and 
        (DstW >= 0) and (DstW < Source.Width) and 
        (I >= 0) and (I < Dest.Width) then begin 
        SrcR := Source.ScanLine[DstH]; 
        DstR := Dest.Scanline[J]; 
        DstR[I] := SrcR[DstW]; 
      end; 
    end; 
  end; 
end; 
 
// Beispielaufruf 
procedure TForm1.Button1Click(Sender: TObject); 
var Bmp: TBitmap; 
begin 
  Bmp := TBitmap.create; 
  RotateBitmap(Bmp, Image1.picture.bitmap, 53.7, clRed, True, False); 
  Refresh; 
  canvas.draw(10, 10, Bmp); 
  Bmp.free; 
end; 

type 
  TOffset = record 
    fx: single; 
    fy: single; 
  end; 
 
var 
  diff: TPoint; 
  r, g, b: Byte; 
  Grad: single = 0.0; 
  links, oben: integer; 
  Quell, Ziel: TBitmap; 
  dcxy, scx, scy: Word; 
  ZStep, QStep, PQuell, PZiel: Cardinal; 
  offs: array [1 .. 4, 0 .. 8] of TOffset; 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  Timer1.Interval := 0; // für Beispiel 2 
  Quell := TBitmap.Create; 
  Ziel := TBitmap.Create; 
  Doublebuffered := true; 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject); 
begin 
  Quell.Free; 
  Ziel.Free; 
end; 
 
function TForm1.Vorbereitung(gr: TGraphic; dm: TBitmap; cl: TColor): TPoint; 
begin 
  Quell.PixelFormat := pf32bit; 
  Quell.Width := gr.Width; 
  Quell.Height := gr.Height; 
  Quell.Canvas.Draw(0, 0, gr); 
  Ziel := dm; 
  Ziel.PixelFormat := pf32bit; 
  Ziel.Canvas.Brush.Color := ColorToRGB(cl); 
  scx := (Quell.Width - 1) shr 1; 
  scy := (Quell.Height - 1) shr 1; 
  Ziel.Width := 2 + trunc(sqrt(sqr(Quell.Width) + sqr(Quell.Height))) or 1; 
  Ziel.Height := Ziel.Width; 
  Result.x := (Ziel.Width - Quell.Width + 1) shr 1; 
  Result.y := (Ziel.Height - Quell.Height + 1) shr 1; 
  dcxy := trunc(Ziel.Width / 2); 
  PQuell := Cardinal(Quell.scanline[0]); 
  QStep := PQuell - Cardinal(Quell.scanline[1]); 
  PZiel := Cardinal(Ziel.scanline[0]); 
  ZStep := PZiel - Cardinal(Ziel.scanline[1]); 
end; 
 
procedure TForm1.DoIt(Grad: single); 
var 
  vi, vj, vsin, vcos, tx, ty, xtx, xty, ytx, yty: single; 
  ttx, tty, sumR, sumG, sumB, x, y, t: Word; 
  pix, Ybase1, Ybase2, PS, PD: Cardinal; 
  trunctx, truncty: SmallInt; 
  i, j, vier: Byte; 
begin 
  while Grad > 360 do 
    Grad := Grad - 360; 
  while Grad < 360 do 
    Grad := Grad + 360; 
  Grad := (PI / 180) * Grad; 
  vsin := sin(Grad); 
  vcos := cos(Grad); 
  for j := 0 to 2 do 
  begin 
    vj := 0.333 * j; 
    yty := vj * vcos; 
    ytx := vj * vsin; 
    for i := 0 to 2 do 
    begin 
      vi := 0.333 * i; 
      xtx := vi * vcos; 
      xty := vi * vsin; 
      for vier := 1 to 4 do 
        with offs[vier, i + 3 * j] do 
          case vier of 
            1: 
              begin 
                fx := xtx + ytx; 
                fy := -xty + yty; 
              end; 
            2: 
              begin 
                fx := -xtx + ytx; 
                fy := xty + yty; 
              end; 
            3: 
              begin 
                fx := -xtx - ytx; 
                fy := xty - yty; 
              end; 
            else 
              begin 
                fx := xtx - ytx; 
                fy := -xty - yty; 
              end; 
            end; 
    end; 
  end; 
  for y := 0 to dcxy do 
  begin 
    yty := y * vcos; 
    ytx := y * vsin; 
    Ybase1 := PZiel - (dcxy + y) * ZStep; 
    t := dcxy - y; 
    Ybase2 := PZiel - t * ZStep; 
    for x := 0 to dcxy do 
    begin 
      xtx := x * vcos; 
      xty := x * vsin; 
      for i := 1 to 4 do 
      begin 
        case i of 
          1: 
            begin 
              PD := Ybase1 + ((dcxy + x) shl 2); 
              tx := xtx + ytx; 
              ty := -xty + yty; 
            end; 
          2: 
            begin 
              t := dcxy - x; 
              PD := Ybase1 + (t shl 2); 
              tx := -xtx + ytx; 
              ty := xty + yty; 
            end; 
          3: 
            begin 
              PD := Ybase2 + (t shl 2); 
              tx := -xtx - ytx; 
              ty := xty - yty; 
            end; 
          else 
            begin 
              PD := Ybase2 + ((dcxy + x) shl 2); 
              tx := xtx - ytx; 
              ty := -xty - yty; 
            end; 
          end; 
        sumR := 0; 
        sumG := 0; 
        sumB := 0; 
        for j := 0 to 8 do 
        begin 
          trunctx := trunc(tx + offs[i, j].fx); 
          truncty := trunc(ty + offs[i, j].fy); 
          if (abs(trunctx) > scx) or (abs(truncty) > scy) then 
          begin 
            sumR := sumR + r; 
            sumG := sumG + g; 
            sumB := sumB + b; 
          end 
          else 
          begin 
            ttx := scx + trunctx; 
            tty := scy + truncty; 
            PS := PQuell - tty * QStep + (ttx shl 2); 
            pix := PDWord(PS)^; 
            sumR := sumR + ((pix shr 16) and $FF); 
            sumG := sumG + ((pix shr 8) and $FF); 
            sumB := sumB + (pix and $FF); 
          end; 
        end; 
        sumR := sumR div 9; 
        sumG := sumG div 9; 
        sumB := sumB div 9; 
        pix := (sumR shl 16) or (sumG shl 8) or sumB; 
        PDWord(PD)^ := pix; 
      end; 
    end; 
  end; 
end; 
 
procedure TForm1.Rotate(grphk: TGraphic; Grad: single; cl: TColor); 
begin 
  cl := ColorToRGB(cl); 
  r := Getrvalue(cl); 
  g := Getgvalue(cl); 
  b := Getbvalue(cl); 
  diff := Vorbereitung(grphk, Ziel, cl); 
  DoIt(Grad); 
end; 
 
procedure TForm1.zeigen(cnv: TCanvas; x, y: integer); 
begin 
  cnv.Draw(x - diff.x, y - diff.y, Ziel); 
end; 
 
 
// Beispielaufrufe mit einem TImage 
 
// einmalig um einen bestimmten Betrag nach links drehen 
procedure TForm1.Button1Click(Sender: TObject); 
var 
  Hintergrund: TColor; 
begin 
  Hintergrund := clBtnFace; // z.B. 
  links := Image1.Left; 
  oben := Image1.Top; 
  Grad := -45.3; 
  Rotate(Image1.Picture.Graphic, Grad, Hintergrund); 
  zeigen(Canvas, links, oben); 
end; 
// -------------------------------------------- 
 
// ständig im Uhrzeigersinn drehen 
procedure TForm1.Button2Click(Sender: TObject); 
begin 
  if Timer1.Interval = 0 then 
  begin 
    links := Image1.Left; 
    oben := Image1.Top; 
    Rotate(Image1.Picture.Graphic, Grad, Color); 
    Timer1.Interval := 10; 
  end 
  else 
    Timer1.Interval := 0; 
end; 
 
procedure TForm1.Timer1Timer(Sender: TObject); 
begin 
  Grad := Grad + 1.0; 
  DoIt(Grad); 
  zeigen(Canvas, links, oben); 
end;