Windows Global Keyboard Hook - Delphi - delphi

I've created a GLOBAL keyboard hook DLL, using source code found on the internet. For the best part it works brilliant, except when it comes to browsers.
It picks up every key in the browser except, it seems, when the browser gets focus, it looses the first key that is pressed. Tested this in IE and Firefox and it seems to be the same for both.
For instance, if I open IE and start typing www. , I only get back ww. If the browser window stays in focus no further keys are lost. As soon as the browser looses focus and regains focus, the first key is again missing.
Could it be because of using only WH_KEYDOWN instead of WH_KEYPRESS / WH_KEYUP ? Can anyone shed some light on this please?
Thank you
PS: The hook function itself is below: The DLL is sent a memo box and app handle to wich the DLL will send messages as well as a usermessage.
function KeyHookFunc(Code, VirtualKey, KeyStroke: Integer): LRESULT; stdcall;
var
KeyState1: TKeyBoardState;
AryChar: array[0..1] of Char;
Count: Integer;
begin
Result := 0;
if Code = HC_NOREMOVE then Exit;
Result := CallNextHookEx(hKeyHook, Code, VirtualKey, KeyStroke);
{I moved the CallNextHookEx up here but if you want to block
or change any keys then move it back down}
if Code < 0 then
Exit;
if Code = HC_ACTION then
begin
if ((KeyStroke and (1 shl 30)) <> 0) then
if not IsWindow(hMemo) then
begin
{I moved the OpenFileMapping up here so it would not be opened
unless the app the DLL is attatched to gets some Key messages}
hMemFile := OpenFileMapping(FILE_MAP_WRITE, False, 'NetParentMAP');//Global7v9k
PHookRec1 := MapViewOfFile(hMemFile, FILE_MAP_WRITE, 0, 0, 0);
if PHookRec1 <> nil then
begin
hMemo := PHookRec1.MemoHnd;
hApp := PHookRec1.AppHnd;
end;
end;
if ((KeyStroke AND (1 shl 31)) = 0) then //if ((KeyStroke and (1 shl 30)) <> 0) then
begin
GetKeyboardState(KeyState1);
Count := ToAscii(VirtualKey, KeyStroke, KeyState1, AryChar, 0);
if Count = 1 then
begin
SendMessage(hMemo, WM_CHAR, Ord(AryChar[0]), 0);
{I included 2 ways to get the Charaters, a Memo Hnadle and
a WM_USER+1678 message to the program}
PostMessage(hApp, WM_USER + 1678, Ord(AryChar[0]), 0);
end;
end;
end;
end;

You are not assigning your hMemo and hApp values early enough. You are waiting until a notification with a "previous state" flag of 1, which indicates a key has been held down for at least 1 repeat count, or is being released, whichever occurs first. Thus, hMemo and hApp are not available yet when your hook detects its first key down notification. That is why you miss characters. Try this instead:
function KeyHookFunc(Code, VirtualKey, KeyStroke: Integer): LRESULT; stdcall;
var
KeyState1: TKeyBoardState;
AryChar: array[0..1] of Char;
Count: Integer;
begin
Result := CallNextHookEx(hKeyHook, Code, VirtualKey, KeyStroke);
if Code <> HC_ACTION then Exit;
{ a key notification had occured, prepare the HWNDs
before checking the actual key state }
if (hMemo = 0) or (hApp = 0) then
begin
if hMemFile = 0 then
begin
hMemFile := OpenFileMapping(FILE_MAP_WRITE, False, 'NetParentMAP');
if hMemFile = 0 then Exit;
end;
if PHookRec1 = nil then
begin
PHookRec1 := MapViewOfFile(hMemFile, FILE_MAP_WRITE, 0, 0, 0);
if PHookRec1 = nil then Exit;
end;
hMemo := PHookRec1.MemoHnd;
hApp := PHookRec1.AppHnd;
if (hMemo = 0) and (hApp = 0) then Exit;
end;
if ((KeyStroke and (1 shl 31)) = 0) then // a key is down
begin
GetKeyboardState(KeyState1);
Count := ToAscii(VirtualKey, KeyStroke, KeyState1, AryChar, 0);
if Count = 1 then
begin
if hMemo <> 0 then SendMessage(hMemo, WM_CHAR, Ord(AryChar[0]), 0);
if hApp <> 0 then PostMessage(hApp, WM_USER + 1678, Ord(AryChar[0]), 0);
end;
end;
end;

