I'm trying to notice, when OneNote is opened or set to foreground. So I searched my old source files and found the DLLs for Hooks, which did their job on Win XP.
But awefully, they do not on windows 8. I do get Messages from my own Application including Buttons and Textfields, but no other Application triggers the callback function :-(
Running the Hook-starting Exe as Administrator, doesn't change the issue.
var
HookHandle: Cardinal = 0;
WindowHandle : Cardinal = 0;
function HookProc(nCode: Integer; wParam: WPARAM; lParam: LPARAM):
LRESULT; stdcall;
var s:PChar;
begin
Result := CallNextHookEx(HookHandle, nCode, wParam, lParam);
// debug if the callback function is triggerd...
SendMessage(WindowHandle,WM_USER+999,wParam,lParam);
case nCode < 0 of
TRUE: exit;
FALSE:
begin
if nCode=HSHELL_WINDOWCREATED then begin
SendMessage(WindowHandle,WM_USER+999,wParam,lParam);
GetMem(s,GetWindowTextLength(wParam)+2);
GetWindowText(wParam,s,GetWindowTextLength(wParam)+2);
//if (AnsiEndsStr('OneNote',s)) then begin
CallNextHookEx(HookHandle, nCode, wParam, lParam);
end;
end;
end;
end;
function InstallHook(Hwnd: Cardinal): Boolean; stdcall;
begin
Result := False;
if HookHandle = 0 then begin
HookHandle := SetWindowsHookEx(WH_SHELL, #HookProc, HInstance, 0);
WindowHandle := Hwnd;
Result := TRUE;
end;
end;
function UninstallHook: Boolean; stdcall;
begin
Result := UnhookWindowsHookEx(HookHandle);
HookHandle := 0;
end;
exports
InstallHook,
UninstallHook;
end.
Related
I'm wanting change a old code of keyboard hook for one better with support to unicode characters ( old code is ascii) and in this moment i have trouble to capture WM_KEYDOWN event.
My actual code is the following:
var
Form1: TForm1;
HookHandle: hHook;
ft: text;
implementation
{$R *.dfm}
function KBHookProc(Code: Integer; WParam: WParam; LParam: LParam)
: LRESULT; stdcall;
var
_Msg: TMessage;
VK: Integer;
SC: Integer;
buf: Char;
KS: TKeyboardState;
MyHKB: HKL;
begin
if Code = HC_ACTION then
begin
if _Msg.Msg = WM_KEYDOWN then
begin
VK := _Msg.WPARAM;
MyHKB := GetKeyboardLayout(_Msg.LParam);
SC := MapVirtualKeyEx(VK, MAPVK_VK_TO_VSC, MyHKB);
GetKeyboardState(KS);
ToUnicodeEx(VK, SC, KS, #buf, sizeof(buf), 0, MyHKB);
append(ft);
write(ft,buf);
closefile(ft);
MyHKB := 0;
end;
end;
Result := CallNextHookEx(HookHandle, Code, WParam, LParam);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
assignfile(ft,'log.txt');
rewrite(ft);
closefile(ft);
HookHandle := SetWindowsHookEx(WH_JOURNALRECORD , #KBHookProc, hinstance, 0);
end;
EDIT 1:
My code below is capturing WM_KEYDOWN with success, but nothing is written to file :-(.
Some suggestion?
var
Form1: TForm1;
HookHandle: hHook;
ft: text;
implementation
{$R *.dfm}
function LowLevelKeyboardProc(nCode: Integer; wParam: wParam;
lParam: lParam): LRESULT; stdcall;
var
_Msg: TMessage;
VK: Integer;
SC: Integer;
buf: Char;
KS: TKeyboardState;
MyHKB: HKL;
begin
if (nCode >= 0) and (wParam = WM_KEYDOWN) then
begin
VK := _Msg.WParam;
MyHKB := GetKeyboardLayout(_Msg.LParam);
SC := MapVirtualKeyEx(VK, MAPVK_VK_TO_VSC, MyHKB);
GetKeyboardState(KS);
ToUnicodeEx(VK, SC, KS, #buf, sizeof(buf), 0, MyHKB);
append(ft);
write(ft,buf);
closefile(ft);
MyHKB := 0;
end;
Result := CallNextHookEx(HookHandle, nCode, wParam, lParam);
end;
function InstallHook: Boolean;
begin
Result := False;
if HookHandle = 0 then
begin
HookHandle := SetWindowsHookEx(WH_KEYBOARD_LL, LowLevelKeyboardProc, 0, 0);
Result := HookHandle <> 0;
end;
end;
function UninstallHook: Boolean;
begin
Result := UnhookWindowsHookEx(HookHandle);
HookHandle := 0;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
assignfile(ft,'log.txt');
rewrite(ft);
closefile(ft);
InstallHook;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
UninstallHook;
end;
After a while crashes and I have to start the hook again
Function of KeyboardHook
function KeyboardHook(Code: Integer; wParam : WPARAM; lParam : LPARAM): LongInt;
var
Buffer: TEventMsg;
Key: Cardinal;
begin
if (wParam = $0101) and
(App.Inside) then
begin
Buffer := PEventMsg(lParam)^;
Key := Buffer.message;
if App.Inside then
begin
case Key of
VK_NEXT: App.Next;
VK_CAPITAL: App.Show;
end;
end;
end;
CallNextHookEx(Hook_ID_Keyboard, Code, wParam, lParam);
Result := 0;
end;
Function to start the Hook
function StartHookKeyboard: Boolean; stdcall;
begin
Hook_ID_Keyboard := SetWindowsHookEx(13, #KeyboardHook, HInstance, 0);
If Hook_ID_Keyboard = 0 then
Result := False else
Result := True;
end;
Is there any error in my code?
Don't use hard-coded magic numbers. In this context, 13 is WH_KEYBOARD_LL, $0101 is WM_KEYUP, etc. Use the actual names in your code. They are declared in the Windows and Messages units.
Did you declare KeyboardHook() to use the stdcall calling convention? The code you have shown is not doing so. This is very important so the parameter values are passed correctly on the call stack.
The lParam value of a WH_KEYBOARD_LL hook is NOT a PEventMsg (pointer to an EVENTMSG structure). That structure is used for WH_JOURNALPLAYBACK hooks. WH_KEYBOARD_LL uses the KBDLLHOOKSTRUCT structure instead. Delphi does not declare that particular structure, so you will have to declare it yourself in your code.
And don't ignore the callback's Code parameter, or the return value of CallNextHookEx(). They are important. The wParam and lParam values are only valid when the Code parameter is HC_ACTION (0). And the return value of CallNextHookEx() needs to be passed up the hook chain.
Try this instead:
type
PKBDLLHOOKSTRUCT = ^KBDLLHOOKSTRUCT;
KBDLLHOOKSTRUCT = record
vkCode: DWORD;
scanCode: DWORD;
flags: DWORD;
time: DWORD;
dwExtraInfo: ULONG_PTR;
end;
function KeyboardHook(Code: Integer; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
begin
if Code = HC_ACTION then
begin
if (wParam = WM_KEYUP) and (App.Inside) then
begin
case PKBDLLHOOKSTRUCT(lParam)^.vkCode of
VK_NEXT: App.Next;
VK_CAPITAL: App.Show;
end;
end;
end;
// note that CallNextHookEx() ignores the first parameter,
// so you could pass 0 instead of ID_Keyboard...
Result := CallNextHookEx(Hook_ID_Keyboard, Code, wParam, lParam);
end;
function StartHookKeyboard: Boolean; stdcall;
begin
if Hook_ID_Keyboard = 0 then
Hook_ID_Keyboard := SetWindowsHookEx(WH_KEYBOARD_LL, #KeyboardHook, HInstance, 0);
Result := Hook_ID_Keyboard <> 0;
end;
function StopHookKeyboard: Boolean; stdcall;
begin
if Hook_ID_Keyboard <> 0 then
begin
if UnhookWindowsHookEx(Hook_ID_Keyboard) then
Hook_ID_Keyboard := 0;
end;
Result := Hook_ID_Keyboard = 0;
end;
If the code is still crashing, it is likely related to App. What is App? Where and how is it declared? How is it initialized? What do Next() and Show() actually do? You are installing the hook globally to hook all running processes, so is App being used in a cross-process-safe manner?
Currently i check if a HWND is a console by EnumWindows and checking the ClassName.
function EnumWindows(AHandle: HWND; AParam: LPARAM): BOOL; stdcall;
var
classname: array[0.. 255] of Char;
begin
GetClassName(AHandle, classname, 255);
if classname = 'ConsoleWindowClass' then
begin
// do something
Result := False;
end
else
Result := True;
end;
I am wondering if there is a better way to accomplish something like this?
Would checking the Style (or/and ExStyle) be "better"?
You can use AttachConsole and FreeConsole do detect if other processes provide a console. One other thing to mind: there are processes with no console windows which allo AttachConsole - here GetConsoleWindow returns 0. There is a very good explanation of this behaviour in this github repository.
Declarations:
function AttachConsole(dwProcessID: Integer): Boolean; stdcall; external 'kernel32.dll';
function FreeConsole(): Boolean; stdcall; external 'kernel32.dll';
function GetConsoleWindow: HWND; stdcall; external kernel32;
Enumerate Processes:
procedure TForm2.FindConsoleWindows(AList: TListBox);
var
LProcHandle: THandle;
LResult, LNext: Boolean;
LProc: TProcessEntry32;
begin
aList.Items.Clear;
LProcHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
LResult := LProcHandle <> INVALID_HANDLE_VALUE;
if LResult then
try
LProc.dwSize := SizeOf(LProc);
LNext := Process32First(LProcHandle, LProc);
while LNext do begin
if AttachConsole(LProc.th32ProcessID) then
try
AList.Items.Add(IntToStr(LProc.th32ProcessID) + ' has a console ' + IntToStr(GetConsoleWindow()))
finally
FreeConsole();
end;
LNext := Process32Next(LProcHandle, LPRoc);
end;
finally
CloseHandle(LProcHandle);
end;
Credits:
JclSysInfo.pas to enumerate the processes
Im trying to use SetWindowsHookEx to Hook Mouse in some process. Im using Delphi 7.
Code (DLL):
function MouseProc(code: integer; wParam: WPARAM; lParam: LPARAM)
: LongInt; stdcall;
var
AppWnd: HWND;
begin
Result := 0;
if (code < 0) then
Result := CallNextHookEx(HookHandle, code, wParam, lParam)
else begin
AppWnd := FindWindowW('ichookapplication', nil);
SendMessage(AppWnd, MW_MOUSEHOOKED, wParam, GetCurrentProcessId);
Result := CallNextHookEx(HookHandle, code, wParam, lParam);
end;
end;
procedure HookThreadId(theadId: Cardinal) export; stdcall;
var
e: DWORD;
begin
HookHandle := SetWindowsHookEx(WH_MOUSE, #MouseProc, 0, theadId);
if (HookHandle = 0) then
begin
e := GetLastError;
MessageBox(0, 'error', PAnsiChar(IntToStr(e)), MB_OK);
end;
end;
MW_MOUSEHOOKED is WM_USER + 101;
application:
//loading code
if (dll = 0) then
begin
dll := LoadLibrary('mhook.dll');
#Hook := nil;
#SetThreadHook := nil;
end;
if (dll > HINSTANCE_ERROR) then
begin
pH := GetProcAddress(dll, 'Hook');
#Hook := pH;
pSth := GetProcAddress(dll, 'HookThreadId');
#SetThreadHook := pSth;
end;
// attach code
h := FindWindow(nil, 'Form1');
terminalProc := GetWindowThreadProcessId(h, nil);
if (terminalProc = 0) then
begin
ShowMessage(IntToStr(GetLastError));
Exit;
end;
SetThreadHook(terminalProc);
So. SetWindowsHookEx returns 1428 error: Cannot set nonlocal hook without a module handle.
But as i know if im using dll hmodule is not needed...
How i whant it will work:
Every mouse event will passing to my app (window class is 'ichookapplication') using WM_DATA (wParam is event data, lParam is ProcessId)
Thanks!
WH_MOUSE is a global hook. The DLL will be injected into hooked processes. You do need to supply a module handle. The name associated with error code 1428 is pretty clear, ERROR_HOOK_NEEDS_HMOD. It's not as though it's difficult to provide a module handle. Pass HInstance.
If you don't want to inject, then you'll need to use WH_MOUSE_LL instead of WH_MOUSE.
in this article delphi.net(prism) support async file io.
Delphi(Native/VCL) has Async File IO Class too?
Have you seen this code? http://pastebin.com/A2EERtyW
It is a good start for ansynchronous file I/O, but personally I would write a wrapper around the standard TStream class to maintain compatibility with VCL/RTL.
EDIT 2: This one looks good, too. http://www.torry.net/vcl/filedrv/other/dstreams.zip
I am posting it here just in case it disappears from Pastebin:
unit xfile;
{$I cubix.inc}
interface
uses
Windows,
Messages,
WinSock,
SysUtils,
Classes;
const
MAX_BUFFER = 1024 * 32;
type
TFileReadEvent = procedure(Sender: TObject; const Buffer; Count: Integer) of object;
TAsyncFile = class
private
FHandle: THandle;
FPosition: Cardinal;
FReadPending: Boolean;
FOverlapped: TOverlapped;
FBuffer: Pointer;
FBufferSize: Integer;
FOnRead: TFileReadEvent;
FEof: Boolean;
FSize: Integer;
function ProcessIo: Boolean;
procedure DoOnRead(Count: Integer);
function GetOpen: Boolean;
public
constructor Create(Filename: string; BufferSize: Integer = MAX_BUFFER);
destructor Destroy; override;
procedure BeginRead;
procedure Seek(Position: Integer);
procedure Close;
property OnRead: TFileReadEvent read FOnRead write FOnRead;
property Eof: Boolean read FEof;
property IsOpen: Boolean read GetOpen;
property Size: Integer read FSize;
end;
function ProcessFiles: Boolean;
implementation
var
Files: TList;
function ProcessFiles: Boolean;
var
i: Integer;
AsyncFile: TAsyncFile;
begin
Result := False;
for i := Files.Count - 1 downto 0 do
begin
AsyncFile := TAsyncFile(Files[i]);
Result := AsyncFile.ProcessIo or Result;
end;
end;
procedure Cleanup;
var
i: Integer;
AsyncFile: TAsyncFile;
begin
for i := Files.Count - 1 downto 0 do
begin
AsyncFile := TAsyncFile(Files[i]);
AsyncFile.Free;
end;
Files.Free;
end;
{ TAsyncFile }
constructor TAsyncFile.Create(Filename: string; BufferSize: Integer);
begin
Files.Add(Self);
FReadPending := False;
FBufferSize := BufferSize;
GetMem(FBuffer, FBufferSize);
FillMemory(#FOverlapped, SizeOf(FOverlapped), 0);
Cardinal(FHandle) := CreateFile(
PChar(Filename), // file to open
GENERIC_READ, // open for reading
0, // do not share
nil, // default security
OPEN_EXISTING, // open existing
FILE_ATTRIBUTE_NORMAL, //or // normal file
//FILE_FLAG_OVERLAPPED, // asynchronous I/O
0); // no attr. template
FSize := FileSeek(FHandle, 0, soFromEnd);
FileSeek(FHandle, 0, soFromBeginning);
FPosition := 0;
end;
destructor TAsyncFile.Destroy;
begin
Files.Remove(Self);
CloseHandle(FHandle);
FreeMem(FBuffer);
inherited;
end;
function TAsyncFile.ProcessIo: Boolean;
var
ReadCount: Cardinal;
begin
Result := False; Exit;
if not FReadPending then
begin
Exit;
end;
if GetOverlappedResult(FHandle, FOverlapped, ReadCount, False) then
begin
FReadPending := False;
DoOnRead(ReadCount);
end
else
begin
case GetLastError() of
ERROR_HANDLE_EOF:
begin
FReadPending := False;
FEof := True;
end;
ERROR_IO_PENDING:
begin
FReadPending := True;
end;
0:
begin
Result := True;
end;
end;
end;
end;
procedure TAsyncFile.BeginRead;
var
ReadResult: Boolean;
ReadCount: Cardinal;
begin
ReadCount := 0;
Seek(FPosition);
ReadResult := ReadFile(FHandle, FBuffer^, FBufferSize, ReadCount, nil);//#FOverlapped);
if ReadResult then
begin
FEof := False;
FReadPending := False;
FPosition := FPosition + ReadCount;
DoOnRead(ReadCount);
end
else
begin
case GetLastError() of
ERROR_HANDLE_EOF:
begin
FReadPending := False;
FEof := True;
end;
ERROR_IO_PENDING:
begin
FReadPending := True;
end;
end;
end;
end;
procedure TAsyncFile.DoOnRead(Count: Integer);
begin
if Assigned(FOnRead) then
begin
FOnRead(Self, FBuffer^, Count);
end;
end;
function TAsyncFile.GetOpen: Boolean;
begin
Result := Integer(FHandle) >= 0;
end;
procedure TAsyncFile.Close;
begin
FileClose(FHandle);
end;
procedure TAsyncFile.Seek(Position: Integer);
begin
FPosition := Position;
FileSeek(FHandle, Position, soFromBeginning);
end;
initialization
Files := Tlist.Create;
finalization
Cleanup;
end.
There is nothing built in to the RTL/VCL that offers asynchronous I/O for files. Incidentally the support in Delphi Prism is down to the .net framework rather than being language based.
You can either code directly against the Win32 API (that's not much fun) or hunt around for a Delphi wrapper to that API. Off the top of my head, I don't know any Delphi wrappers of asynchronous file I/O but they must exist.