Вращать Bitmap вокруг точки

// Vector from FromP to ToP
function TForm1.Vektor(FromP, Top: TPoint): TPoint;
begin
 Result.x := Top.x - FromP.x;
 Result.y := Top.y - FromP.y;
end;
// neue x Komponente des Verktors
// new x-component of the vector
function TForm1.xComp(Vektor: TPoint; Angle: Extended): Integer;
begin
 Result := Round(Vektor.x * cos(Angle) - (Vektor.y) * sin(Angle));
end;
// neue Y-Komponente des Vektors
// new y-component of the vector
function TForm1.yComp(Vektor: TPoint; Angle: Extended): Integer;
begin
 Result := Round((Vektor.x) * (sin(Angle)) + (vektor.y) * cos(Angle));
end;
{
 srcbit: TBitmap; // Bitmap dass gedreht werden soll ; Bitmap to be rotated
 Angle: extended; // Winkel in Bogenma?, angle
 FPoint: TPoint; // Punkt um den gedreht wird ; Point to be rotated around
 Background: TColor): TBitmap; // Hintergrundfarbe des neuen Bitmaps ;
 // Backgroundcolor of the new bitmap
}
function TForm1.RotImage(srcbit: TBitmap; Angle: Extended; FPoint: TPoint;
 Background: TColor): TBitmap;
var
 highest, lowest, mostleft, mostright: TPoint;
 topoverh, leftoverh: integer;
 x, y, newx, newy: integer;
begin
 Result := TBitmap.Create;
 // Drehwinkel runterrechnen auf eine Umdrehung, wenn notig
 // Calculate angle down on one rotation, if necessary
 while Angle >= (2 * pi) do
 begin
 angle := Angle - (2 * pi);
 end;
 // neue Ausma?e festlegen
 // specify new size
 if (angle <= (pi / 2)) then
 begin
 highest := Point(0,0); //OL
 Lowest := Point(Srcbit.Width, Srcbit.Height); //UR
 mostleft := Point(0,Srcbit.Height); //UL
 mostright := Point(Srcbit.Width, 0); //OR
 end
 else if (angle <= pi) then
 begin
 highest := Point(0,Srcbit.Height);
 Lowest := Point(Srcbit.Width, 0);
 mostleft := Point(Srcbit.Width, Srcbit.Height);
 mostright := Point(0,0);
 end
 else if (Angle <= (pi * 3 / 2)) then
 begin
 highest := Point(Srcbit.Width, Srcbit.Height);
 Lowest := Point(0,0);
 mostleft := Point(Srcbit.Width, 0);
 mostright := Point(0,Srcbit.Height);
 end
 else
 begin
 highest := Point(Srcbit.Width, 0);
 Lowest := Point(0,Srcbit.Height);
 mostleft := Point(0,0);
 mostright := Point(Srcbit.Width, Srcbit.Height);
 end;
 topoverh := yComp(Vektor(FPoint, highest), Angle);
 leftoverh := xComp(Vektor(FPoint, mostleft), Angle);
 Result.Height := Abs(yComp(Vektor(FPoint, lowest), Angle)) + Abs(topOverh);
 Result.Width := Abs(xComp(Vektor(FPoint, mostright), Angle)) + Abs(leftoverh);
 // Verschiebung des FPoint im neuen Bild gegenuber srcbit
 // change of FPoint in the new picture in relation on srcbit
 Topoverh := TopOverh + FPoint.y;
 Leftoverh := LeftOverh + FPoint.x;
 // erstmal mit Hintergrundfarbe fullen
 // at first fill with background color
 Result.Canvas.Brush.Color := Background;
 Result.Canvas.pen.Color := background;
 Result.Canvas.Fillrect(Rect(0,0,Result.Width, Result.Height));
 // Start des eigentlichen Rotierens
 // Start of actual rotation
 for y := 0 to srcbit.Height - 1 do
 begin // Zeilen ; Rows
 for x := 0 to srcbit.Width - 1 do
 begin // Spalten ; Columns
 newX := xComp(Vektor(FPoint, Point(x, y)), Angle);
 newY := yComp(Vektor(FPoint, Point(x, y)), Angle);
 newX := FPoint.x + newx - leftoverh;
 // Verschieben wegen der neuen Ausma?e
 newy := FPoint.y + newy - topoverh;
 // Move beacause of new size
 Result.Canvas.Pixels[newx, newy] := srcbit.Canvas.Pixels[x, y];
 // auch das Pixel daneben fullen um Leerpixel bei Drehungen zu verhindern
 // also fil lthe pixel beside to prevent empty pixels
 if ((angle < (pi / 2)) or
 ((angle > pi) and
 (angle < (pi * 3 / 2)))) then
 begin
 Result.Canvas.Pixels[newx, newy + 1] := srcbit.Canvas.Pixels[x, y];
 end
 else
 begin
 Result.Canvas.Pixels[newx + 1,newy] := srcbit.Canvas.Pixels[x, y];
 end;
 end;
 end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
 mybitmap, newbit: TBitMap;
begin
 if OpenDialog1.Execute then
 begin
 mybitmap := TBitmap.Create;
 mybitmap.LoadFromFile(OpenDialog1.FileName);
 newbit := RotImage(mybitmap, DegToRad(45),
 Point(mybitmap.Width div 2, mybitmap.Height div 2), clBlack);
 Image1.Canvas.Draw(0,0, newBit);
 end;
end;
Source: http://www.swissdelphicenter.ch
ID: 03849
Category:Графика
Category:Bitmap