Related

How to start a windows service in Delphi for Windows 8

I need to Start a service using Delphi Windows application.It is working fine in Windows 7 but not working in Windows 8.1 .I have used the following code
function ServiceStart(sMachine,sService : string ) : boolean;
var
schm,schs : SC_Handle;
ss : TServiceStatus;
psTemp : PChar;
dwChkP : DWord;
begin
ss.dwCurrentState := 0;
schm := OpenSCManager(PChar(sMachine),Nil,SC_MANAGER_CONNECT);
if(schm > 0)then
begin
schs := OpenService(schm,PChar(sService),SERVICE_START or SERVICE_QUERY_STATUS);
if(schs > 0)then
begin
psTemp := Nil;
if(StartService(schs,0,psTemp))then
begin
if(QueryServiceStatus(schs,ss))then
begin
while(SERVICE_RUNNING <> ss.dwCurrentState)do
begin
dwChkP := ss.dwCheckPoint;
Sleep(ss.dwWaitHint);
if(not QueryServiceStatus(schs,ss))then
begin
break;
end;
if(ss.dwCheckPoint < dwChkP)then
begin
break;
end;
end;
end;
end;
CloseServiceHandle(schs);
end;
CloseServiceHandle(schm);
end;
Result := SERVICE_RUNNING = ss.dwCurrentState;
end;
procedure TForm1.BBSerStatusClick(Sender: TObject);
begin
ServiceStart('','SERVTEST');
end;
Note: SERVTEST it is service application.
Can anyone help me?
I see that you are using code copied from here.
if(schm > 0)then and if(schs > 0)then should be changed to if(schm <> 0)then and if(schs <> 0) then instead. The only failure value in this situation is 0 (some APIs use INVALID_HANDLE_VALUE instead, but the SCM API does not). Any other value is a valid handle. Handles are not really integers (although Delphi declares them as such), so you should not treat them as integers. They are arbitrary values that are not meant to be interpreted, they are meant to be used as-is. If you do not get back an actual failure value (in this case, 0), then the call was successful regardless of the value actully returned.
The handling of ss.dwCurrentState is a little off, too. Instead of looping while ss.dwCurrentState is not SERVICE_RUNNING, loop while ss.dwCurrentState is SERVICE_START_PENDING instead. If something goes wrong and the service never enters the SERVICE_RUNNING state, the loop will run forever, unless QueryServiceStatus() itself fails. And I would not suggest relying on ss.dwCheckPoint because not all services implement it correctly (in fact, Delphi's own TService does not - see QC #1006 TService.ReportStatus reports incorrect CheckPoint).
Try something more like the following. It differentiates between SCM API failures and Service start failures, but also does extra error checking to handle certain errors that are not actually fatal errors:
function ServiceStart(sMachine, sService : string) : Boolean;
var
schm, schs : SC_HANDLE;
ss : TServiceStatus;
begin
schm := OpenSCManager(PChar(sMachine), nil, SC_MANAGER_CONNECT);
if (schm = 0) then RaiseLastOSError;
try
schs := OpenService(schm, PChar(sService), SERVICE_START or SERVICE_QUERY_STATUS);
if (schs = 0) then RaiseLastOSError;
try
// NOTE: if you use a version of Delphi that incorrectly declares
// StartService() with a 'var' lpServiceArgVectors parameter, you
// can't pass a nil value directly in the 3rd parameter, you would
// have to pass it indirectly as either PPChar(nil)^ or PChar(nil^)
if not StartService(schs, 0, nil) then
begin
Result := ERROR_SERVICE_ALREADY_RUNNING = GetLastError();
if not Result then RaiseLastOSError;
Exit;
end;
repeat
if not QueryServiceStatus(schs, ss) then
begin
if (ERROR_SERVICE_NOT_ACTIVE <> GetLastError()) then RaiseLastOSError;
Result := False;
Exit;
end;
if (SERVICE_START_PENDING <> ss.dwCurrentState) then Break;
Sleep(ss.dwWaitHint);
until False;
Result := SERVICE_RUNNING = ss.dwCurrentState;
finally
CloseServiceHandle(schs);
end;
finally
CloseServiceHandle(schm);
end;
end;
Or, here is a (modified) version of Microsoft's example, which also includes handling if the service is in SERVICE_STOP_PENDING state before starting it (I removed timeout logic since it is based on dwCheckPoint handling):
Starting a Service:
function ServiceStart(sMachine, sService : string) : Boolean;
var
schSCManager,
schService : SC_HANDLE;
ssStatus : TServiceStatus;
begin
// Get a handle to the SCM database.
schSCManager := OpenSCManager(PChar(sMachine), nil, SC_MANAGER_CONNECT);
if (schSCManager = 0) then RaiseLastOSError;
try
// Get a handle to the service.
schService := OpenService(schSCManager, PChar(sService), SERVICE_START or SERVICE_QUERY_STATUS);
if (schService = 0) then RaiseLastOSError;
try
// Check the status in case the service is not stopped.
if not QueryServiceStatus(schService, ssStatus) then
begin
if (ERROR_SERVICE_NOT_ACTIVE <> GetLastError()) then RaiseLastOSError;
ssStatus.dwCurrentState := SERVICE_STOPPED;
end;
// Check if the service is already running
if (ssStatus.dwCurrentState <> SERVICE_STOPPED) and ssStatus.dwCurrentState <> SERVICE_STOP_PENDING) then
begin
Result := True;
Exit;
end;
// Wait for the service to stop before attempting to start it.
while (ssStatus.dwCurrentState = SERVICE_STOP_PENDING) do
begin
// Do not wait longer than the wait hint. A good interval is
// one-tenth of the wait hint but not less than 1 second
// and not more than 10 seconds.
dwWaitTime := ssStatus.dwWaitHint div 10;
if (dwWaitTime < 1000) then
dwWaitTime := 1000
else if (dwWaitTime > 10000) then
dwWaitTime := 10000;
Sleep(dwWaitTime);
// Check the status until the service is no longer stop pending.
if not QueryServiceStatus(schService, ssStatus) then
begin
if (ERROR_SERVICE_NOT_ACTIVE <> GetLastError()) then RaiseLastOSError;
Break;
end;
end;
// Attempt to start the service.
// NOTE: if you use a version of Delphi that incorrectly declares
// StartService() with a 'var' lpServiceArgVectors parameter, you
// can't pass a nil value directly in the 3rd parameter, you would
// have to pass it indirectly as either PPChar(nil)^ or PChar(nil^)
if not StartService(schService, 0, nil) then RaiseLastOSError;
// Check the status until the service is no longer start pending.
if not QueryServiceStatus(schService, ssStatus) then
begin
if (ERROR_SERVICE_NOT_ACTIVE <> GetLastError()) then RaiseLastOSError;
ssStatus.dwCurrentState := SERVICE_STOPPED;
end;
while (ssStatus.dwCurrentState = SERVICE_START_PENDING) do
begin
// Do not wait longer than the wait hint. A good interval is
// one-tenth the wait hint, but no less than 1 second and no
// more than 10 seconds.
dwWaitTime := ssStatus.dwWaitHint div 10;
if (dwWaitTime < 1000) then
dwWaitTime := 1000
else if (dwWaitTime > 10000) then
dwWaitTime := 10000;
Sleep(dwWaitTime);
// Check the status again.
if not QueryServiceStatus(schService, ssStatus) then
begin
if (ERROR_SERVICE_NOT_ACTIVE <> GetLastError()) then RaiseLastOSError;
ssStatus.dwCurrentState := SERVICE_STOPPED;
Break;
end;
end;
// Determine whether the service is running.
Result := (ssStatus.dwCurrentState = SERVICE_RUNNING);
finally
CloseServiceHandle(schService);
end;
finally
CloseServiceHandle(schSCManager);
end;
end;

