Is there any way to block the Keyboard input completely ? This should also block key combos like WIN+E.
I found this Code, is there anyway to change it to block only keyboard input (Mouse needs to work)
procedure TForm1.Button1Click(Sender: TObject) ;
function FuncAvail(dllName, funcName: string; var p: pointer): boolean;
var
lib: THandle;
begin
result := false;
p := nil;
if LoadLibrary(PChar(dllName)) = 0 then exit;
lib := GetModuleHandle(PChar(dllName)) ;
if lib <> 0 then
begin
p := GetProcAddress(lib, PChar(funcName)) ;
if p <> nil then Result := true;
end;
end;
var
BlockInput : function(Block: BOOL): BOOL; stdcall;
begin
if FuncAvail('USER32.DLL', 'BlockInput', #BlockInput) then
begin
ShowMessage('Your Mouse and Keyboard will be blocked for 5 seconds!') ;
BlockInput(true) ;
Sleep(5000) ;
BlockInput(false) ;
end;
end;
end.
Would this code also work with WIN keys etc ?
Thanks!
You're thinking way too hard.
The appropriate way to set up a kiosk that can be controlled by the mouse and not the keyboard is to not have a keyboard attached. (This also makes it impossible for an unscrupulous kiosk-user to steal your keyboard.)
This also means that, if you need to perform administrative tasks, you can attach a keyboard (or remote in) and everything will work fine.
If for some reason removing the keyboard is not a feasible option, there is an unsupported way of doing this in software: remove the UpperFilters value from
HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\Class\{4D36E96B-E325-11CE-BFC1-08002BE10318}
This disables input from all normal keyboard devices, but the Remote Desktop virtual keyboard will still work, so you may want to ensure that Remote Desktop is configured and working first.
For your reference, should you want to reverse the process, UpperFilters is normally a REG_MULTI_SZ containing a single string "kbdclass" (without the quote marks).
Related
I have a program that uses SetCursorPos to position the cursor. The program operates as it is supposed to when running on real hardware but, when running in a VM (VMware workstation 10.0.7) it doesn't work. The cursor does not move. I tried using SendInput instead (the syscall it makes is different, because of that, I thought it might work), the result is the same as with SetCursorPos, it works on real hardware, does not work when running in a VM.
The question is: does anyone know if either SetCursorPos or SendInput can be made to work in a VM and if yes, how ? Any other way to position the cursor at a specific place that works in a VM would be welcome as well.
Thank you for your help.
For anyone who cares to try, here is some of the code I've tried.
{$APPTYPE CONSOLE}
program ConsoleSetCursorPos;
uses
Windows
;
function GetConsoleWindow : HWND; stdcall; external kernel32;
procedure DoIt;
var
ConsoleWindow : HWND;
ClientRect : TRECT;
CursorPosRetVal : BOOL;
LastError : dword;
Desktop : HDESK;
begin
// the code below is not normally necessary - for testing only
Desktop := OpenInputDesktop(0, false, WINSTA_WRITEATTRIBUTES);
LastError := GetLastError;
writeln;
writeln('From OpenInputDesktop');
writeln('Last error (decimal) : ', LastError);
if Desktop = 0 then
begin
writeln('Program terminated due to OpenInputDesktop failure');
halt(255);
end;
if not SetThreadDesktop(Desktop) then
begin
writeln('Program terminated due to SetThreadDesktop failure');
halt(255);
end;
writeln;
// end of normally unnecessary code
SetLastError(0);
ConsoleWindow := GetConsoleWindow;
GetClientRect(ConsoleWindow, ClientRect);
ClientToScreen(ConsoleWindow, ClientRect.TopLeft);
CursorPosRetVal := SetCursorPos(ClientRect.Left, ClientRect.Top);
LastError := GetLastError;
if not CursorPosRetVal
then writeln('SetCursorPos returned false (failed)')
else writeln('SetCursorPos returned true (succeeded)');
writeln('Last error (decimal) : ', LastError);
if Desktop <> 0 then CloseDesktop(Desktop);
end;
begin
DoIt;
end.
As the remarks on SetCursorPos doc:
The cursor is a shared resource. A window should move the cursor only
when the cursor is in the window's client area.
The calling process must have WINSTA_WRITEATTRIBUTES access to the
window station.
The input desktop must be the current desktop when you call
SetCursorPos. Call OpenInputDesktop to determine whether the current
desktop is the input desktop. If it is not, call SetThreadDesktop with
the HDESK returned by OpenInputDesktop to switch to that desktop.
Or you can take the same try to un-installed the mouse driver from the VM as this answer.
I would like to send a BackSpace control char to a TMemo like the user would actually press the BackSpace button.
My Memo is readonly and if I click a button it should delete the last char in the memo.
I would like to do that without using Memo.Text := ... (so no redraw or beginupdate, etc.)
Is that possible, if yes, how?
Thank you for your help.
EDIT: I tried to add #8 but no luck...
Sending a key press to a read only memo won't work. The key press will be ignored because the memo is read only. To delete the final character of a memo in an efficient way, that is without replacing the entire contents, you can use EM_SETSEL and EM_REPLACESEL.
var
Len: Integer;
begin
Len := Memo1.GetTextLen;
SendMessage(Memo1.Handle, EM_SETSEL, Len-1, Len);
SendMessage(Memo1.Handle, EM_REPLACESEL, 0, LPARAM(PChar('')));
end;
Or if you prefer a pure VCL version which wraps up these Windows messages:
begin
Memo1.SelStart := Memo1.GetTextLen-1;
Memo1.SelLength := 1;
Memo1.SelText := '';
end;
The latter probably sends a few more Windows messages, but is much easier to read. I would prefer the latter option.
One possible problem I can see with this is that it may not do what you want with line breaks. Since a Windows line break is two characters (CR+LF), you would need to delete two characters if the last character in the memo was LF. To handle that you can probably do it like this:
begin
Memo1.SelStart := Memo1.GetTextLen-1;
Memo1.SelLength := 1;
if Memo1.SelText=#10 then
begin
Memo1.SelStart := Memo1.SelStart-1;
Memo1.SelLength := 2;
end;
Memo1.SelText := '';
end;
Using Windows Print Spooler API's, we can print out XPS files.
The problem is that the print spooler ignores the default printer settings.
(We've given up on trying to apply printer settings. Default printer settings will just have to suffice.)
For example... the printouts always come out in colour and on one paper per page, regardless of what the settings are set to in the control panel: black & white/colour, duplex/not duplex, multiple pages per sheet/single page per sheet.
Other applications such as MS Word and Adobe respect the default printer settings.
We're using Delphi XE2 and Windows 7 64-bit.
This test code is self contained, so you can just paste it in to test it...
Populate a combo box with printer names using:
uses
Printers
ComboBox1.Items.Assign(Printer.Printers);
Printing procedure:
uses
Winapi.WinSpool
procedure PrintXPS(PrinterName, FileNameXPS: string; ParentFormHandle: THandle = 0);
// Printer handle
procedure Printer_Open(out Printer: THandle; Defaults: PPrinterDefaultsW = nil);
begin
if not OpenPrinterW(PWideChar(PrinterName), Printer, Defaults) then
RaiseLastOSError;
end;
procedure Printer_Close(Printer: THandle);
begin
if not ClosePrinter(Printer) then
RaiseLastOSError;
end;
// Print jobs
function JobCreate(Printer: THandle; FileName: string): Cardinal;
var
lBufferSize: Cardinal;
lAddJobInfo: PAddJobInfo1W;
begin
// Create job
AddJobW(Printer, 1, nil, 0, lBufferSize);
GetMem(lAddJobInfo, lBufferSize);
try
if not AddJobW(Printer, 1, lAddJobInfo, lBufferSize, lBufferSize) then
RaiseLastOSError;
Result := lAddJobInfo.JobId;
// Copy the file into place
CopyFile(PWideChar(FileName), lAddJobInfo.Path, True);
finally
FreeMem(lAddJobInfo, lBufferSize);
end;
end;
procedure JobStart(Printer: THandle; JobID: Cardinal);
begin
if not ScheduleJob(Printer, JobID) then
RaiseLastOSError;
end;
var
PrinterA: THandle;
JobID: Cardinal;
begin
if not FileExists(FileNameXPS) then
raise Exception.Create('File not found: ' + FileNameXPS);
Printer_Open(PrinterA, nil);
try
JobID := JobCreate(PrinterA, FileNameXPS);
JobStart(PrinterA, JobID);
finally
Printer_Close(PrinterA);
end;
end;
Much as I know you can not change the appearance of a .xps file.
XPS stands for XML Paper Specification, it is virtually an "electronic paper", the document on screen and in print is exactly the way it was intended by the author. Anyone who has ever experienced, how the page layout of an Office document on a shared computer because of a different default printer has shifted, appreciate it.
EDIT
Test
1.) Default black and white printer settings. Open the. xps file Print.
With IE == colored output.
With XPS Viewer EP == colored output.
Default printer settings == ignored.
2.) Dialog: Printer-settings manually to print black and white set.
IE == black and white output.
XPS Viewer EP == black and white output.
Say I have got a program that hogs the processor and/or hard disk to the point that it makes it nearly impossible to do anything else on that computer. Now I don't want to kill that program because what it does is useful (it's a batch job that really is that CPU or disk heavy, e.g. it could ZIP a few gigabytes of data files) but for a short time I need to do something else on that computer. Is there any way an external program could do to freeze that performance killer for a while?
It's like the old DOS option to switch between programs without actually having multitasking.
Assume that the hypothetical program in question is a 3rd party product for which I don't have the source code and there is no way to tell it to pause.
I know I can change the program's priority class e.g. in TaskManager but that's not enough, I want to freeze it.
I am talking about Windows XP as the OS and would like to program a solution with Delphi. I have got all rights on the machine, so I could start something as administrator, replace files and I could also install a service if that is necessary.
You can freeze it with Process Explorer: Right-click on your program and select Suspend.
Here is some sample code for programmatic freezing from http://www.c-plusplus.de/forum/viewtopic-var-p-is-1460293.html, edited and omitted error checking for brevity:
#include <windows.h>
_NtSuspendProcess NtSuspendProcess =
(_NtSuspendProcess) GetProcAddress( GetModuleHandle( "ntdll" ),
"NtSuspendProcess" );
HANDLE ProcessHandle = OpenProcess( PROCESS_ALL_ACCESS, FALSE, pid);
NtSuspendProcess( ProcessHandle );
If you want to do it programatically you can use the approach described here.
What is does, is enumerating all the threads in a process and then suspending them. There is no SuspendProcess API, so this is a simulation of such a call.
Beware that this can potentionally have some bad side effects. It depend on the process and how it is written.
I don't know of any other way to do it in the Win32/64 API world. If you go lower to the kernel land and use the NT* APIs you have "NtSuspendProcess" API available. But this is undocumented so it can change with any version of windows or even with any service pack (not very likely though).
The declaration of "NtSuspendProcess" can be found in the JEDI ports of the windows APIs.
You can use my ProcessInfo component to suspend all threads belonging to the process. The approach is similar to what Runner explained to you. The code would be something like this:
var
Process : TProcessItem;
AThread: TThreadItem;
begin
Process := ProcessInfo1.RunningProcesses.FindByName('notepad.exe');
if Assigned(Process) then
begin
for AThread in Process.Threads do
AThread.SuspendThread;
end;
end;
You can download source code of ProcessInfo form here
function OpenThread(dwDesiredAccess: DWORD; InheritHandle: Boolean; dwThreadID: DWORD): THandle; stdcall; external 'kernel32.dll';
function ResumeProcess(PID: DWORD):Boolean;
var
tid, snap: THandle;
TE32: TThreadEntry32;
begin
Result := False;
snap := CreateToolHelp32SnapShot(TH32CS_SNAPTHREAD, 0);
TE32.dwSize := SizeOf(TThreadEntry32);
Thread32First(snap, TE32);
repeat
if TE32.th32OwnerProcessID = PID then begin
tid := OpenThread($0002, FALSE, TE32.th32ThreadID);
ResumeThread(tid);
Result := TRUE;
CloseHandle(tid);
end;
until Thread32Next(snap, TE32) = false;
CloseHandle(snap);
end;
function SuspendProcess(PID: DWORD): Boolean;
var
tid, snap: THandle;
TE32: TThreadEntry32;
begin
Result := False;
snap := CreateToolHelp32SnapShot(TH32CS_SNAPTHREAD, 0);
TE32.dwSize := SizeOf(TThreadEntry32);
Thread32First(snap, TE32);
repeat
if TE32.th32OwnerProcessID = PID then begin
tid := OpenThread($0002, FALSE, TE32.th32ThreadID);
SuspendThread(tid);
Result := TRUE;
CloseHandle(tid);
end;
until Thread32Next(snap, TE32) = false;
CloseHandle(snap);
end;
Hope this helps
I Delphi, I need a function which determinates if the system menu (resp. window menu, the menu that appears when the icon is clicked) is opened. The reason is that I am writing a anti-keylogger functionality which sends garbage to the current active editcontrol (this also prevents keylogger which read WinAPI messages to read the content). But if system-menu is opened, the editcontrol STILL has the focus, so the garbage will invoke shortcuts.
If I use message WM_INITMENUPOPUP in my TForm1, I can determinate when the system menu opens, but I wish that I do not have to change the TForm, since I want to write a non visual component, which does not need any modifications at the TForm-derivate-class itself.
//I do not want that solution since I have to modify TForm1 for that!
procedure TForm1.WMInitMenuPopup(var Message: TWMInitMenuPopup);
begin
if message.MenuPopup=getsystemmenu(Handle, False) then
begin
SystemMenuIsOpened := true;
end;
end;
TApplicaton.HookMainWindow() does not send the WM_INITMENUPOPUP to my hook function.
function TForm1.MessageHook(var Msg: TMessage): Boolean;
begin
Result := False;
if (Msg.Msg = WM_INITMENUPOPUP) then
begin
// Msg.Msg IS NEVER WM_INITMENUPOPUP!
if LongBool(msg.LParamHi) then
begin
SystemMenuIsOpened := true;
end;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Application.HookMainWindow(MessageHook);
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
Application.UnhookMainWindow(MessageHook);
end;
Even after very long research I did not found any information about how to query if the system-menu is opened or not. I do not find any way to determinate the opening+closing of that menu.
Has someone a solution for me please?
Regards
Daniel Marschall
Application.HookMainWindow doesn't do what you seem to think. It hooks the hidden application window, not the main form. To intercept WM_INITMENUPOPUP on a specific form, all you need to do is write a handler for it, as you have seen.
To do this generically for any owner form of a component, you could assign WindowProc property of the form to place the hook:
unit FormHook;
interface
uses
Windows, Classes, SysUtils, Messages, Controls, Forms;
type
TFormMessageEvent = procedure(var Message: TMessage; var Handled: Boolean) of object;
TFormHook = class(TComponent)
private
FForm: TCustomForm;
FFormWindowProc: TWndMethod;
FOnFormMessage: TFormMessageEvent;
protected
procedure FormWindowProc(var Message: TMessage); virtual;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property OnFormMessage: TFormMessageEvent read FOnFormMessage write FOnFormMessage;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Test', [TFormHook]);
end;
procedure TFormHook.FormWindowProc(var Message: TMessage);
var
Handled: Boolean;
begin
if Assigned(FFormWindowProc) then
begin
Handled := False;
if Assigned(FOnFormMessage) then
FOnFormMessage(Message, Handled);
if not Handled then
FFormWindowProc(Message);
end;
end;
constructor TFormHook.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FFormWindowProc := nil;
FForm := nil;
while Assigned(AOwner) do
begin
if AOwner is TCustomForm then
begin
FForm := TCustomForm(AOwner);
FFormWindowProc := FForm.WindowProc;
FForm.WindowProc := FormWindowProc;
Break;
end;
AOwner := AOwner.Owner;
end;
end;
destructor TFormHook.Destroy;
begin
if Assigned(FForm) and Assigned(FFormWindowProc) then
begin
FForm.WindowProc := FFormWindowProc;
FFormWindowProc := nil;
FForm := nil;
end;
inherited Destroy;
end;
end.
You could then use this component on a form:
procedure TForm1.FormHook1FormMessage(var Message: TMessage; var Handled: Boolean);
begin
case Message.Msg of
WM_INITMENUPOPUP:
...
end;
end;
The problem might be that if the form has any other components which do the same thing then you need to make sure that unhooking happens in reverse order (last hooked, first unhooked). The above example hooks in the constructor and unhooks in the destructor; this seems to work even with multiple instances on the same form.
If you don't want any modifications to TForm-derivate-class, why don't try pure Windows API way to implement your current solution, that is, use SetWindowLongPtr() to intercept the WM_INITMENUPOPUP message. Delphi VCL style to intercept messages is just a wrapper of this Windows API function actually.
For that purpose, use SetWindowLongPtr() to set a new address for the window procedure and to get the original address of the window procedure, both at one blow. Remember to store the original address in a LONG_PTR variable. In 32-bit Delphi, LONG_PTR was Longint; supposing 64-bit Delphi will have been released in the future, LONG_PTR should be Int64; you can use $IFDEF directive to distinguish them as follows:
Type
{$IFDEF WIN32}
PtrInt = Longint;
{$ELSE}
PtrInt = Int64;
{$ENDIF}
LONG_PTR = PtrInt;
The value for nIndex parameter to be used for this purpose is GWLP_WNDPROC. Also, pass the new address for the window procedure to dwNewLong parameter, e.g. LONG_PTR(NewWndProc). The NewWndProc is a WindowProc Callback Function that processes messages, it is where your put your intercept criteria and override the default handling of the message you are going to intercept. The callback function can be any name, but the parameters must follow the WindowProc convention.
Note that you must call CallWindowProc() to pass any messages not processed by the new window procedure to the original window procedure.
Finally, you should call SetWindowLongPtr() again somewhere in your code to set the address of modified/new window procedure handler back to the original address. The original address has been saved before as mentioned above.
There was a Delphi code example here. It used SetWindowLong(), but now Microsoft recommends to use SetWindowLongPtr() instead to make it compatible with both 32-bit and 64-bit versions of Windows.
SetWindowLongPtr() didn't exist in Windows.pas of Delphi prior to Delphi 2009. If you use an older version of Delphi, you must declare it by yourself, or use JwaWinUser unit of JEDI API Library.
Not tried this myself, but give this a shot:
Use GetMenuItemRect to get the rect for item 0 of the menu returned by GetSystemMenu.
I (assume!) GetMenuItemRect should return 0 if the system menu is not open (because system could not know the rect of the menu item unless it is open?) If the result is non-zero, check if the coords returned are possible for the given screen resolution.
If you have the time, you could look into AutoHotKey's source code to see how to monitor when system menu is open/closed.