unit CutImageFrm;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, BaseFrm, StdCtrls, ExtCtrls, Model, Math, System.UITypes;
type
TOpMode = (omNone, omDraw, omMove);
TCutImageFrame = class(TBaseFrame)
pbImage: TPaintBox;
procedure pbImagePaint(Sender: TObject);
procedure pbImageMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure pbImageMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure pbImageMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
private
{ Private declarations }
FImage : TBitmap;
FAspect : Extended;
FImageRect : TRect;
FAlphaBmp : TBitmap;
FBlendFunc : _BLENDFUNCTION;
FOpMode : TOpMode;
FHasPoints : Boolean;
FIsDrawing : Boolean;
FStartPt, FEndPt : TPoint;
procedure MoveRect(var Rect : TRect; ShiftX, ShiftY : Integer);
procedure GetFaceRects(ClipRect : TRect; var TopRect, BottomRect : TRect);
procedure BlendRectangle(CanvasHandle : THandle; R: TRect);
procedure NomalizePoints;
public
{ Public declarations }
constructor Create(AOwner : TComponent); override;
destructor Destroy; override;
function IsValid : Boolean; override;
procedure LoadFromModel(Model : TModel); override;
procedure SaveToModel(Model : TModel); override;
end;
var
CutImageFrame: TCutImageFrame;
implementation
{$R *.dfm}
constructor TCutImageFrame.Create(AOwner: TComponent);
const
cTransColor : TColor = clBlue;
cTransPercent : Byte = 25;
begin
inherited;
FImage := Nil;
FAlphaBmp := TBitmap.Create;
FAlphaBmp.Width := 1;
FAlphaBmp.Height := 1;
FAlphaBmp.Canvas.Pixels[0,0] := cTransColor;
FBlendFunc.BlendOp := AC_SRC_OVER;
FBlendFunc.BlendFlags := 0;
FBlendFunc.SourceConstantAlpha := (50 + 255*cTransPercent) Div 100;
FBlendFunc.AlphaFormat := 0;
FOpMode := omNone;
end;
procedure TCutImageFrame.LoadFromModel(Model: TModel);
begin
inherited;
If Not Assigned(FImage) Then FImage := TBitmap.Create;
FImage.Assign(Model.SourceBitmap);
FAspect := Min(pbImage.Width/FImage.Width, pbImage.Height/FImage.Height);
If FAspect > 1 Then FAspect := 1;
FImageRect := Rect(0,0,Round(FImage.Width * FAspect),Round(FImage.Height * FAspect));
MoveRect(FImageRect,Round((pbImage.Width-FImageRect.Right)/2),Round((pbImage.Height-FImageRect.Bottom)/2));
FHasPoints := False;
FIsDrawing := False;
end;
procedure TCutImageFrame.SaveToModel(Model: TModel);
var
R : TRect;
FBitmap : TBitmap;
begin
inherited;
FBitmap := TBitmap.Create;
Try
R := Rect(Min(FStartPt.X,FEndPt.X),Min(FStartPt.Y,FEndPt.Y),Max(FStartPt.X,FEndPt.X),Max(FStartPt.Y,FEndPt.Y));
MoveRect(R,-FImageRect.Left,-FImageRect.Top);
R.Left := Round(R.Left / FAspect);
R.Top := Round(R.Top / FAspect);
R.Right := Round(R.Right / FAspect);
R.Bottom := Round(R.Bottom / FAspect);
FBitmap.Width := R.Right - R.Left;
FBitmap.Height := R.Bottom - R.Top;
FBitmap.Canvas.CopyRect(Rect(0,0,FBitmap.Width,FBitmap.Height),FImage.Canvas,R);
Model.CroppedBitmap := FBitmap;
FreeAndNil(FImage);
Finally
FreeAndNil(FBitmap);
End;
end;
procedure TCutImageFrame.pbImagePaint(Sender: TObject);
var
R, FaceTop, FaceBottom : TRect;
begin
inherited;
pbImage.Canvas.StretchDraw(FImageRect,FImage);
If FHasPoints Then
Begin
R := Rect(Min(FStartPt.X,FEndPt.X),Min(FStartPt.Y,FEndPt.Y),Max(FStartPt.X,FEndPt.X),Max(FStartPt.Y,FEndPt.Y));
pbImage.Canvas.DrawFocusRect(R);
GetFaceRects(R,FaceTop,FaceBottom);
BlendRectangle(pbImage.Canvas.Handle,FaceTop);
BlendRectangle(pbImage.Canvas.Handle,FaceBottom);
End;
end;
procedure TCutImageFrame.GetFaceRects(ClipRect: TRect; var TopRect,
BottomRect: TRect);
var
RectWidth : Integer;
TenPC : Integer;
begin
{
Height: 2 inch
Head height: 1 - 1 3/8 inch (50%-69%)
Head position: 10% from the top
}
RectWidth := ClipRect.Right - ClipRect.Left;
TenPC := RectWidth div 10;
TopRect.Top := ClipRect.Top + TenPC div 2;
TopRect.Bottom := TopRect.Top + TenPC div 2;
TopRect.Left := ClipRect.Left + RectWidth div 4;
TopRect.Right := ClipRect.Right - RectWidth div 4;
BottomRect.Bottom := ClipRect.Bottom - 3 * TenPC;
BottomRect.Top := BottomRect.Bottom - TenPC div 2;
BottomRect.Left := TopRect.Left;
BottomRect.Right := TopRect.Right;
end;
procedure TCutImageFrame.MoveRect(var Rect: TRect; ShiftX,
ShiftY: Integer);
begin
Rect.Left := Rect.Left + ShiftX;
Rect.Right := Rect.Right + ShiftX;
Rect.Top := Rect.Top + ShiftY;
Rect.Bottom := Rect.Bottom + ShiftY;
end;
function TCutImageFrame.IsValid: Boolean;
begin
Result := False;
If Not FHasPoints
Then MessageDlg('Crop boundaries are not selected.',mtError,[mbOK],0)
Else Result := True;
end;
procedure TCutImageFrame.BlendRectangle(CanvasHandle : THandle; R: TRect);
begin
AlphaBlend(CanvasHandle,
R.Left, R.Top, R.Right-R.Left, R.Bottom-R.Top,
FAlphaBmp.Canvas.Handle, 0, 0, 1, 1, FBlendFunc);
end;
destructor TCutImageFrame.Destroy;
begin
FreeAndNil(FAlphaBmp);
inherited;
end;
procedure TCutImageFrame.NomalizePoints;
var
P1, P2 : TPoint;
begin
P1.X := Min(FStartPt.X,FEndPt.X);
P1.Y := Min(FStartPt.Y,FEndPt.Y);
P2.X := Max(FStartPt.X,FEndPt.X);
P2.Y := Max(FStartPt.Y,FEndPt.Y);
FStartPt := P1;
FEndPt := P2;
end;
procedure TCutImageFrame.pbImageMouseDown(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
inherited;
If (X < FImageRect.Left) Or (X > FImageRect.Right) Or
(Y < FImageRect.Top) Or (Y > FImageRect.Bottom)
Then
MessageDlg('Can''t start selection outside the photo.',mtError,[mbOK],0)
Else
Begin
FStartPt.X := X;
FStartPt.Y := Y;
FEndPt.X := X;
FEndPt.Y := Y;
FHasPoints := True;
FIsDrawing := True;
Screen.Cursor := crCross;
pbImagePaint(Sender);
End;
end;
procedure TCutImageFrame.pbImageMouseMove(Sender: TObject;
Shift: TShiftState; X, Y: Integer);
var
FDelta : Integer;
FSignX : Integer;
FSignY : Integer;
begin
inherited;
If FIsDrawing
Then
Begin
If X > FImageRect.Right Then X := FImageRect.Right;
If Y > FImageRect.Bottom Then Y := FImageRect.Bottom;
If X < FImageRect.Left Then X := FImageRect.Left;
If Y < FImageRect.Top Then Y := FImageRect.Top;
FDelta := Min(Abs(FStartPt.X - X),Abs(FStartPt.Y - Y));
FSignX := Sign(FStartPt.X - X);
FSignY := Sign(FStartPt.Y - Y);
FEndPt.X := FStartPt.X - FSignX * FDelta;
FEndPt.Y := FStartPt.Y - FSignY * FDelta;
pbImagePaint(Sender);
End
Else
Begin
{
If (X <= FEndPt.X) And (X >= FStartPt.X) And
(Y <= FEndPt.Y) And (Y >= FStartPt.Y) And FHasPoints
Then
Begin
Screen.Cursor := crSizeAll;
End
Else
Begin
Screen.Cursor := crDefault;
End;
}
End;
end;
procedure TCutImageFrame.pbImageMouseUp(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
FDelta : Integer;
FSignX : Integer;
FSignY : Integer;
begin
inherited;
If (X < FImageRect.Left) Or (X > FImageRect.Right) Or
(Y < FImageRect.Top) Or (Y > FImageRect.Bottom) Then
Begin
If X > FImageRect.Right Then X := FImageRect.Right;
If Y > FImageRect.Bottom Then Y := FImageRect.Bottom;
If X < FImageRect.Left Then X := FImageRect.Left;
If Y < FImageRect.Top Then Y := FImageRect.Top;
End;
FDelta := Min(Abs(FStartPt.X - X),Abs(FStartPt.Y - Y));
FSignX := Sign(FStartPt.X - X);
FSignY := Sign(FStartPt.Y - Y);
FEndPt.X := FStartPt.X - FSignX * FDelta;
FEndPt.Y := FStartPt.Y - FSignY * FDelta;
NomalizePoints;
FHasPoints := (FStartPt.X <> FEndPt.X) And (FstartPt.Y <> FEndPt.Y);
FIsDrawing := False;
Screen.Cursor := crDefault;
pbImagePaint(Sender);
end;
end.