Procedure fires without being called

Is it possible, in delphi, that a procedure fires without being called?
I have two completly different procedure. First one is a click on popup menu. The second one is a function which i defined to split a string.
And i don't call my split method in my click of popup menu but it fires anyway and i can't find why. Debugger just says he can't read adress 00000001 but i don't even want him to read cause i don't call this procedure in any of my popup options. Does anyone have any idea of why it could fire by its own?
I can edit code if you want but idk it will be usefull as both procedure arent linked x)
CODE
procedure TBDDTool.pmDeleteColumnClick(Sender: TObject);
var
i: integer;
sListColNames : string;
begin
fileModified := true;
sListColNames := '';
//Increment undo number
Inc(undoNum);
if undoNum = 11 then
begin
for i := 0 to Length(UndoArray) - 1 do
begin
if i < Length(UndoArray)-1 then
UndoArray[i] := UndoArray[i+1];
end;
undoNum := UndoNum -1;
end;
//Add action to the array of undo actions
undoArray[undoNum] := 'Deleted column:' + IntToStr(sgFilePreview.Col)
+'$'+aSourceData[0,sgFilePreview.Col] + '#deleted';
pmUndo.Enabled := true;
if (Pos('#primarykeypk', aSourceData[0, sgFilePreview.Col]) <> 0) then
begin
aSourceData[0,sgFilePreview.Col] := COPY(aSourceData[0,sgFilePreview.Col], 0, Pos('#primarykey', aSourceData[0, sgFilePreview.Col])-1);
pmPrimaryKey.Enabled := true;
end;
if (Pos('#', aSourceData[0, sgFilePreview.Col]) <> 0) then
aSourceData[0,sgFilePreview.Col] := COPY(aSourceData[0,sgFilePreview.Col], 0, Pos('#', aSourceData[0, sgFilePreview.Col])-1);
for i := 0 to Length(aSourceData[0])-1 do
begin
if aSourceData[0,i] = sgFilePreview.Cells[sgFilePreview.Col, 0] then
begin
aSourceData[0,i] := aSourceData[0,i] + '#deleted';
Break;
end;
end;
//just set col width to 0 to hide it but we need the index
sgFilePreview.ColWidths[sgFilePreview.Col] := 0;
end;
//Custom split method
function TBDDTool.Explode(const Separator, s: String;
Limit: Integer): TStringDynArray;
var
SepLen: Integer;
F, P: PChar;
ALen, Index: Integer;
begin
SetLength(Result,0);
//if the word passed is empty there's no need to continue
if (S = '') or (Limit < 0) then Exit;
if Separator = '' then
begin
SetLength(Result, 1);
Result[0] := S;
Exit;
end;
//Set to the length of the separator
SepLen := Length(Separator);
ALen := Limit;
SetLength(Result, ALen);
Index := 0;
P := PChar(s);
While P^ <> #0 do
begin
F := P;
P := AnsiStrPos(P,PChar(Separator));
if (P = nil) OR ((Limit > 0) AND (Index = Limit -1)) then P := StrEnd(F);
if Index >= ALen then
begin
Inc(ALen,5);
SetLength(Result, ALen);
end;
SetString(Result[Index], F, P-F);
INC(Index);
if p^ <> #0 then Inc(P,SepLen);
end;
if index < ALen then SetLength(Result, Index);
end;
The explode functions is called when i click delet option (from a popup menu). But i don't call the explode function in my delete procedure. The break happens on while P^ <> #0 line
Is it possible, in delphi, that a procedure fires without being called?
Generally speak, it is not possible. If code executes, something in the system made it execute.
However, it is possible that you have somehow corrupted memory. That in turn may lead to you calling one function and the corruption leading to a different function being called.
In order to debug this I suggest that you first of all inspect the call stack when the unexpected function begins executing. That should tell you how the execution reached that point. If that's not enough to explain things, cut your code down to the bare minimum that produces the problem. It's harder to find problems when there's lots of code. By cutting down to a minimum, you'll make it easier to see what has gone wrong.

