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.
Related
I am writing a Keyboard application that hooks the keyboard and remaps the keys. For this, I have created two projects, one .exe and .dll. In the .dll project, I detect the Handle of the Window in which the user is typing by GetFocus(). However, it works fine in notepad, but not in MS Word since I am not able to get the Window's Handle for the MS Word, using GetFocus()
I understand, that is because it might be running under different thread and hence, I need to get the Parent Window Handle by GetForegroundWindow() and iterate through its child windows and somehow get the right Handle.
While searching on internet I found following code (http://www.codeproject.com/Articles/34752/Control-in-Focus-in-Other-Processes)
activeWindowHandle:= GetForegroundWindow();
activeWindowThread:= GetWindowThreadProcessId(activeWindowHandle, 0);
thisWindowThread:= GetWindowThreadProcessId(lpHookRec^.TheHookHandle, 0);
AttachThreadInput(activeWindowThread, thisWindowThread, true);
lpHookRec^.TheAppWinHandle:= GetFocus();
AttachThreadInput(activeWindowThread, thisWindowThread, false);
However, it is not working for me :(
In my code I have written
lpHookRec^.TheAppWinHandle := GetFocus();
and that gives me the Handle of the NotePad window in lpHookRec^.TheAppWinHandle. However, if I use MS Word instead of NotePad, the above code gives me null(zero). So need to write function that returns the correct Handle, irrespective of thread it is running under, something like
function GetAppliWinHandle: Hwnd;
var
activeWindowHandle,activeWindowThread,thisWindowThread,focusedControlHandle: Hwnd;
begin { GetAppliWinHandle }
focusedControlHandle := GetFocus();
if focusedControlHandle = 0 then
begin
activeWindowHandle := GetForegroundWindow();
activeWindowThread := GetWindowThreadProcessId(activeWindowHandle, 0);
thisWindowThread := GetWindowThreadProcessId(lpHookRec^.TheHookHandle, 0);
AttachThreadInput(activeWindowThread, thisWindowThread, true);
focusedControlHandle := GetFocus();
AttachThreadInput(activeWindowThread, thisWindowThread, false);
end;
Result:=focusedControlHandle
end; { GetAppliWinHandle }
and here is the complete code for the dll
library TheHook;
uses
Windows, Messages, SysUtils;
{Define a record for recording and passing information process wide}
type
PHookRec = ^THookRec;
THookRec = packed record
TheHookHandle: HHOOK;
TheAppWinHandle: HWND;
TheCtrlWinHandle: HWND;
TheKeyCount: DWORD;
end;
var
hObjHandle: THandle; {Variable for the file mapping object}
lpHookRec: PHookRec; {Pointer to our hook record}
procedure MapFileMemory(dwAllocSize: DWORD);
begin
{Create a process wide memory mapped variable}
hObjHandle := CreateFileMapping($FFFFFFFF, nil, PAGE_READWRITE, 0, dwAllocSize,
'HookRecMemBlock');
if (hObjHandle = 0) then
begin
MessageBox(0, 'Hook DLL', 'Could not create file map object', MB_OK);
exit;
end;
{Get a pointer to our process wide memory mapped variable}
lpHookRec := MapViewOfFile(hObjHandle, file_MAP_write, 0, 0, dwAllocSize);
if (lpHookRec = nil) then
begin
CloseHandle(hObjHandle);
MessageBox(0, 'Hook DLL', 'Could not map file', MB_OK);
exit;
end;
end;
procedure UnMapFileMemory;
begin
{Delete our process wide memory mapped variable}
if (lpHookRec <> nil) then
begin
UnMapViewOfFile(lpHookRec);
lpHookRec := nil;
end;
if (hObjHandle > 0) then
begin
CloseHandle(hObjHandle);
hObjHandle := 0;
end;
end;
function GetHookRecPointer: pointer stdcall;
begin
{Return a pointer to our process wide memory mapped variable}
result := lpHookRec;
end;
{The function that actually processes the keystrokes for our hook}
function KeyBoardProc(Code: integer; wParam: integer; lParam: integer): integer;
stdcall;
function GetAppliWinHandle: Hwnd;
var
activeWindowHandle,activeWindowThread,thisWindowThread,focusedControlHandle: Hwnd;
begin { GetAppliWinHandle }
focusedControlHandle := GetFocus();
if focusedControlHandle = 0 then
begin
activeWindowHandle := GetForegroundWindow();
activeWindowThread := GetWindowThreadProcessId(activeWindowHandle, 0);
thisWindowThread := GetWindowThreadProcessId(lpHookRec^.TheHookHandle, 0);
AttachThreadInput(activeWindowThread, thisWindowThread, true);
focusedControlHandle := GetFocus();
AttachThreadInput(activeWindowThread, thisWindowThread, false);
end;
Result:=focusedControlHandle
end; { GetAppliWinHandle }
var
KeyUp: bool;
{Remove comments for additional functionability ... :
IsAltPressed: bool;
IsCtrlPressed: bool;
IsShiftPressed: bool;
}
begin
result := 0;
case Code of
HC_ACTION:
begin
{We trap the keystrokes here}
{is this a key up message?}
KeyUp := ((lParam and (1 shl 31)) <> 0);
{Remove comments for additional functionability ... :
{is the Alt key pressed}
if ((lParam and (1 shl 29)) <> 0) then
begin
IsAltPressed := TRUE;
end
else
begin
IsAltPressed := FALSE;
end;
{is the Control key pressed}
if ((GetKeyState(VK_CONTROL) and (1 shl 15)) <> 0) then
begin
IsCtrlPressed := TRUE;
end
else
begin
IsCtrlPressed := FALSE;
end;
{if the Shift key pressed}
if ((GetKeyState(VK_SHIFT) and (1 shl 15)) <> 0) then
begin
IsShiftPressed := TRUE;
end
else
begin
IsShiftPressed := FALSE;
end;
}
{if KeyUp then increment the key count}
if (KeyUp <> FALSE) then
begin
Inc(lpHookRec^.TheKeyCount);
end;
case wParam of
{Was the enter key pressed?}
VK_RETURN:
begin
{if KeyUp}
if (KeyUp <> FALSE) then
begin
{Post a bogus message to the window control in our app}
PostMessage(lpHookRec^.TheCtrlWinHandle, WM_KEYDOWN, 0, 0);
PostMessage(lpHookRec^.TheCtrlWinHandle, WM_KEYUP, 0, 0);
end;
{if you wanted to swallow the keystroke then return -1, else if you
want
to allow the keystroke then return 0}
result := 0;
exit;
end; {VK_RETURN}
{if the left arrow key is pressed then lets play a joke!}
VK_LEFT:
begin
{Get the Handle of the Application Window in lpHookRec^.TheAppWinHandle}
lpHookRec^.TheAppWinHandle:=GetAppliWinHandle;
{if KeyUp}
if (KeyUp <> FALSE) then
begin
{Create a UpArrow keyboard event}
keybd_event(VK_RIGHT, 0, 0, 0);
keybd_event(VK_RIGHT, 0, KEYEVENTF_KEYUP, 0);
end;
{Swallow the keystroke}
result := -1;
exit;
end; {VK_LEFT}
end; {case wParam}
{Allow the keystroke}
result := 0;
end; {HC_ACTION}
HC_NOREMOVE:
begin
{This is a keystroke message, but the keystroke message has not been removed
from the message queue, since an application has called PeekMessage()
specifying PM_NOREMOVE}
result := 0;
exit;
end;
end; {case code}
if (Code < 0) then
{Call the next hook in the hook chain}
result := CallNextHookEx(lpHookRec^.TheHookHandle, Code, wParam, lParam);
end;
procedure StartKeyBoardHook stdcall;
begin
{if we have a process wide memory variable and the hook has not already been
set...}
if ((lpHookRec <> nil) and (lpHookRec^.TheHookHandle = 0)) then
begin
{set the hook and remember our hook handle}
lpHookRec^.TheHookHandle := SetWindowsHookEx(WH_KEYBOARD, #KeyBoardProc,
hInstance, 0);
end;
end;
procedure StopKeyBoardHook stdcall;
begin
{if we have a process wide memory variable and the hook has already been set...}
if ((lpHookRec <> nil) and (lpHookRec^.TheHookHandle <> 0)) then
begin
{Remove our hook and clear our hook handle}
if (UnHookWindowsHookEx(lpHookRec^.TheHookHandle) <> FALSE) then
begin
lpHookRec^.TheHookHandle := 0;
end;
end;
end;
procedure DllEntryPoint(dwReason: DWORD);
begin
case dwReason of
Dll_Process_Attach:
begin
{if we are getting mapped into a process, then get a pointer to our
process wide memory mapped variable}
hObjHandle := 0;
lpHookRec := nil;
MapFileMemory(sizeof(lpHookRec^));
end;
Dll_Process_Detach:
begin
{if we are getting unmapped from a process then, remove the pointer to
our process wide memory mapped variable}
UnMapFileMemory;
end;
end;
end;
exports
KeyBoardProc name 'KEYBOARDPROC',
GetHookRecPointer name 'GETHOOKRECPOINTER',
StartKeyBoardHook name 'STARTKEYBOARDHOOK',
StopKeyBoardHook name 'STOPKEYBOARDHOOK';
begin
{set our Dll's main entry point}
DLLProc := #DllEntryPoint;
{Call our Dll's main entry point}
DllEntryPoint(Dll_Process_Attach);
end.
Per the GetFocus() documentation:
Retrieves the handle to the window that has the keyboard focus, if the window is attached to the calling thread's message queue.
...
GetFocus returns the window with the keyboard focus for the current thread's message queue. If GetFocus returns NULL, another thread's queue may be attached to a window that has the keyboard focus.
Use the GetForegroundWindow function to retrieve the handle to the window with which the user is currently working. You can associate your thread's message queue with the windows owned by another thread by using the AttachThreadInput function.
You are trying to do this part, but you are not doing it correctly, and you are not checking for errors along the way. You are also mistakenly using the HWND data type for thread IDs, but they are not HWNDs, they are DWORDs instead.
Try something more like this:
function GetAppliWinHandle: HWND;
var
activeWindowHandle: HWND;
activeWindowThread, thisThread: DWORD;
begin
Result := GetFocus();
if Result = 0 then
begin
activeWindowHandle := GetForegroundWindow();
if activeWindowHandle <> 0 then
begin
activeWindowThread := GetWindowThreadProcessId(activeWindowHandle, 0);
thisThread := GetCurrentThreadId();
if AttachThreadInput(activeWindowThread, thisThread, TRUE) then
begin
Result := GetFocus();
AttachThreadInput(activeWindowThread, thisThread, FALSE);
end;
end;
end;
end;
However, the same documentation also says:
To get the window with the keyboard focus on the foreground queue or the queue of another thread, use the GetGUIThreadInfo function.
For example:
function GetAppliWinHandle: HWND;
var
activeWindowHandle: HWND;
activeWindowThread: DWORD;
gui: TGUIThreadinfo;
begin
Result := GetFocus();
if Result = 0 then
begin
activeWindowHandle := GetForegroundWindow();
if activeWindowHandle <> 0 then
begin
activeWindowThread := GetWindowThreadProcessId(activeWindowHandle, 0);
gui.cbSize := sizeof(gui);
if GetGUIThreadInfo(activeWindowThread, gui) then
Result := gui.hwndFocus;
end;
end;
end;
Or simpler:
function GetAppliWinHandle: HWND;
var
gui: TGUIThreadinfo;
begin
gui.cbSize := sizeof(gui);
if GetGUIThreadInfo(0, gui) then
Result := gui.hwndFocus
else
Result := 0;
end;
I want my delphi application to be able to know which control currently has keyboard focus, system wide (in different processes).
To achieve this, I use a global CBT hook to get all of the setfocus messages. Every focus change triggers my application to check the type of the focused control by using UIAutomation framework.
This works e.g. for my own delphi applications or in the delphi IDE, but if I focus edit boxes in chrome browser, I will only get the window and not the focused control. Changing focus inside of chrome window has no effect. There's no setfocus message sent anymore.
Furthermore, focusing e.g. the edit box in the start menu of windows or elements in the explorer won't return anything.
As far as I know, those actions should also cause a setfocus message, so I think that maybe not every process is hooked properly.
Below is the code of my hook DLL, I don't know what I am doing wrong...
const
WM_MYFOCUSCHANGED = WM_USER + 1;
type
PHookRec = ^THookRec;
THookRec = packed Record
HookHandle: hhook;
WindowHandle: hwnd;
End;
var
MapHandle: THandle; // file mapping object
ipHookRec: PHookRec; // Pointer to hook record
{$R *.res}
procedure MapFileMemory(dwAllocSize: DWORD);
begin
{Create a process wide memory mapped variable}
MapHandle := CreateFileMapping($FFFFFFFF, nil, PAGE_READWRITE, 0, dwAllocSize, 'HookRecMemBlock');
if (MapHandle = 0) then
begin
MessageBox(0, 'Hook DLL', 'Could not create file map object', MB_OK);
exit;
end;
{Get a pointer to our process wide memory mapped variable}
ipHookRec := MapViewOfFile(MapHandle, FILE_MAP_WRITE, 0, 0, dwAllocSize);
if (ipHookRec = nil) then
begin
CloseHandle(MapHandle);
MessageBox(0, 'Hook DLL', 'Could not map file', MB_OK);
exit;
end;
end;
procedure UnMapFileMemory;
begin
{Delete our process wide memory mapped variable}
if (ipHookRec <> nil) then
begin
UnMapViewOfFile(ipHookRec);
ipHookRec := nil;
end;
if (MapHandle > 0) then
begin
CloseHandle(MapHandle);
MapHandle := 0;
end;
end;
function GetHookRecPointer: pointer stdcall;
begin
{Return a pointer to our process wide memory mapped variable}
result := ipHookRec;
end;
function FocusHookProc(code: integer; wParam: wParam; lParam: lParam): LResult; stdcall;
begin
if (code < 0) then
begin
result := CallNextHookEx(ipHookRec^.HookHandle, code, wParam, lParam);
exit;
end;
result := 0;
if (code = WM_SETFOCUS) then
begin
if (ipHookRec^.WindowHandle <> INVALID_HANDLE_VALUE) then
PostMessage(ipHookRec^.WindowHandle, WM_MYFOCUSCHANGED, wParam, lParam);
// wParam: Handle to the window gaining keyboard focus
end;
end;
procedure InstallHook(Hwnd: Cardinal); stdcall;
begin
if ((ipHookRec <> nil) and (ipHookRec^.HookHandle = 0) and (ipHookRec^.WindowHandle = 0)) then
begin
ipHookRec^.WindowHandle := Hwnd; // handle to the application window
ipHookRec^.HookHandle := SetWindowsHookEx(WH_CBT, #FocusHookProc, Hinstance, 0);
end;
end;
procedure UninstallHook; stdcall;
begin
if ((ipHookRec <> nil) and (ipHookRec^.HookHandle <> 0)) then
begin
{Remove our hook and clear our hook handle}
if (UnHookWindowsHookEx(ipHookRec^.HookHandle) <> FALSE) then
begin
ipHookRec^.HookHandle := 0;
ipHookRec^.WindowHandle := 0;
end;
end;
end;
procedure DllEntryPoint(dwReason: DWORD);
begin
case dwReason of
Dll_Process_Attach:
begin
{If we are getting mapped into a process, then get a pointer to our
process wide memory mapped variable}
MapHandle := 0;
ipHookRec := nil;
MapFileMemory(sizeof(ipHookRec^));
end;
Dll_Process_Detach:
begin
{If we are getting unmapped from a process then, remove the pointer to
our process wide memory mapped variable}
UnMapFileMemory;
end;
end;
end;
exports
InstallHook name 'INSTALLHOOK',
UninstallHook name 'UNINSTALLHOOK',
GetHookRecPointer name 'GETHOOKRECPOINTER';
begin
DLLProc := #DllEntryPoint; // set DLL main entry point
DllEntryPoint(Dll_Process_Attach); // call DLL main entry point
end.
I have a server written in Delphi that I would like to add a debug logger to so it can log messages passed to Windows.OutputDebugString() while it is deployed, so clients can send me the log when there are issues. In the end, I want functionality similar to DebugView, but built into the server program itself.
I understand how the OutputDebugString works by writing to a shared memory file and using system wide events to synchronize the program and its debugger, and I have found solutions in C# and C++, but have yet to be able to translate those solutions to Delphi.
My largest problem is not knowing how to interact with the DBWIN_BUFFER_READY and DBWIN_DATA_READY synchronization events with Delphi, or how to reference the specific memory mapped file "DBWIN_BUFFER" that OutputDebugString writes to.
Additionally I have found solutions that implement their own method call instead of Windows.OutputDebugString(), but the program already has hundreds of calls, both in the code we have written and third-party modules we have added in, so these are not an option.
The C++ code you linked to can be translated to Delphi as follows:
//////////////////////////////////////////////////////////////
//
// File: WinDebugMonitor.pas
// Description: Interface of class TWinDebugMonitor
// Created: 2007-12-6
// Author: Ken Zhang
// E-Mail: cpp.china#hotmail.com
//
// Translated: 2015-02-13
// Translator: Remy Lebeau
// E-Mail: remy#lebeausoftware.org
//
//////////////////////////////////////////////////////////////
unit WinDebugMonitor;
interface
uses
Windows;
type
PDbWinBuffer = ^DbWinBuffer;
DbWinBuffer = record
dwProcessId: DWORD;
data: array[0..(4096-sizeof(DWORD))-1] of AnsiChar;
end;
TWinDebugMonitor = class
private
m_hDBWinMutex: THandle;
m_hDBMonBuffer: THandle;
m_hEventBufferReady: THandle;
m_hEventDataReady: THandle;
m_hWinDebugMonitorThread: THandle;
m_bWinDebugMonStopped: Boolean;
m_pDBBuffer: PDbWinBuffer;
function Initialize: DWORD;
procedure Uninitialize;
function WinDebugMonitorProcess: DWORD;
public
constructor Create;
destructor Destroy; override;
procedure OutputWinDebugString(const str: PAnsiChar); virtual;
end;
implementation
// ----------------------------------------------------------------------------
// PROPERTIES OF OBJECTS
// ----------------------------------------------------------------------------
// NAME | DBWinMutex DBWIN_BUFFER_READY DBWIN_DATA_READY
// ----------------------------------------------------------------------------
// TYPE | Mutex Event Event
// ACCESS | All All Sync
// INIT STATE | ? Signaled Nonsignaled
// PROPERTY | ? Auto-Reset Auto-Reset
// ----------------------------------------------------------------------------
constructor TWinDebugMonitor.Create;
begin
inherited;
if Initialize() <> 0 then begin
OutputDebugString('TWinDebugMonitor.Initialize failed.'#10);
end;
end;
destructor TWinDebugMonitor.Destroy;
begin
Uninitialize;
inherited;
end;
procedure TWinDebugMonitor.OutputWinDebugString(const str: PAnsiChar);
begin
end;
function WinDebugMonitorThread(pData: Pointer): DWORD; stdcall;
var
_Self: TWinDebugMonitor;
begin
_Self = TWinDebugMonitor(pData);
if _Self <> nil then begin
while not _Self.m_bWinDebugMonStopped do begin
_Self.WinDebugMonitorProcess;
end;
end;
Result := 0;
end;
function TWinDebugMonitor.Initialize: DWORD;
begin
SetLastError(0);
// Mutex: DBWin
// ---------------------------------------------------------
m_hDBWinMutex := OpenMutex(MUTEX_ALL_ACCESS, FALSE, 'DBWinMutex');
if m_hDBWinMutex = 0 then begin
Result := GetLastError;
Exit;
end;
// Event: buffer ready
// ---------------------------------------------------------
m_hEventBufferReady := OpenEvent(EVENT_ALL_ACCESS, FALSE, 'DBWIN_BUFFER_READY');
if m_hEventBufferReady = 0 then begin
m_hEventBufferReady = CreateEvent(nil, FALSE, TRUE, 'DBWIN_BUFFER_READY');
if m_hEventBufferReady = 0 then begin
Result := GetLastError;
Exit;
end;
end;
// Event: data ready
// ---------------------------------------------------------
m_hEventDataReady := OpenEvent(SYNCHRONIZE, FALSE, 'DBWIN_DATA_READY');
if m_hEventDataReady = 0 then begin
m_hEventDataReady := CreateEvent(nil, FALSE, FALSE, 'DBWIN_DATA_READY');
if m_hEventDataReady = 0 then begin
Result := GetLastError;
end;
end;
// Shared memory
// ---------------------------------------------------------
m_hDBMonBuffer := OpenFileMapping(FILE_MAP_READ, FALSE, 'DBWIN_BUFFER');
if m_hDBMonBuffer = 0 then begin
begin
m_hDBMonBuffer := CreateFileMapping(INVALID_HANDLE_VALUE, nil, PAGE_READWRITE, 0, SizeOf(DbWinBuffer), 'DBWIN_BUFFER');
if m_hDBMonBuffer = 0 then begin
Result := GetLastError;
Exit;
end;
end;
m_pDBBuffer := PDbWinBuffer(MapViewOfFile(m_hDBMonBuffer, SECTION_MAP_READ, 0, 0, 0));
if m_pDBBuffer = nil then begin
Result := GetLastError;
Exit;
end;
// Monitoring thread
// ---------------------------------------------------------
m_bWinDebugMonStopped := False;
m_hWinDebugMonitorThread := CreateThread(nil, 0, #WinDebugMonitorThread, Self, 0, nil);
if m_hWinDebugMonitorThread = 0 then begin
m_bWinDebugMonStopped := True;
Result := GetLastError;
Exit;
end;
// set monitor thread's priority to highest
// ---------------------------------------------------------
SetPriorityClass(GetCurrentProcess(), REALTIME_PRIORITY_CLASS);
SetThreadPriority(m_hWinDebugMonitorThread, THREAD_PRIORITY_TIME_CRITICAL);
Result := 0;
end;
procedure TWinDebugMonitor.Uninitialize;
begin
if m_hWinDebugMonitorThread <> 0 then begin
m_bWinDebugMonStopped := True;
WaitForSingleObject(m_hWinDebugMonitorThread, INFINITE);
CloseHandle(m_hWinDebugMonitorThread);
m_hWinDebugMonitorThread := 0;
end;
if m_hDBWinMutex <> 0 then begin
CloseHandle(m_hDBWinMutex);
m_hDBWinMutex := 0;
end;
if m_pDBBuffer <> nil then begin
UnmapViewOfFile(m_pDBBuffer);
m_pDBBuffer := nil;
end;
if m_hDBMonBuffer <> 0 then begin
CloseHandle(m_hDBMonBuffer);
m_hDBMonBuffer := 0;
end;
if m_hEventBufferReady <> 0 then begin
CloseHandle(m_hEventBufferReady);
m_hEventBufferReady := 0;
end;
if m_hEventDataReady <> 0 then begin
CloseHandle(m_hEventDataReady);
m_hEventDataReady := 0;
end;
end;
function TCWinDebugMonitor.WinDebugMonitorProcess: DWORD;
const
TIMEOUT_WIN_DEBUG = 100;
begin
// wait for data ready
Result := WaitForSingleObject(m_hEventDataReady, TIMEOUT_WIN_DEBUG);
if Result = WAIT_OBJECT_0 then begin
OutputWinDebugString(m_pDBBuffer^.data);
// signal buffer ready
SetEvent(m_hEventBufferReady);
end;
end;
program Monitor;
{$APPTYPE CONSOLE}
{$R *.res}
uses
WinDebugMonitor;
type
Monitor = class(TWinDebugMonitor)
public
procedure OutputWinDebugString(const str: PAnsiChar); override;
end;
procedure Monitor.OutputWinDebugString(const str: PAnsiChar);
begin
Write(str);
end;
var
mon: Monitor;
begin
WriteLn('Win Debug Monitor Tool');
WriteLn('----------------------');
mon := Monitor.Create;
try
ReadLn;
finally
mon.Free;
end;
end.
program Output;
{$APPTYPE CONSOLE}
{$R *.res}
uses
SysUtils, Windows, Messages;
var
hConsoleInput: THandle;
function KeyPressed: boolean;
var
NumberOfEvents: Integer;
begin
GetNumberOfConsoleInputEvents(hConsoleInput, NumberOfEvents);
Result := NumberOfEvents > 0;
end;
procedure KeyInit;
var
mode: Integer;
begin
// get input file handle
Reset(Input);
hConsoleInput := TTextRec(Input).Handle;
// checks/sets so mouse input does not work
SetActiveWindow(0);
GetConsoleMode(hConsoleInput, mode);
if (mode and ENABLE_MOUSE_INPUT) = ENABLE_MOUSE_INPUT then
SetConsoleMode(hConsoleInput, mode xor ENABLE_MOUSE_INPUT);
end;
var
i: Integer;
buf: AnsiString;
begin
KeyInit;
WriteLn('Press any key to stop calling OutputDebugString......');
i := 0;
while not KeyPressed do
begin
Inc(i);
buf := Format('Message from process %d, msg id: %d'#10, [ GetCurrentProcessId(), I]);
OutputDebugStringA(PAnsiChar(buf));
end;
Writeln('Total ', i, ' messages sent.');
end.
Your solution is wrong.
Hint: This function is listed under functions for debugging, and it has "Debug" in its name.
Imagine what if two programs did this. OutputDebugString is a global function. It sends a string from ANY process to the debugger. If two programs would use OutputDebugString as their logging solution - you will get a mess from simultaneous output from two processes, and each log will be mixed with other.
Quote from MSDN (as additional proof that your solution is wrong):
Applications should send very minimal debug output and provide a way for the user to enable or disable its use. To provide more detailed tracing, see Event Tracing.
In other words, OutputDebugString is a debugging solution for development builds; it is not a logging system.
Use this (pseudo-code to illustrate the idea):
unit DebugTools;
interface
procedure OutputDebugString(const AStr: String);
implementation
procedure OutputDebugString(const AStr: String);
begin
if IsDebuggerPresent then
Windows.OutputDebugString(PChar(AStr))
else
begin
CritSect.Enter;
try
GlobalLog.Add(AStr);
finally
CritSect.Leave;
end;
end;
end;
end.
Just add this unit to the uses clause for each of your other units - and you will automatically capture "output OutputDebugString" without need to change source code.
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.
I am trying to register an Active X .ocx Library in a Delphi program i have tried the following code with out success no errors and the program runs through all of the code but when it has finished the Active X Library hasn't been registered. What am i doing wrong ?
procedure RegisterOCX;
type
TRegFunc = function : HResult; stdcall;
var
ARegFunc : TRegFunc;
aHandle : THandle;
ocxPath,AppPath : string;
begin
GetDir(0, AppPath);
try
ocxPath := AppPath + '\VOIP.ocx';
aHandle := LoadLibrary(PChar(ocxPath));
if aHandle <> 0 then
begin
ARegFunc := GetProcAddress(aHandle,'DllRegisterServer');
if Assigned(ARegFunc) then
begin
ExecAndWait('regsvr32','/s ' + ocxPath);
end;
FreeLibrary(aHandle);
end;
except
ShowMessage('Unable to register ');
end;
end;
function ExecAndWait(const ExecuteFile, ParamString : string): boolean;
var
SEInfo: TShellExecuteInfo;
ExitCode: DWORD;
begin
FillChar(SEInfo, SizeOf(SEInfo), 0);
SEInfo.cbSize := SizeOf(TShellExecuteInfo);
with SEInfo do begin
fMask := SEE_MASK_NOCLOSEPROCESS;
Wnd := Application.Handle;
lpFile := PChar(ExecuteFile);
lpParameters := PChar(ParamString);
nShow := SW_HIDE;
end;
if ShellExecuteEx(#SEInfo) then
begin
repeat
Application.ProcessMessages;
GetExitCodeProcess(SEInfo.hProcess, ExitCode);
until (ExitCode <> STILL_ACTIVE) or Application.Terminated;
Result:=True;
end
else Result:=False;
end;
You are making life hard for yourself by using regsvr32. You've gone 99% of the way to doing without. Instead of calling regsvr32, just call DllRegisterServer. After all, that's all that regsvr32 is going to do!
Your code becomes:
if Assigned(ARegFunc) then
OleCheck(ARegFunc());
You can then remove ExecAndWait altogether. Which is nice because it saves me discussing the busy loop, and the leaked handle!
It would make sense to me to rename the variable that you called ARegFunc as DllRegisterServer. So the code might then look like this:
aHandle := LoadLibrary(PChar(ocxPath));
if aHandle = 0 then
RaiseLastWin32Error;
try
DllRegisterServer := GetProcAddress(aHandle,'DllRegisterServer');
if Assigned(DllRegisterServer) then
OleCheck(DllRegisterServer());
finally
FreeLibrary(aHandle);
end;
The most likely failure mode for a call to DllRegisterServer will be a failure to run your registration code elevated.
As an aside, LoadLibrary returns HMODULE rather than THandle.