Create a special visual selection tool for Image - delphi

Question

I want to create a special kind of selection, in which the image darkened and in part which user is selecting, the real Image is shown. You can see an Example:
I found two approaches for implementing this:
Implementing a control which show the darkened image.
When user drag an ellipse over this control, an ellipse copy the real image (Image which is NOT Darkened) into the control canvas.
In this scenario When he/she try to Resize the ellipse to SMALLER SIZE, first the whole rectangular area of ellipse darkened and then real image draw in the new Smaller Ellipse.
Same as Approach 1, but instead of drawing on the canvas of the control, we create a new control which show the real image. In this case, all messages send to the new control, SHOULD pass to the parent control. Because if user try to resize the ellipse to smaller size, WM_MOVE messages sent to this control, instead of the parent control.
Can please, someone show me the right direction for implementing this. I think that approach 1 is very hard to implement because it cause lot's of Flicker. Unless I implement a way to only repaint the changed part by InvalidateRect function.
Here is the code of the class TScreenEmul which is implemented by me, until now. It works but it has flicker.
unit ScreenEmul;
interface
uses Classes, Types, Windows, Messages, Graphics, Controls, SysUtils, Dialogs, ExtCtrls;
const
PixelCountMax = 32768;
type
PRGBTripleArray = ^TRGBTripleArray;
TRGBTripleArray = array[0..PixelCountMax-1] of TRGBTriple;
TScreenEmul = class(TCustomControl)
private
LastRect, DrawRect: TRect;
DrawStart: TPoint;
MouseDown: Boolean;
Backup, Darken: TBitmap;
FBitmap: TBitmap;
procedure BitmapChange(Sender: TObject);
procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
procedure WMMouseMove(var Message: TWMMouseMove); message WM_MOUSEMOVE;
procedure WMLButtonUp(var Message: TWMLButtonUp); message WM_LBUTTONUP;
procedure WMEraseBkgnd(var Message: TWMEraseBkgnd ); message WM_ERASEBKGND;
procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
procedure DarkenBitmap(B: TBitmap);
procedure RestoreImage;
procedure CalculateDrawRect(X, Y: Integer);
procedure SetBitmap(const Value: TBitmap);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
property Bitmap: TBitmap read FBitmap write SetBitmap;
end;
implementation
{ TScreenEmul }
function AlphaBlend(Color1, Color2: TRGBTriple; Alpha: Byte): TRGBTriple; overload;
var
rPrimary : Real; // Primary (Color1) Intensity
rSecondary: Real;// Secondary (Color2) Intensity
begin
rPrimary:=((Alpha+1)/$100);
rSecondary:=(($100-Alpha)/$100);
with Result do
begin
rgbtBlue := Trunc(Color1.rgbtBlue * rPrimary + Color2.rgbtBlue * rSecondary);
rgbtGreen := Trunc(Color1.rgbtGreen * rPrimary + Color2.rgbtGreen * rSecondary);
rgbtRed := Trunc(Color1.rgbtRed * rPrimary + Color2.rgbtRed * rSecondary);
end;
end;
procedure TScreenEmul.BitmapChange(Sender: TObject);
begin
FreeAndNil(Backup);
Backup := TBitmap.Create;
Backup.Assign(FBitmap);
DarkenBitmap(FBitmap);
Darken := TBitmap.Create;
Darken.Assign(FBitmap);
end;
procedure TScreenEmul.CalculateDrawRect(X, Y: Integer);
begin
if X >= DrawStart.X then
begin
if DrawRect.Left <> DrawStart.X then DrawRect.Left := DrawStart.X;
DrawRect.Right := X
end
else
begin
if DrawRect.Right <> DrawStart.X then DrawRect.Right := DrawStart.X;
DrawRect.Left := X;
end;
if Y >= DrawStart.Y then
begin
if DrawRect.Top <> DrawStart.Y then DrawRect.Top := DrawStart.Y;
DrawRect.Bottom := Y;
end
else
begin
if DrawRect.Bottom <> DrawStart.Y then DrawRect.Bottom := DrawStart.Y;
DrawRect.Top := Y;
end;
end;
constructor TScreenEmul.Create(AOwner: TComponent);
begin
inherited;
MouseDown := False;
FBitmap := TBitmap.Create;
FBitmap.OnChange := BitmapChange;
DoubleBuffered := True;
end;
procedure TScreenEmul.DarkenBitmap(B: TBitmap);
var
I, J: Integer;
Row: PRGBTripleArray;
rgbBlack: tagRGBTRIPLE;
begin
rgbBlack.rgbtBlue := 0; rgbBlack.rgbtGreen := 0; rgbBlack.rgbtRed := 0;
for I := 0 to B.Height - 1 do
begin
Row := B.ScanLine[I];
for J := 0 to B.Width - 1 do
Row[J] := AlphaBlend(Row[J], rgbBlack, 150);
end;
end;
destructor TScreenEmul.Destroy;
begin
FBitmap.Free;
inherited;
end;
procedure TScreenEmul.RestoreImage;
begin
BitBlt(FBitmap.Canvas.Handle,
LastRect.Left, LastRect.Top, RectWidth(LastRect), RectHeight(LastRect),
Darken.Canvas.Handle, LastRect.Left, LastRect.Top, SRCCOPY);
end;
procedure TScreenEmul.SetBitmap(const Value: TBitmap);
begin
FBitmap := Value;
FBitmap.OnChange := BitmapChange;
end;
procedure TScreenEmul.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
Message.Result := LResult(False);
end;
procedure TScreenEmul.WMLButtonDown(var Message: TWMLButtonDown);
begin
MouseDown := True;
with DrawRect do
begin
Left := Message.XPos;
Top := Message.YPos;
Right := Left;
Bottom := Top;
end;
DrawStart.X := DrawRect.Top;
DrawStart.Y := DrawRect.Left;
end;
procedure TScreenEmul.WMLButtonUp(var Message: TWMLButtonUp);
begin
MouseDown := False;
RestoreImage;
InvalidateRect(Self.Handle, DrawRect, False);
end;
procedure TScreenEmul.WMMouseMove(var Message: TWMMouseMove);
begin
if not MouseDown then Exit;
CalculateDrawRect(Message.XPos, Message.YPos);
RestoreImage;
BitBlt(
FBitmap.Canvas.Handle,
DrawRect.Left, DrawRect.Top, RectWidth(DrawRect), RectHeight(DrawRect),
Backup.Canvas.Handle,
DrawRect.Left, DrawRect.Top,
SRCCOPY);
InvalidateRect(Self.Handle, DrawRect, False);
LastRect := DrawRect;
end;
procedure TScreenEmul.WMPaint(var Message: TWMPaint);
var
B: TBitmap;
Rct: TRect;
X, Y: Integer;
FullRepaint: Boolean;
begin
inherited;
FullRepaint := GetUpdateRect(Self.Handle, Rct, False);
if not FullRepaint then
begin
Canvas.Draw(0, 0, FBitmap);
end
else
begin
B := TBitmap.Create;
B.SetSize(RectWidth(Rct), RectHeight(Rct));
FBitmap.Canvas.CopyRect(Rect(0, 0, B.Width, B.Height), B.Canvas, Rct);
Canvas.Draw(0, 0, B);
FreeAndNil(B);
end;
end;
end.
For using this class:
var
ScreenEmul: TScreenEmul;
begin
ScreenEmul := TScreenEmul.Create(Self);
ScreenEmul.Parent := Self;
ScreenEmul.Align := alClient;
ScreenEmul.Bitmap.LoadFromFile('C:\img13.bmp');