How to close all windows with the same title

i have thread in my application shows messageboxs in another application with title 'Test' on every event the thread create it,by the end of this thread i wanna close all of this messages.
i tried to create loop like this
while FindWindow(Nil,PChar('Test')) <> 0 do
begin
Sleep(5); //if i remove the sleep the application will hanging and froze.
SendMessage(FindWindow(Nil,PChar('Test')), WM_CLOSE, 0, 0); // close the window message
end;
but this loop works only if i close the last message manually
Note: the messageboxs comes from another applaction not in the same application have this thread.
Try this instead:
var
Wnd: HWND;
begin
Wnd := FindWindow(Nil, 'Test');
while Wnd <> 0 do
begin
PostMessage(Wnd, WM_CLOSE, 0, 0);
Wnd := FindWindowEx(0, Wnd, Nil, 'Test');
end;
end;
Or:
function CloseTestWnd(Wnd: HWND; Param: LPARAM): BOOL; stdcall;
var
szText: array[0..5] of Char;
begin
if GetWindowText(Wnd, szText, Length(szText)) > 0 then
if StrComp(szText, 'Test') = 0 then
PostMessage(Wnd, WM_CLOSE, 0, 0);
Result := True;
end;
begin
EnumWindows(#CloseTestWnd, 0);
end;
Your logic seems to be somewhat... off. :-) You may or may not be sending the WM_CLOSE to the same window, since you're using one FindWindow to see if it exists and a different call to FindWindow to send the message.
I'd suggest doing it more like this:
var
Wnd: HWnd;
begin
Wnd := FindWindow(nil, 'Test'); // Find the first window (if any)
while Wnd <> 0 do
begin
SendMessage(Wnd, WM_CLOSE, 0, 0); // Send the message
Sleep(5); // Allow time to close
Wnd := FindWindow(nil, 'Test'); // See if there's another one
end;
end;
Depending on what the other application is doing, you may need to increase the Sleep time in order to allow the window time to receive and process the WM_CLOSE message; otherwise, you'll be simply sending it multiple times to the same window. (I'm suspecting that 5 ms is far too little time.)

