// Mit dem
folgenden Code kann man Bitmaps unter Angabe eines frei // Variante 1 // Der Code funktioniert bei Bitmaps mit einer Farbtiefe von 24 Bit. 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 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; |
Zugriffe seit 6.9.2001 auf Delphi-Ecke