قم بإنشاء أداة اختيار مرئية خاصة للصورة

Question

أرغب في إنشاء نوع خاص من التحديد ، حيث تظلم الصورة وجزءًا من المستخدم ، يتم عرض الصورة الحقيقية. يمكنك رؤية مثال:

لقد وجدت نهجين لتنفيذ هذا:

1. تنفيذ عنصر تحكم يظهر الصورة المظلمة. عندما يسحب المستخدم القطع الناقص عبر هذا التحكم ، نسخ القطع الناقص الصورة الحقيقية (الصورة غير المظلمة) في قماش التحكم. في هذا السيناريو عندما يحاول/هي تغيير حجم القطع الناقص إلى حجم أصغر ، أولاً ، فإن المنطقة المستطيلة بالكامل من القطع الناقص مظلمة ثم رسم صورة حقيقية في القطع الناقص الأصغر الجديدة.

2. مثل النهج 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');

Answer 1

حللت المشاكل. أجب على السؤال للسجل:

1- يجب أن يعود Wmerasebkgnd إلى منع خلفية الطلاء. لقد عدت عن طريق الخطأ خطأ.

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.

Answer 2

لقد فعلت بعض الشيء مماثل ... فيما يلي مقتطفات من الكود الخاص بي (صورة نقطية واحدة فقط في الذاكرة):

1. شاشة الاستيلاء ...

   اكتب 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;
   

2. طمس أن صورة نقطية بمجرد بدء الاختيار بواسطة الماوس لأسفل (رمز مقترح)

   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;
   

3. حدد المنطقة* على صورة نقطية غير واضحة على الشاشة (exemple :)

   الإجراءات grabselectedarea (المرسل: tobject) ؛ يبدأ

   Grab (image1.picture.bitmap ، gtscreen) ؛ BMP: = Image1.picture.bitmap ؛ Image1.width: = image1.picture.bitmap.width ؛ Image1.Height: = Image1.picture.bitmap.height ؛ doselect: = صحيح ؛ نهاية؛

4. القيام بذلك ، عكس (الإزاحة) تأثير طمس للمنطقة المحددة على صورة نقطية.

---

*هنا الرمز الذي لدي للاختيار

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

أولاً ، تحتاج إلى الحصول على صورة نقطية في الذاكرة (مخفية) والتي تتلاعب بها حتى لا يظهر تأثير "وميض". ثانياً ، تحتاج إلى تطبيق بعض الخوارزمية المظلمة على صورة نقطية تعرضها ونسخ التحديد من صورة نقطية أصلية إلى صورة نقطية مرئية.

بعبارات أخرى:

1. OffSetBitMap (صورة نقطية أصلية) إلى صورة نقطية مرئية.
2. عندما يحدث الاختيار:
   1. قم بتطبيق التأثير المظلم على صورة نقطية مرئية
   2. انسخ المستطيل المحدد من OffSetBitMap إلى صورة نقطية مرئية حتى تحصل على اختيارك بكثافة الضوء الأصلية.

آمل أن يساعد هذا إلى حد ما - تنفيذ هذا يستغرق بعض الوقت الذي لا أملكه الآن.