为图像创建一个特殊的视觉选择工具

发布于 2024-10-01 11:25:19 字数 5877 浏览 5 评论 0原文

我想创建一种特殊类型的选择，其中图像变暗，并且在用户选择的部分中显示真实图像。您可以看到一个示例：

Example

我发现了两种实现此目的的方法：

实现显示变暗图像的控件。当用户将椭圆拖动到此控件上时，椭圆会将真实图像（未变暗的图像）复制到控件画布中。在这种情况下，当他/她尝试将椭圆调整为较小尺寸时，首先椭圆的整个矩形区域变暗，然后在新的较小椭圆中绘制真实图像。
与方法 1 相同，但我们不是在控件的画布上绘图，而是创建一个显示真实图像的新控件。在这种情况下，所有发送到新控件的消息都应该传递到父控件。因为如果用户尝试将椭圆调整为较小的尺寸，WM_MOVE 消息将发送到此控件，而不是父控件。

请有人告诉我实施此操作的正确方向。我认为方法 1 很难实现，因为它会导致很多闪烁。除非我实现一种仅通过 InvalidateRect 函数重新绘制更改部分的方法。

这是我迄今为止实现的 TScreenEmul 类的代码。它可以工作，但有闪烁。

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.

对于使用此类：

var
  ScreenEmul: TScreenEmul;
begin
  ScreenEmul := TScreenEmul.Create(Self);
  ScreenEmul.Parent := Self;
  ScreenEmul.Align := alClient;
  ScreenEmul.Bitmap.LoadFromFile('C:\img13.bmp');

原文

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

分享到QQ

分享到微博

如果你对这篇内容有疑问，欢迎到本站社区发帖提问参与讨论，获取更多帮助，或者扫码二维码加入 Web 技术交流群。

发布评论

需要登录才能够评论，你可以免费注册一个本站的账号。

七色彩虹 2024-10-08 11:25:19

我解决了这个问题。我回答记录的问题：

1- WMEraseBkgnd 应该返回 True 以防止绘制背景。我错误地返回了False。

2-我继承了WMPaint方法，这是不正确的。我还将更新的矩形复制到新的位图中，然后将位图绘制到画布中，这会减慢绘制过程。这是完整的固定源代码：

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.

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.

回复收藏 0 原文

木落 2024-10-08 11:25:19

我做了一些类似的事情...以下是我的代码摘录（内存中只有一个位图）：

抓取屏幕...

类型
抓取屏幕 = (GTSCREEN);
[...]

过程 PGrabScreen(bm: TBitMap; gt : GrabScreen);
变量
  目标矩形、源矩形：TRect；
  h: T句柄；
  hdcSrc : T句柄；
  pt：T点；
开始
  案例(gt)
   //...  
    GTSCREEN : h := GetDesktopWindow;
  结尾;
  如果h＜＞那么 0
  开始
    尝试
      开始
          hdcSrc := GetWindowDC(h);
          GetWindowRect(h, SourceRect);
      结尾;
        bm.Width := SourceRect.Right - SourceRect.Left;
        bm.Height := SourceRect.Bottom - SourceRect.Top;
        目标矩形 := 矩形(0, 0, SourceRect.Right - SourceRect.Left, SourceRect.Bottom - SourceRect.Top);
          StretchBlt(bm.Canvas.Handle, 0, 0, bm.Width,
            bm.高度，hdcSrc，
            0,0,SourceRect.Right - SourceRect.Left,
            SourceRect.Bottom - SourceRect.Top，
            SRC复制）；
          DrawCursor(bm,SourceRect.Left, SourceRect.Top);
    最后
      ReleaseDC(0, hdcSrc);
    结尾;
  结尾;
结尾;

通过鼠标按下启动选择后模糊该位图（建议代码）

procedure BitmapBlur(var theBitmap: TBitmap);
变量
  x、y：整数；
  y线，
  xLine：PByteArray；
开始
  对于 y := 1 到 theBitmap.Height -2 开始
    yLine := theBitmap.ScanLine[y -1];
    xLine := theBitmap.ScanLine[y];
    对于 x := 1 到 theBitmap.Width -2 开始
      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;
    结尾;
  结尾;
结尾;

在屏幕上的模糊位图上选择区域*（例如：）
过程 GrabSelectedArea(Sender: TObject);
开始
抓取(image1.Picture.Bitmap, GTSCREEN);
bmp := Image1.Picture.Bitmap;
image1.Width := image1.Picture.Bitmap.Width;
image1.Height := image1.Picture.Bitmap.Height;
DoSelect := true;
end;
这样做可以反转（偏移）位图上选定区域的模糊效果。

*这是我可供选择的代码

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;

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;

回复收藏 0 原文