unit RotImg;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;
type
TRotateImage = class(TGraphicControl)
private
FPicture: TPicture;
FOnProgress: TProgressEvent;
FStretch: Boolean;
FCenter: Boolean;
FIncrementalDisplay: Boolean;
FTransparent: Boolean;
FDrawing: Boolean;
FAngle: Extended;
{$IFNDEF RI_D4orHigher}
FAutoSize: Boolean;
{$ENDIF}
FUniqueSize: Boolean;
FRotatedBitmap: TBitmap;
function GetCanvas: TCanvas;
procedure PictureChanged(Sender: TObject);
procedure SetCenter(Value: Boolean);
procedure SetPicture(Value: TPicture);
procedure SetStretch(Value: Boolean);
procedure SetTransparent(Value: Boolean);
procedure SetAngle(Value: Extended);
{$IFNDEF RI_D4orHigher}
procedure SetAutoSize(Value: Boolean);
{$ENDIF}
procedure SetUniqueSize(Value: Boolean);
procedure CreateRotatedBitmap;
procedure CMColorChanged(var Msg: TMessage); message CM_COLORCHANGED;
protected
{$IFDEF RI_D4orHigher}
function CanAutoSize(var NewWidth, NewHeight: Integer): Boolean; override;
{$ELSE}
procedure AdjustSize;
{$ENDIF}
function DestRect: TRect;
function DoPaletteChange: Boolean;
function GetPalette: HPALETTE; override;
procedure Paint; override;
procedure Loaded; override;
procedure Progress(Sender: TObject; Stage: TProgressStage;
PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string); dynamic;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
property Canvas: TCanvas read GetCanvas;
property RotatedBitmap: TBitmap read FRotatedBitmap;
published
property Align;
{$IFDEF RI_D4orHigher}
property Anchors;
{$ENDIF}
property Angle: Extended read FAngle write SetAngle;
{$IFDEF RI_D4orHigher}
property AutoSize;
{$ELSE}
property AutoSize: Boolean read FAutoSize write SetAutoSize default False;
{$ENDIF}
property Center: Boolean read FCenter write SetCenter default False;
property Color;
{$IFDEF RI_D4orHigher}
property Constraints;
{$ENDIF}
property DragCursor;
{$IFDEF RI_D4orHigher}
property DragKind;
{$ENDIF}
property DragMode;
property Enabled;
property IncrementalDisplay: Boolean read FIncrementalDisplay write FIncrementalDisplay default False;
property ParentColor;
property ParentShowHint;
property Picture: TPicture read FPicture write SetPicture;
property PopupMenu;
property ShowHint;
property Stretch: Boolean read FStretch write SetStretch default False;
property Transparent: Boolean read FTransparent write SetTransparent default False;
property UniqueSize: Boolean read FUniqueSize write SetUniqueSize default True;
property Visible;
property OnClick;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
{$IFDEF RI_D4orHigher}
property OnEndDock;
{$ENDIF}
property OnEndDrag;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnProgress: TProgressEvent read FOnProgress write FOnProgress;
{$IFDEF RI_D4orHigher}
property OnStartDock;
{$ENDIF}
property OnStartDrag;
end;
function RotateBitmap(Bitmap: TBitmap; Angle: Double; Color: TColor): TBitmap;
procedure Register;
implementation
uses
Consts, Math;
// Bitmaps must be 24 bit pixel format.
// Angle is in degrees.
function RotateBitmap(Bitmap: TBitmap; Angle: Double; Color: TColor): TBitmap;
const
MaxPixelCount = 32768;
type
PRGBTripleArray = ^TRGBTripleArray;
TRGBTripleArray = array[0..MaxPixelCount] of TRGBTriple;
var
CosTheta: Extended;
SinTheta: Extended;
xSrc, ySrc: Integer;
xDst, yDst: Integer;
xODst, yODst: Integer;
xOSrc, yOSrc: Integer;
xPrime, yPrime: Integer;
srcRow, dstRow: PRGBTripleArray;
begin
Result := TBitmap.Create;
SinCos(Angle * Pi / 180, SinTheta, CosTheta);
if (SinTheta * CosTheta) < 0 then
begin
Result.Width := Round(Abs(Bitmap.Width * CosTheta - Bitmap.Height * SinTheta));
Result.Height := Round(Abs(Bitmap.Width * SinTheta - Bitmap.Height * CosTheta));
end
else
begin
Result.Width := Round(Abs(Bitmap.Width * CosTheta + Bitmap.Height * SinTheta));
Result.Height := Round(Abs(Bitmap.Width * SinTheta + Bitmap.Height * CosTheta));
end;
with Result.Canvas do
begin
Brush.Color := Color;
Brush.Style := bsSolid;
FillRect(ClipRect);
end;
Result.PixelFormat := pf24bit;
Bitmap.PixelFormat := pf24bit;
xODst := Result.Width div 2;
yODst := Result.Height div 2;
xOSrc := Bitmap.Width div 2;
yOSrc := Bitmap.Height div 2;
for ySrc := Max(Bitmap.Height, Result.Height)-1 downto 0 do
begin
yPrime := ySrc - yODst;
for xSrc := Max(Bitmap.Width, Result.Width)-1 downto 0 do
begin
xPrime := xSrc - xODst;
xDst := Round(xPrime * CosTheta - yPrime * SinTheta) + xOSrc;
yDst := Round(xPrime * SinTheta + yPrime * CosTheta) + yOSrc;
if (yDst >= 0) and (yDst < Bitmap.Height) and
(xDst >= 0) and (xDst < Bitmap.Width) and
(ySrc >= 0) and (ySrc < Result.Height) and
(xSrc >= 0) and (xSrc < Result.Width) then
begin
srcRow := Bitmap.ScanLine[yDst];
dstRow := Result.Scanline[ySrc];
dstRow[xSrc] := srcRow[xDst];
end;
end;
end;
end;
procedure TRotateImage.CreateRotatedBitmap;
var
OrgBitmap: TBitmap;
RotBitmap: TBitmap;
begin
if (Picture.Width > 0) and (Picture.Height > 0) then
begin
OrgBitmap := TBitmap.Create;
OrgBitmap.Width := Picture.Width;
OrgBitmap.Height := Picture.Height;
with OrgBitmap.Canvas do
begin
Brush.Color := Color;
Brush.Style := bsSolid;
FillRect(ClipRect);
end;
OrgBitmap.Canvas.Draw(0, 0, Picture.Graphic);
RotBitmap := RotateBitmap(OrgBitmap, Angle, Color);
if UniqueSize then
begin
with RotatedBitmap.Canvas do
begin
Brush.Color := Color;
Brush.Style := bsSolid;
FillRect(ClipRect);
end;
RotatedBitmap.Width := Round(Sqrt(Sqr(Picture.Width+2) + Sqr(Picture.Height+2)));
RotatedBitmap.Height := RotatedBitmap.Width;
RotatedBitmap.Transparent := Transparent;
if Center and not Stretch then
RotatedBitmap.Canvas.Draw((RotatedBitmap.Width - RotBitmap.Width) div 2,
(RotatedBitmap.Height - RotBitmap.Height) div 2, RotBitmap)
else
RotatedBitmap.Canvas.Draw(0, 0, RotBitmap);
RotBitmap.Free;
end
else
begin
RotatedBitmap.Free;
FRotatedBitmap := RotBitmap;
end;
OrgBitmap.Free;
end
else
begin
RotatedBitmap.Width := 0;
RotatedBitmap.Height := 0;
end;
if AutoSize then AdjustSize;
end;
constructor TRotateImage.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle := ControlStyle + [csReplicatable];
FPicture := TPicture.Create;
FPicture.OnChange := PictureChanged;
FPicture.OnProgress := Progress;
FUniqueSize := True;
FRotatedBitmap := TBitmap.Create;
Height := 105;
Width := 105;
end;
destructor TRotateImage.Destroy;
begin
Picture.Free;
RotatedBitmap.Free;
inherited Destroy;
end;
function TRotateImage.GetPalette: HPALETTE;
begin
Result := 0;
if Picture.Graphic <> nil then
Result := Picture.Graphic.Palette;
end;
function TRotateImage.DestRect: TRect;
begin
if Stretch then
Result := ClientRect
else if Center then
Result := Bounds((Width - RotatedBitmap.Width) div 2,
(Height - RotatedBitmap.Height) div 2,
RotatedBitmap.Width, RotatedBitmap.Height)
else
Result := Rect(0, 0, RotatedBitmap.Width, RotatedBitmap.Height);
end;
procedure TRotateImage.Paint;
var
Save: Boolean;
begin
if not RotatedBitmap.Empty then
begin
Save := FDrawing;
FDrawing := True;
try
with inherited Canvas do
StretchDraw(DestRect, RotatedBitmap);
finally
FDrawing := Save;
end;
end;
if csDesigning in ComponentState then
with inherited Canvas do
begin
Pen.Style := psDash;
Brush.Style := bsClear;
Rectangle(0, 0, Width, Height);
end;
end;
procedure TRotateImage.Loaded;
begin
inherited Loaded;
PictureChanged(Self);
end;
function TRotateImage.DoPaletteChange: Boolean;
var
ParentForm: TCustomForm;
G: TGraphic;
begin
Result := False;
G := Picture.Graphic;
if Visible and (not (csLoading in ComponentState)) and
(G <> nil) and (G.PaletteModified) then
begin
if (G.Palette = 0) then
G.PaletteModified := False
else
begin
ParentForm := GetParentForm(Self);
if Assigned(ParentForm) and ParentForm.Active and Parentform.HandleAllocated then
begin
if FDrawing then
ParentForm.Perform(WM_QUERYNEWPALETTE, 0, 0)
else
PostMessage(ParentForm.Handle, WM_QUERYNEWPALETTE, 0, 0);
Result := True;
G.PaletteModified := False;
end;
end;
end;
end;
procedure TRotateImage.Progress(Sender: TObject; Stage: TProgressStage;
PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string);
begin
if IncrementalDisplay and RedrawNow then
begin
if DoPaletteChange then Update
else Paint;
end;
if Assigned(OnProgress) then OnProgress(Sender, Stage, PercentDone, RedrawNow, R, Msg);
end;
function TRotateImage.GetCanvas: TCanvas;
var
Bitmap: TBitmap;
begin
if Picture.Graphic = nil then
begin
Bitmap := TBitmap.Create;
try
Bitmap.Width := Width;
Bitmap.Height := Height;
Picture.Graphic := Bitmap;
finally
Bitmap.Free;
end;
end;
if Picture.Graphic is TBitmap then
Result := TBitmap(Picture.Graphic).Canvas
else
raise EInvalidOperation.Create(SImageCanvasNeedsBitmap);
end;
procedure TRotateImage.CMColorChanged(var Msg: TMessage);
begin
inherited;
CreateRotatedBitmap;
end;
procedure TRotateImage.SetCenter(Value: Boolean);
begin
if Value <> Center then
begin
FCenter := Value;
PictureChanged(Self)
end;
end;
procedure TRotateImage.SetPicture(Value: TPicture);
begin
Picture.Assign(Value);
end;
procedure TRotateImage.SetStretch(Value: Boolean);
begin
if Value <> Stretch then
begin
FStretch := Value;
PictureChanged(Self);
end;
end;
procedure TRotateImage.SetTransparent(Value: Boolean);
begin
if Value <> Transparent then
begin
FTransparent := Value;
PictureChanged(Self);
end;
end;
procedure TRotateImage.SetAngle(Value: Extended);
begin
if Value <> Angle then
begin
FAngle := Value;
PictureChanged(Self);
end;
end;
{$IFNDEF RI_D4orHigher}
procedure TRotateImage.SetAutoSize(Value: Boolean);
begin
if Value <> AutoSizethen
begin
FAutoSize := Value;
if FAutoSize then AdjustSize;
end;
end;
{$ENDIF}
procedure TRotateImage.SetUniqueSize(Value: Boolean);
begin
if Value <> UniqueSize then
begin
FUniqueSize := Value;
PictureChanged(Self);
end;
end;
procedure TRotateImage.PictureChanged(Sender: TObject);
var
G: TGraphic;
begin
if not (csLoading in ComponentState) then
begin
G := Picture.Graphic;
if G <> nil then
begin
if not ((G is TMetaFile) or (G is TIcon)) then
G.Transparent := FTransparent;
if (not G.Transparent) and (Stretch or (RotatedBitmap.Width >= Width)
and (RotatedBitmap.Height >= Height)) then
ControlStyle := ControlStyle + [csOpaque]
else
ControlStyle := ControlStyle - [csOpaque];
if DoPaletteChange and FDrawing then Update;
end
else
ControlStyle := ControlStyle - [csOpaque];
CreateRotatedBitmap;
if AutoSize and (Picture.Width > 0) and (Picture.Height > 0) then
SetBounds(Left, Top, RotatedBitmap.Width, RotatedBitmap.Height);
if not FDrawing then Invalidate;
end;
end;
{$IFDEF RI_D4orHigher}
function TRotateImage.CanAutoSize(var NewWidth, NewHeight: Integer): Boolean;
begin
Result := True;
if not (csDesigning in ComponentState) or
(RotatedBitmap.Width > 0) and (RotatedBitmap.Height > 0) then
begin
if Align in [alNone, alLeft, alRight] then
NewWidth := RotatedBitmap.Width;
if Align in [alNone, alTop, alBottom] then
NewHeight := RotatedBitmap.Height;
end;
end;
{$ENDIF}
{$IFNDEF RI_D4orHigher}
procedure TRotateImage.AdjustSize;
begin
if not (csDesigning in ComponentState) or
(RotatedBitmap.Width > 0) and (RotatedBitmap.Height > 0) then
begin
if Align in [alNone, alLeft, alRight] then
Width := RotatedBitmap.Width;
if Align in [alNone, alTop, alBottom] then
Height := RotatedBitmap.Height;
end;
end;
{$ENDIF}
procedure Register;
begin
RegisterComponents('Samples', [TRotateImage]);
end;
end.