How can I check if keybd_event was successful?

I have this code right here that modifies the clipboard and then restores it back:
function SetClipText(szText:WideString):Boolean;
var
pData: DWORD;
dwSize: DWORD;
begin
Result := FALSE;
if OpenClipBoard(0) then
begin
dwSize := (Length(szText) * 2) + 2;
if dwSize <> 0 then
begin
pData := GlobalAlloc(MEM_COMMIT, dwSize);
if pData <> 0 then
begin
CopyMemory(Pointer(pData), #szText[1], dwSize - 2);
if SetClipBoardData(CF_UNICODETEXT, pData) <> 0 then
Result := TRUE;
end;
end;
CloseClipBoard;
end;
end;
function GetClipText(var szText:WideString):Boolean;
var
hData: DWORD;
pData: Pointer;
dwSize: DWORD;
begin
Result := FALSE;
if OpenClipBoard(0) then
begin
hData := GetClipBoardData(CF_UNICODETEXT);
if hData <> 0 then
begin
pData := GlobalLock(hData);
if pData <> nil then
begin
dwSize := GlobalSize(hData);
if dwSize <> 0 then
begin
SetLength(szText, (dwSize div 2) - 1);
CopyMemory(#szText[1], pData, dwSize);
Result := TRUE;
end;
GlobalUnlock(DWORD(pData));
end;
end;
CloseClipBoard;
end;
end;
var
OldClip : WideString;
begin
repeat until GetClipText (OldClip);
repeat until SetClipText ('NewClipBoardText');
// PASTE
keybd_event(VK_CONTROL, MapVirtualKey(VK_CONTROL, 0), 0, 0);
keybd_event(Ord('V'), MapVirtualKey(Ord('V'), 0), 0, 0);
keybd_event(Ord('V'), MapVirtualKey(Ord('V'), 0), KEYEVENTF_KEYUP, 0);
keybd_event(VK_CONTROL, MapVirtualKey(VK_CONTROL, 0), KEYEVENTF_KEYUP, 0);
repeat until SetClipText (OldClip);
end.
I use keybd_event to paste new clipboard text to a window (e.g. notepad).
It seems like that keybd_event is so fast, that repeat until SetClipText (OldClip); get's called before the keys got pressed. Is there way to check when and if the keys were pressed?
keybd_event never fails. It merely places they event that you specify into the currently active input queue.
Because the function is asynchronous the keyboard event is not processed until the other application gets round to processing it. So, most likely the other application has not processed the keyboard event by the time you call SetClipText. You can't expect to know when a particular keyboard event is processed, unless you have control of the other application. But in that case you would not be communicating with it by faking input.

How to get the master volume in windows xp?

In Windows XP, with Delphi, how to get the master volume?
I know I can set up and down sending key strokes with keybd_event(VK_VOLUME_UP, 1, 0, 0); and keybd_event(VK_VOLUME_DOWN, 1, 0, 0);, but I don't know how to get the actual value of the volume.
The below is a little modification on the example code found here (credited there is Thomas Stutz). The example there sets the microphone volume. I just modified the component type - speaker destination instead of microphone source, and replaced mixerSetControlDetails with mixerGetControlDetails, and turned the setter into a getter of course. On the few systems I tested here (XPSp3, XPSp2, W2K, 98), it seems to work. The return of the function is the speaker out of the first (default) mixer - a value of 0-65535, the 'ShowMessage' in the button handler changes it into a percentage. But don't ask me more details about it, I really have no experience with the mixer api. Instead refer here f.i., though old the article really seemed to be comprehensive to me.
function GetSpeakerVolume(var bValue: Word): Boolean;
var {0..65535}
hMix: HMIXER;
mxlc: MIXERLINECONTROLS;
mxcd: TMIXERCONTROLDETAILS;
vol: TMIXERCONTROLDETAILS_UNSIGNED;
mxc: MIXERCONTROL;
mxl: TMixerLine;
intRet: Integer;
nMixerDevs: Integer;
begin
Result := False;
// Check if Mixer is available
nMixerDevs := mixerGetNumDevs();
if (nMixerDevs < 1) then
Exit;
// open the mixer
intRet := mixerOpen(#hMix, 0, 0, 0, 0);
if intRet = MMSYSERR_NOERROR then
begin
mxl.dwComponentType := MIXERLINE_COMPONENTTYPE_DST_SPEAKERS;
mxl.cbStruct := SizeOf(mxl);
// get line info
intRet := mixerGetLineInfo(hMix, #mxl, MIXER_GETLINEINFOF_COMPONENTTYPE);
if intRet = MMSYSERR_NOERROR then
begin
ZeroMemory(#mxlc, SizeOf(mxlc));
mxlc.cbStruct := SizeOf(mxlc);
mxlc.dwLineID := mxl.dwLineID;
mxlc.dwControlType := MIXERCONTROL_CONTROLTYPE_VOLUME;
mxlc.cControls := 1;
mxlc.cbmxctrl := SizeOf(mxc);
mxlc.pamxctrl := #mxc;
intRet := mixerGetLineControls(hMix, #mxlc, MIXER_GETLINECONTROLSF_ONEBYTYPE);
if intRet = MMSYSERR_NOERROR then
begin
ZeroMemory(#mxcd, SizeOf(mxcd));
mxcd.dwControlID := mxc.dwControlID;
mxcd.cbStruct := SizeOf(mxcd);
mxcd.cMultipleItems := 0;
mxcd.cbDetails := SizeOf(vol);
mxcd.paDetails := #vol;
mxcd.cChannels := 1;
intRet := mixerGetControlDetails(hMix, #mxcd, MIXER_GETCONTROLDETAILSF_VALUE);
if intRet <> MMSYSERR_NOERROR then
ShowMessage('GetControlDetails Error')
else begin
bValue := vol.dwValue;
Result := True;
end;
end
else
ShowMessage('GetLineInfo Error');
end;
intRet := mixerClose(hMix);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
Vol: Word;
begin
if GetSpeakerVolume(Vol) then
ShowMessage(IntToStr(Round(Vol * 100 / 65535)));
end;

Resources