Question

有没有办法让鼠标光标下的像素颜色真快？我有一个鼠标钩，我尝试在鼠标移动过程中读取像素颜色。它的ColorPicker

任何使用getPixel和BitBlt的尝试都非常慢。

更新 - 添加代码

unit Unit1;

{$mode delphi}{$H+}

interface

uses
  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, ExtCtrls, lclintf, Windows;

type

  { TForm1 }

  TForm1 = class(TForm)
    pnColor: TPanel;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure ms(var message: tmessage); message WM_USER+1234;
  private
    { private declarations }
  public
    { public declarations }
  end;

var
  Form1: TForm1;
  DC:HDC;

    const WH_MOUSE_LL = 14; //for Lazarus

implementation

{$R *.lfm}

{ TForm1 }

procedure HookMouse(Handle:HWND); stdcall; external 'mhook.dll';
procedure UnHookMouse; stdcall; external 'mhook.dll';

procedure TForm1.FormCreate(Sender: TObject);
begin
  //Self.Caption := IntToStr(Self.Height);
  Self.Left:= Screen.Monitors[0].WorkareaRect.Right  - Self.Width - 18;
  Self.Top := Screen.Monitors[0].WorkareaRect.Bottom - Self.Height - 18 - 25; //35 LAZARUS BUG

  DC := getDC(0);

  HookMouse(Self.Handle);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
    UnHookMouse;
end;

procedure TForm1.ms(var message: tmessage);
var color:TColor;
begin
  color := GetPixel(DC, message.WParam, message.LParam); //<-- Extremly slow
  //format('%d - %d',[message.LParam, message.WParam]); // Edited

  pnColor.Color:=color;
end;

end.

和DLL

library project1;

{$mode delphi}{$H+}

uses
  Windows,
  Messages;

var Hook: HHOOK;
    hParent:HWND;

function HookProc(nCode: Integer; MsgID: WParam; Data: LParam): LResult; stdcall;
var
  mousePoint: TPoint;
begin
  //if nCode = HC_ACTION then
  //begin
       mousePoint := PMouseHookStruct(Data)^.pt;
       PostMessage(hParent, WM_USER+1234, mousePoint.X, mousePoint.Y);
  //end;
  Result := CallNextHookEx(Hook,nCode,MsgID,Data);
end;

procedure HookMouse(Parent: Hwnd); stdcall;
begin
  hParent := parent;
  if Hook = 0 then Hook:=SetWindowsHookEx(WH_MOUSE_LL,@HookProc,HInstance,0); 
end;

procedure UnHookMouse; stdcall;
begin
  UnhookWindowsHookEx(Hook);
  Hook:=0;
end;

exports
  HookMouse, UnHookMouse;

begin

end.

更新2 - 一次更新，间隔为100毫秒

unit Unit1;

{$mode delphi}{$H+}

interface

uses
  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, ExtCtrls, lclintf, Windows;

type

  { TForm1 }

  TForm1 = class(TForm)
    pnColor: TPanel;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { private declarations }
  public
    { public declarations }
  end;

var
  Form1: TForm1;
  HookHandle: Cardinal;
  DC:HDC;
  timer:Long;

const WH_HOOK_LL = 14; //for Lazarus

implementation

{$R *.lfm}

{ TForm1 }

function LowLevelMouseProc(nCode: Integer; wParam: wParam; lParam: lParam): LRESULT; stdcall;
var
   point:TPoint;
begin
  if (nCode >= 0) then
  begin
    if(GetTickCount - timer >= 100) then
    begin
       point:=PMouseHookStruct(lParam)^.pt;
       Form1.pnColor.Color := GetPixel(DC,point.X,point.Y);
       timer := GetTickCount;
    end;
  end;
  Result := CallNextHookEx(HookHandle, nCode, wParam, lParam);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  //Self.Caption := IntToStr(Self.Height);
  Self.Left:= Screen.Monitors[0].WorkareaRect.Right  - Self.Width - 18;
  Self.Top := Screen.Monitors[0].WorkareaRect.Bottom - Self.Height - 18 - 25; //35 LAZARUS BUG

  DC :=  GetWindowDC(GetDesktopWindow);
  if HookHandle = 0 then
  begin
    HookHandle := SetWindowsHookEx(WH_HOOK_LL, @LowLevelMouseProc, hInstance, 0);
  end;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
    if HookHandle <> 0 then
    UnhookWindowsHookEx(HookHandle);

    ReleaseDC(GetDesktopWindow(), DC);
end;

end.

Answer 1

我个人不会为此使用钩子。我会用例如例如，间隔为30ms的计时器，并使用以下代码确定鼠标光标下当前像素的位置和颜色（该代码仅在Windows平台上可用，因为您的原始代码可以）。我会使用它，因为如果你的应用程序无法处理（低级别空闲优先级）WM_TIMER消息，我认为它不能处理你的钩子保持这么频繁的回调负责的用户界面（处理自己的主线程消息）：

unit Unit1;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, ExtCtrls,
  StdCtrls, Windows;

type

  { TForm1 }

  TForm1 = class(TForm)
    Label1: TLabel;
    Panel1: TPanel;
    UpdateTimer: TTimer;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure UpdateTimerTimer(Sender: TObject);
  private
    DesktopDC: HDC;
  public
    { public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.lfm}

{ TForm1 }

procedure TForm1.FormCreate(Sender: TObject);
begin
  DesktopDC := GetDC(0);
  if (DesktopDC <> 0) then
    UpdateTimer.Enabled := True;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  ReleaseDC(GetDesktopWindow, DesktopDC);
end;

procedure TForm1.UpdateTimerTimer(Sender: TObject);
var
  CursorPos: TPoint;
begin
  if GetCursorPos(CursorPos) then
  begin
    Label1.Caption := 'Cursor pos: [' + IntToStr(CursorPos.x) + '; ' +
      IntToStr(CursorPos.y) + ']';
    Panel1.Color := GetPixel(DesktopDC, CursorPos.x, CursorPos.y);
  end;
end;

end.

在鼠标光标下获取像素颜色 - 快速方式

1 个答案: