5

マウスカーソルの下のピクセルカラーを本当に速く取得する方法はありますか？マウスフックがあり、マウスの移動中にピクセルの色を読み取ろうとしています。その種類の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.

UPDATE2-100ms間隔での1ユニットの更新

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.
4

1 に答える 1

5

私は個人的にこれにフックを使用しません。たとえば、間隔が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.
于 2013-03-04T00:18:33.220 に答える