Answer 1

I solved the problem. I answer the question for the record:
1- WMEraseBkgnd should return True to prevent painting background. I mistakenly returned False.
2- I inherited the WMPaint method which is not correct. I also copy the updated Rect into new Bitmap and then draw the bitmap into canvas which was slow the painting process. Here is full fixed source code:
unit ScreenEmul;
interface
uses Classes, Types, Windows, Messages, Graphics, Controls, SysUtils, Dialogs, ExtCtrls;
const
PixelCountMax = 32768;
type
PRGBTripleArray = ^TRGBTripleArray;
TRGBTripleArray = array[0..PixelCountMax-1] of TRGBTriple;
TScreenEmul = class(TCustomControl)
private
LastRect, DrawRect: TRect;
DrawStart: TPoint;
MouseDown: Boolean;
Backup, Darken: TBitmap;
FBitmap: TBitmap;
procedure BitmapChange(Sender: TObject);
procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
procedure WMMouseMove(var Message: TWMMouseMove); message WM_MOUSEMOVE;
procedure WMLButtonUp(var Message: TWMLButtonUp); message WM_LBUTTONUP;
procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
procedure DarkenBitmap(B: TBitmap);
procedure RestoreImage;
procedure CalculateDrawRect(X, Y: Integer);
procedure SetBitmap(const Value: TBitmap);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
property Bitmap: TBitmap read FBitmap write SetBitmap;
end;
implementation
{ TScreenEmul }
function AlphaBlend(Color1, Color2: TRGBTriple; Alpha: Byte): TRGBTriple; overload;
var
rPrimary : Real; // Primary (Color1) Intensity
rSecondary: Real;// Secondary (Color2) Intensity
begin
rPrimary:=((Alpha+1)/$100);
rSecondary:=(($100-Alpha)/$100);
with Result do
begin
rgbtBlue := Trunc(Color1.rgbtBlue * rPrimary + Color2.rgbtBlue * rSecondary);
rgbtGreen := Trunc(Color1.rgbtGreen * rPrimary + Color2.rgbtGreen * rSecondary);
rgbtRed := Trunc(Color1.rgbtRed * rPrimary + Color2.rgbtRed * rSecondary);
end;
end;
procedure TScreenEmul.BitmapChange(Sender: TObject);
begin
FreeAndNil(Backup);
Backup := TBitmap.Create;
Backup.Assign(FBitmap);
DarkenBitmap(FBitmap);
Darken := TBitmap.Create;
Darken.Assign(FBitmap);
end;
procedure TScreenEmul.CalculateDrawRect(X, Y: Integer);
begin
if X >= DrawStart.X then
begin
if DrawRect.Left <> DrawStart.X then DrawRect.Left := DrawStart.X;
DrawRect.Right := X
end
else
begin
if DrawRect.Right <> DrawStart.X then DrawRect.Right := DrawStart.X;
DrawRect.Left := X;
end;
if Y >= DrawStart.Y then
begin
if DrawRect.Top <> DrawStart.Y then DrawRect.Top := DrawStart.Y;
DrawRect.Bottom := Y;
end
else
begin
if DrawRect.Bottom <> DrawStart.Y then DrawRect.Bottom := DrawStart.Y;
DrawRect.Top := Y;
end;
end;
constructor TScreenEmul.Create(AOwner: TComponent);
begin
inherited;
MouseDown := False;
FBitmap := TBitmap.Create;
FBitmap.OnChange := BitmapChange;
DoubleBuffered := True;
end;
procedure TScreenEmul.DarkenBitmap(B: TBitmap);
var
I, J: Integer;
Row: PRGBTripleArray;
rgbBlack: tagRGBTRIPLE;
begin
rgbBlack.rgbtBlue := 0; rgbBlack.rgbtGreen := 0; rgbBlack.rgbtRed := 0;
for I := 0 to B.Height - 1 do
begin
Row := B.ScanLine[I];
for J := 0 to B.Width - 1 do
Row[J] := AlphaBlend(Row[J], rgbBlack, 150);
end;
end;
destructor TScreenEmul.Destroy;
begin
FBitmap.Free;
inherited;
end;
procedure TScreenEmul.RestoreImage;
begin
BitBlt(FBitmap.Canvas.Handle,
LastRect.Left, LastRect.Top, RectWidth(LastRect), RectHeight(LastRect),
Darken.Canvas.Handle, LastRect.Left, LastRect.Top, SRCCOPY);
end;
procedure TScreenEmul.SetBitmap(const Value: TBitmap);
begin
FBitmap := Value;
FBitmap.OnChange := BitmapChange;
end;
procedure TScreenEmul.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
Message.Result := LResult(True);
end;
procedure TScreenEmul.WMLButtonDown(var Message: TWMLButtonDown);
begin
MouseDown := True;
with DrawRect do
begin
Left := Message.XPos;
Top := Message.YPos;
Right := Left;
Bottom := Top;
end;
DrawStart.X := DrawRect.Top;
DrawStart.Y := DrawRect.Left;
end;
procedure TScreenEmul.WMLButtonUp(var Message: TWMLButtonUp);
begin
MouseDown := False;
RestoreImage;
InvalidateRect(Self.Handle, DrawRect, False);
end;
procedure TScreenEmul.WMMouseMove(var Message: TWMMouseMove);
begin
if not MouseDown then Exit;
CalculateDrawRect(Message.XPos, Message.YPos);
RestoreImage;
BitBlt(
FBitmap.Canvas.Handle,
DrawRect.Left, DrawRect.Top, RectWidth(DrawRect), RectHeight(DrawRect),
Backup.Canvas.Handle,
DrawRect.Left, DrawRect.Top,
SRCCOPY);
InvalidateRect(Self.Handle, DrawRect, False);
LastRect := DrawRect;
end;
procedure TScreenEmul.WMPaint(var Message: TWMPaint);
var
Rct: TRect;
FullRepaint: Boolean;
begin
FullRepaint := GetUpdateRect(Self.Handle, Rct, False);
if not FullRepaint then
Canvas.Draw(0, 0, FBitmap)
else
BitBlt(Canvas.Handle, Rct.Left, Rct.Top, RectWidth(Rct), RectHeight(Rct), FBitmap.Canvas.Handle, Rct.Left, Rct.Top, SRCCOPY);
end;
end.

