// Mit dem folgenden Code kann man Bitmaps unter Angabe eines frei
// bestimmbaren Winkels drehen.
// Siehe auch:
Bitmaps spiegeln / 90 drehen
// und: SetWorldTransform verwenden
 

// Variante 1

// Der Code funktioniert bei Bitmaps mit einer Farbtiefe von 24 Bit.
// Andere Farbtiefen werden umgewandelt. Wie man ganz einfach eine
// Farbtiefe von 32 Bit erreicht, zeigen die beiden auskommentierten
// Zeilen.

// Getestet mit D4 unter WinME

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; 

// --------------------------------------------------------------------------

// Variante 2

// Der Code erlaubt im Gegensatz zu Variante 1 keine Größenanpassung, ist aber
// für Bilder mit besonders kleinen Details besser geeignet. Die Grundidee
// stammt von DavData. Im Original wurde aber bei bestimmten Abmaßen das Bild
// teilweise beschnitten. Deshalb habe ich den Code überarbeitet.

type 
  TOfs = record 
    xx, yy: Single; 
  end; 
 
const 
  p180 = pi / 180; 
 
var 
  SRC, DST, HLP: TBitmap; 
  ow, oh: Byte; 
  cx, cy, dw2: Word; 
  DStep, Pdst, SStep, PSrc: Cardinal; 
  offset: array [1 .. 4, 0 .. 8] of TOfs; 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  SRC := TBitmap.Create; 
  DST := TBitmap.Create; 
  HLP := TBitmap.Create; 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject); 
begin 
  HLP.Free; 
  DST.Free; 
  SRC.Free; 
end; 
 
procedure preparation(c: TColor); 
var 
  cw, ch: Cardinal; 
  w, h: Byte; 
begin 
  DST.PixelFormat := pf32bit; 
  DST.Canvas.Brush.Color := c; 
  ow := ord(odd(SRC.width)); 
  oh := ord(odd(SRC.height)); 
  w := ow xor 1; 
  h := oh xor 1; 
  HLP.PixelFormat := pf32bit; 
  HLP.Canvas.Brush.Color := c; 
  HLP.width := SRC.width + w; 
  HLP.height := SRC.height + h; 
  HLP.Canvas.Draw(w, h, SRC); 
  cx := pred(HLP.width) div 2; 
  cy := pred(HLP.height) div 2; 
  cw := HLP.width * HLP.width; 
  ch := HLP.height * HLP.height; 
  DST.width := trunc(sqrt(cw + ch)) or 1; 
  DST.height := DST.width; 
  dw2 := DST.width div 2; 
  PSrc := dword(HLP.scanline[0]); 
  SStep := PSrc - Cardinal(HLP.scanline[1]); 
  Pdst := Cardinal(DST.scanline[0]); 
  DStep := Pdst - Cardinal(DST.scanline[1]); 
end; 
 
function Rotate(deg: Single; BackGround: TColor): TPoint; 
var 
  x, y, tt: Word; 
  rad, vsin, vcos, tx, ty, xtx, xty, ytx, yty: Single; 
  px, b1, b2, PS, PD: Cardinal; 
  ofx, ofy: SmallInt; 
  i, j, q: Byte; 
  vi, vj: Single; 
  ttx, tty, sumR, sumG, sumB: Word; 
  bgR, bgG, bgB: Byte; 
begin 
  while deg > 360 do 
    deg := deg - 360; 
  while deg < 0 do 
    deg := deg + 360; 
  BackGround := ColorToRGB(BackGround); 
  preparation(BackGround); 
  result.x := 1 + (DST.width - SRC.width) div 2 - ow; 
  result.y := 1 + (DST.height - SRC.height) div 2 - oh; 
  bgR := getRvalue(BackGround); 
  bgG := getGvalue(BackGround); 
  bgB := getBvalue(BackGround); 
  rad := p180 * deg; 
  vsin := sin(rad); 
  vcos := cos(rad); 
  tx := 0; 
  ty := tx; 
  PD := 0; 
  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 q := 1 to 4 do 
        with offset[q, i + 3 * j] do 
          case q of 
            1: 
              begin 
                xx := xtx + ytx; 
                yy := -xty + yty; 
              end; 
            2: 
              begin 
                xx := -xtx + ytx; 
                yy := xty + yty; 
              end; 
            3: 
              begin 
                xx := -xtx - ytx; 
                yy := xty - yty; 
              end; 
            4: 
              begin 
                xx := xtx - ytx; 
                yy := -xty - yty; 
              end; 
          end; 
    end; 
  end; 
  for y := 0 to dw2 do 
  begin 
    yty := y * vcos; 
    ytx := y * vsin; 
    b1 := Pdst - (dw2 + y) * DStep; 
    tt := dw2 - y; 
    b2 := Pdst - tt * DStep; 
    for x := 0 to dw2 do 
    begin 
      xtx := x * vcos; 
      xty := x * vsin; 
      for i := 1 to 4 do 
      begin 
        case i of 
          1: 
            begin 
              PD := b1 + ((dw2 + x) shl 2); 
              tx := xtx + ytx; 
              ty := -xty + yty; 
            end; 
          2: 
            begin 
              tt := dw2 - x; 
              PD := b1 + (tt shl 2); 
              tx := -xtx + ytx; 
              ty := xty + yty; 
            end; 
          3: 
            begin 
              PD := b2 + (tt shl 2); 
              tx := -xtx - ytx; 
              ty := xty - yty; 
            end; 
          4: 
            begin 
              PD := b2 + ((dw2 + x) shl 2); 
              tx := xtx - ytx; 
              ty := -xty - yty; 
            end; 
        end; 
        sumR := 0; 
        sumG := sumR; 
        sumB := sumR; 
        for j := 0 to 8 do 
        begin 
          ofx := trunc(tx + offset[i, j].xx); 
          ofy := trunc(ty + offset[i, j].yy); 
          if (abs(ofx) > cx) or (abs(ofy) > cy) then 
          begin 
            sumR := sumR + bgR; 
            sumG := sumG + bgG; 
            sumB := sumB + bgB; 
          end 
          else 
          begin 
            ttx := cx + ofx; 
            tty := cy + ofy; 
            PS := PSrc - tty * SStep + (ttx shl 2); 
            px := PCardinal(PS)^; 
            sumR := sumR + ((px shr 16) and $FF); 
            sumG := sumG + ((px shr 8) and $FF); 
            sumB := sumB + (px and $FF); 
          end; 
        end; 
        sumR := sumR div 9; 
        sumG := sumG div 9; 
        sumB := sumB div 9; 
        px := (sumR shl 16) or (sumG shl 8) or sumB; 
        PCardinal(PD)^ := px; 
      end; 
    end; 
  end; 
end; 
 
 
// Beispielaufruf: 
 
var 
  MittenKorrektur: TPoint; 
  links, oben: Integer; 
  Hintergrund: TColor; 
  Grad: Single; 
 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
  SRC.LoadFromFile('D:\bilder\dbr.bmp'); 
  links := 100; 
  oben := 100; 
  Grad := -53.7; 
  Hintergrund := clBtnFace; 
  MittenKorrektur := Rotate(Grad, Hintergrund); 
  Canvas.Draw(links - MittenKorrektur.x, oben - MittenKorrektur.y, DST); 
end;


Zugriffe seit 6.9.2001 auf Delphi-Ecke