Create a special visual selection tool for Image

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:

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');

bman · Accepted Answer

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.

Create a special visual selection tool for Image

Tags:

winapi

delphi

gdi

window-management

bman

1 Answers

bman

Recent Activity

Donate For Us

Create a special visual selection tool for Image

Tags:

winapi

delphi

gdi

window-management

bman

1 Answers

bman

Related questions

Recent Activity

Donate For Us