Answer 2

I have done someting similar... here are extracts of my code (only one bitmap in memory):
Grab screen ...
Type
GrabScreen = (GTSCREEN);
[...]
procedure PGrabScreen(bm: TBitMap; gt : GrabScreen);
var
DestRect, SourceRect: TRect;
h: THandle;
hdcSrc : THandle;
pt : TPoint;
begin
case(gt) of
//...
GTSCREEN : h := GetDesktopWindow;
end;
if h <> 0 then
begin
try
begin
hdcSrc := GetWindowDC(h);
GetWindowRect(h, SourceRect);
end;
bm.Width := SourceRect.Right - SourceRect.Left;
bm.Height := SourceRect.Bottom - SourceRect.Top;
DestRect := Rect(0, 0, SourceRect.Right - SourceRect.Left, SourceRect.Bottom - SourceRect.Top);
StretchBlt(bm.Canvas.Handle, 0, 0, bm.Width,
bm.Height, hdcSrc,
0,0,SourceRect.Right - SourceRect.Left,
SourceRect.Bottom - SourceRect.Top,
SRCCOPY);
DrawCursor(bm,SourceRect.Left, SourceRect.Top);
finally
ReleaseDC(0, hdcSrc);
end;
end;
end;
Blur that bitmap once selection is initiated by mouse down (suggested code)
procedure BitmapBlur(var theBitmap: TBitmap);
var
x, y: Integer;
yLine,
xLine: PByteArray;
begin
for y := 1 to theBitmap.Height -2 do begin
yLine := theBitmap.ScanLine[y -1];
xLine := theBitmap.ScanLine[y];
for x := 1 to theBitmap.Width -2 do begin
xLine^[x * 3] := (
xLine^[x * 3 -3] + xLine^[x * 3 +3] +
yLine^[x * 3 -3] + yLine^[x * 3 +3] +
yLine^[x * 3] + xLine^[x * 3 -3] +
xLine^[x * 3 +3] + xLine^[x * 3]) div 8;
xLine^[x * 3 +1] := (
xLine^[x * 3 -2] + xLine^[x * 3 +4] +
yLine^[x * 3 -2] + yLine^[x * 3 +4] +
yLine^[x * 3 +1] + xLine^[x * 3 -2] +
xLine^[x * 3 +4] + xLine^[x * 3 +1]) div 8;
xLine^[x * 3 +2] := (
xLine^[x * 3 -1] + xLine^[x * 3 +5] +
yLine^[x * 3 -1] + yLine^[x * 3 +5] +
yLine^[x * 3 +2] + xLine^[x * 3 -1] +
xLine^[x * 3 +5] + xLine^[x * 3 +2]) div 8;
end;
end;
end;
Select area* on the blurred bitmap on screen (exemple:)
procedure GrabSelectedArea(Sender: TObject);
begin
Grab(image1.Picture.Bitmap, GTSCREEN);
bmp := Image1.Picture.Bitmap;
image1.Width := image1.Picture.Bitmap.Width;
image1.Height := image1.Picture.Bitmap.Height;
DoSelect := true;
end;
Doing so, reverse (offset) the blur effect for the selected area on the bitmap.
*Here the code i have for selection
procedure Image1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var
DestRect, SourceRect : TRect;
begin
if DoSelect then begin
Image1.Canvas.Rectangle(SelX,SelY,SelX1,SelY1);
if X <= SelX then
begin
SelX1 := SelX;
SelX := X;
end
else
SelX1 := X;
if Y <= SelY then
begin
SelY1 := SelY;
SelY := Y;
end
else
SelY1 := Y;
Image1.Canvas.Pen.Mode := pmCopy;
SourceRect := Rect(SelX,SelY,SelX1,SelY1);
DestRect := Rect(0,0,SelX1-SelX,SelY1-SelY);
Image1.Canvas.CopyRect(DestRect,Image1.Canvas,SourceRect);
Image1.Picture.Bitmap.Height := SelY1-SelY;
Image1.Picture.Bitmap.Width := SelX1-SelX;
Image1.SetBounds(0,0,SelX1-SelX,SelY1-SelY);
DoSelect := false;
if FormIsFullScreen then
RestoreForm;
end;
end;
procedure Image1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if DoSelect then begin
SelX := X;
SelY := Y;
SelX1 := X;
SelY1 := Y;
with Image1.Canvas do
begin // Options shown in comments
Pen.Width := 1; // 2; // use with solid pen style
Pen.Style := psDashDotDot; // psSolid;
Pen.Mode := pmNotXOR; // pmXor;
Brush.Style := bsClear;
Pen.Color := clBlue; // clYellow;
end;
end;
end;
procedure Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
if DoSelect then begin
if ssLeft in Shift then
begin
Image1.Canvas.Rectangle(SelX,SelY,SelX1,SelY1);
SelX1 := X;
SelY1 := Y;
Image1.Canvas.Rectangle(SelX,SelY,SelX1,SelY1);
end;
end;
end;

Answer 3

first you need to have a Bitmap into memory(hidden) which you manipulate so the "flicker" effect won't appear. Second you need to apply some darken algorithm on the bitmap the you display and copy the selection from original Bitmap to the visible Bitmap.
In other words:
OffsetBitmap(original bitmap) copy to visible Bitmap.
when selection occurs:
apply darken effect to visible Bitmap
copy the selected rectangle from OFFSETBITMAP to the visible bitmap so you will have your selection with original light intensity.
Hope this helps to some degree -- implementing this takes a bit of time which I don't have right now.