I'm using the following code to terminate a process:
function KillTask(ExeFileName: string): Integer;
const
PROCESS_TERMINATE = $0001;
var
ContinueLoop: BOOL;
FSnapshotHandle: THandle;
FProcessEntry32: TProcessEntry32;
begin
Result := 0;
FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
FProcessEntry32.dwSize := SizeOf(FProcessEntry32);
ContinueLoop := Process32First(FSnapshotHandle, FProcessEntry32);
while Integer(ContinueLoop) <> 0 do
begin
if ((UpperCase(ExtractFileName(FProcessEntry32.szExeFile)) =
UpperCase(ExeFileName)) or (UpperCase(FProcessEntry32.szExeFile) =
UpperCase(ExeFileName))) then
Result := Integer(TerminateProcess(
OpenProcess(PROCESS_TERMINATE,
BOOL(0),
FProcessEntry32.th32ProcessID),
0));
ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32);
end;
CloseHandle(FSnapshotHandle);
end;
The problem is, when I call the above function in order to permanently terminate the explorer.exe, the Windows Explorer terminates though, but it's re-started afterwards:
KillTask('explorer.exe');
I'm using Delphi XE3, Delphi 7 and Windows 8.
Based on this Exit Explorer feature and code debugged by Luke in this post you may try to use the following code:
Warning:
This way is absolutely undocumented! So all constants and variables appearing in this post are fictitious. Any resemblance to real, documented code is purely coincidental :-)
function ExitExplorer: Boolean;
var
TrayHandle: HWND;
const
WM_EXITEXPLORER = $5B4;
begin
Result := False;
TrayHandle := FindWindow('Shell_TrayWnd', nil);
if TrayHandle <> 0 then
Result := PostMessage(TrayHandle, WM_EXITEXPLORER, 0, 0);
end;
I've tested it in Windows 7, where it works and doesn't even need the administrator elevation. Don't know how about the other systems (I'd say this won't work at least on Windows XP, but it's just a guess).
Related
We have a legacy Delphi 7 application that launches the Windows Defrag and On-screen Keyboard applications as follows:
// Defragmentation application
ShellExecute(0, 'open', PChar('C:\Windows\System32\dfrg.msc'), nil, nil, SW_SHOWNORMAL);
// On-screen keyboard
ShellExecute(0, 'open', PChar('C:\Windows\System32\osk.exe'), nil, nil, SW_SHOWNORMAL);
Both work on Windows XP but fail on Windows 10. I spotted that the defragmentation application has had a name change to dfrgui.exe, but updating the code does not help. The On-screen Keyboard is still called osk.exe on Windows 10.
Both applications can be launched manually / directly from the command line or by double-clicking them in Windows Explorer.
My suspicion is that Windows security is preventing my application from launching anything from C:\Windows\System32, because I can launch several other applications from Program Files and from C:\Windows.
Can anyone help?
Delphi 7 produces only 32-bit apps, there is no option to produce 64-bit apps (that was added in XE2).
Accessing a path under %WINDIR%\System32 from a 32-bit app running on a 64-bit system is subject to WOW64's File
System Redirector, which will silently redirect requests for the 64-bit System32 folder to the 32-bit SysWOW64 folder instead.
Chances are, the apps you are trying to run only exist in the 64-bit System32 folder and not in the 32-bit SysWOW64 folder.
To avoid redirection, you need to either:
replace System32 with the special Sysnative alias in your paths (ie 'C:\Windows\Sysnative\osk.exe'), which only works when running under WOW64, so you have to detect that dynamically at runtime via IsWow64Process():
function GetSystem32Folder: string;
var
Folder: array[0..MAX_PATH] of Char;
IsWow64: BOOL;
begin
Result := '';
if IsWow64Process(GetCurrentProcess(), #IsWow64) and IsWow64 then
begin
SetString(Result, Folder, GetWindowsDirectory(Folder, Length(Folder)));
if Result <> '' then
Result := IncludeTrailingPathDelimiter(Result) + 'Sysnative' + PathDelim;
end else
begin
SetString(Result, Folder, GetSystemDirectory(Folder, Length(Folder)));
if Result <> '' then
Result := IncludeTrailingPathDelimiter(Result);
end;
end;
function RunDefrag: Boolean;
var
SysFolder: string;
Res: Integer;
begin
SysFolder := GetSystem32Folder;
Res := Integer(ShellExecute(0, nil, PChar(SysFolder + 'dfrgui.exe'), nil, nil, SW_SHOWNORMAL));
if Res = ERROR_FILE_NOT_FOUND then
Res := Integer(ShellExecute(0, nil, PChar(SysFolder + 'dfrg.msc'), nil, nil, SW_SHOWNORMAL));
Result := (Res = 0);
end;
function RunOnScreenKeyboard: Boolean;
begin
Result := (ShellExecute(0, nil, PChar(GetSystem32Folder + 'osk.exe'), nil, nil, SW_SHOWNORMAL) = 0);
end;
temporarily disable the Redirector via Wow64DisableWow64FsRedirection(), and then re-enable it via Wow64RevertWow64FsRedirection() when done:
function GetSystem32Folder: string
var
Folder: array[0..MAX_PATH] of Char;
begin
SetString(Result, Folder, GetSystemDirectory(Folder, Length(Folder)));
if Result <> '' then
Result := IncludeTrailingPathDelimiter(Result);
end;
function RunDefrag: Boolean;
var
SysFolder: string;
OldState: Pointer;
Res: Integer;
begin
Wow64DisableWow64FsRedirection(#OldState);
try
SysFolder := GetSystem32Folder;
Res := Integer(ShellExecute(0, nil, PChar(SysFolder + 'dfrgui.exe'), nil, nil, SW_SHOWNORMAL));
if Res = ERROR_FILE_NOT_FOUND then
Res := Integer(ShellExecute(0, nil, PChar(SysFolder + 'dfrg.msc'), nil, nil, SW_SHOWNORMAL));
Result := Res = 0;
finally
Wow64RevertWow64FsRedirection(OldState);
end;
end;
function RunOnScreenKeyboard: Boolean;
var
OldState: Pointer;
begin
Wow64DisableWow64FsRedirection(#OldState);
try
Result := (ShellExecute(0, nil, PChar(GetSystem32Folder + 'osk.exe'), nil, nil, SW_SHOWNORMAL) = 0);
finally
Wow64RevertWow64FsRedirection(OldState);
end;
end;
Update: that being said, it turns out that a 32-bit process running under WOW64 is not allowed to run osk.exe when UAC is enabled:
Delphi - On Screen Keyboard (osk.exe) works on Win32 but fails on Win64
So, you will have to create a helper 64-bit process to launch osk.exe on your app's behalf when it is running under WOW64.
A small addition to Remy Lebeau's answer:
If Wow64DisableWow64FsRedirection is not available in your Delphi version, and/or if you are not sure if your target platform will support this API, you could use following code sample that calls the function dynamically:
https://www.delphipraxis.net/155861-windows-7-64bit-redirection.html
function ChangeFSRedirection(bDisable: Boolean): Boolean;
type
TWow64DisableWow64FsRedirection = Function(Var Wow64FsEnableRedirection: LongBool): LongBool; StdCall;
TWow64EnableWow64FsRedirection = Function(var Wow64FsEnableRedirection: LongBool): LongBool; StdCall;
var
hHandle: THandle;
Wow64DisableWow64FsRedirection: TWow64DisableWow64FsRedirection;
Wow64EnableWow64FsRedirection: TWow64EnableWow64FsRedirection;
Wow64FsEnableRedirection: LongBool;
begin
Result := false;
try
hHandle := GetModuleHandle('kernel32.dll');
#Wow64EnableWow64FsRedirection := GetProcAddress(hHandle, 'Wow64EnableWow64FsRedirection');
#Wow64DisableWow64FsRedirection := GetProcAddress(hHandle, 'Wow64DisableWow64FsRedirection');
if bDisable then
begin
if (hHandle <> 0) and (#Wow64DisableWow64FsRedirection <> nil) then
begin
Result := Wow64DisableWow64FsRedirection(Wow64FsEnableRedirection);
end;
end else
begin
if (hHandle <> 0) and (#Wow64EnableWow64FsRedirection <> nil) then
begin
Result := Wow64EnableWow64FsRedirection(Wow64FsEnableRedirection);
Result := True;
end;
end;
Except
end;
end;
function GetFileIcon(const filename:string): HICON;
var
shfi: TShFileInfo;
begin
try
FillChar(shfi, SizeOf(TShFileInfo), 0);
ShGetFileInfo(PChar(filename), 0, shfi, SizeOf(TShFileInfo), SHGFI_ICON or SHGFI_LARGEICON);
Result := shfi.hIcon;
except
Result := 0;
end;
end;
Using delphi xe2, on win 7 64bits, this function will often return 0 when called inside a Tthread, but is always working fine when called from main thread. It looks like a shell initialization problem, because after a while it will work in the Thread as well.
I found a similar question in stack overflow (Calling SHGetFileInfo in thread to avoid UI freeze) but it is for c++ language so I did not sort it out.
Update: It seems ShGetFileInfo is not threadsafe. When there are multiple threads calling it simultaneously, it fails. See David
Hefferman's answer below. Also using CoInitializeEx instead of Coinitialize does not help with multiple threads. You have to serilize access using a TCriticalSection.
From the documentation:
You must initialize Component Object Model (COM) with CoInitialize or OleInitialize prior to calling SHGetFileInfo.
In a GUI app, the COM is initialized in the main thread. But from other threads that does not happen automatically. You will need to do it explicitly.
Beyond that you are not handling errors correctly. Remember that Windows API functions do not raise exceptions. So your exception handler is pointless and should be removed. Instead you need to check the return value of your call to SHGetFileInfo, as described in the documentation.
Beyond that your code works, as this program demonstrates:
{$APPTYPE CONSOLE}
uses
Classes, Windows, ActiveX, ShellAPI;
var
hThread: THandle;
ThreadId: Cardinal;
function ThreadFunc(Parameter: Pointer): Integer;
var
shfi: TSHFileInfo;
begin
CoInitialize(nil);
Try
if ShGetFileInfo('C:\windows\explorer.exe', 0, shfi, SizeOf(shfi), SHGFI_ICON or SHGFI_LARGEICON)=0 then
begin
Writeln('ShGetFileInfo Failed');
Result := 1;
exit;
end;
Writeln(shfi.hIcon);
Finally
CoUninitialize;
End;
Result := 0;
end;
begin
hThread := BeginThread(nil, 0, ThreadFunc, nil, 0, ThreadId);
WaitForSingleObject(hThread, INFINITE);
CloseHandle(hThread);
Readln;
end.
I expect that any failure you observe is actually related to the particular file that you are trying to inspect.
Update: It seems ShGetFileInfo is not threadsafe. When there are multiple threads calling it simultaneously, it fails. I believe that you will need to serialize the calls to ShGetFileInfo with a lock. For instance, TCriticalSection.
The following program, based on the SSCCE you provided in the comments, demonstrates this:
{$APPTYPE CONSOLE}
uses
SysUtils,
Classes,
SyncObjs,
Windows,
ActiveX,
ShellAPI;
var
hThreads: TWOHandleArray;
ThreadId: Cardinal;
Lock: TCriticalSection;
function ThreadFunc(Parameter: Pointer): Integer;
var
shfi: TSHFileInfo;
randomnumber: integer;
fname: string;
begin
CoInitialize(nil);
Try
fname := 'c:\desktop\file'+IntToStr(Integer(Parameter))+'.exe';
Lock.Acquire;
try
if ShGetFileInfo(pchar(fname), 0, shfi, SizeOf(shfi), SHGFI_ICON or SHGFI_LARGEICON)=0 then
begin
Writeln('ShGetFileInfo Failed');
Result := 1;
exit;
end;
Writeln(shfi.hIcon);
finally
Lock.Release;
end;
Finally
CoUninitialize;
End;
Result := 0;
end;
var
i: integer;
begin
Lock := TCriticalSection.Create;
for i := 0 to 9 do
hThreads[i] := BeginThread(nil, 0, ThreadFunc, Pointer(i), 0, ThreadId);
WaitForMultipleObjects(10, #hThreads,true, INFINITE);
Readln;
end.
Remove the critical section, and the calls to ShGetFileInfo succeed, but return 0 for the icon handle. With the critical section, valid icon handles are returned.
I' programming a Delphi application. My goal is to cover ALL screen with my application to force user to fill my form. Application will be run as scheduled task.
My problem is, that normally, Windows does not allow applications to block other users action.
In Windows 7 I can run my application as scr file (screen saver), with no title bar and set StayOnTop. In this case, other application even if visible on "Window key" (start), stays behind my application, so my goal is reached.
Unfortunately, in Windows 8 this solution does not work because "window key" shows start screen, when I can run anything and this "anything" stays on top.
I tried some trick with code below, but without success.
h := FindWindowEx(FindWindow('Shell_TrayWnd', nil),0,'Button',nil);
ShowWindow(h,0);
Windows.SetParent(h,0);
How to block 'window key' (start button) action in the entire Windows 8 system?
I didn't test it on windows 8, but in principle one can use a keyboard hook to discard the key-press.
Something similar to the following:
const
WH_KEYBOARD_LL = 13;
LLKHF_ALTDOWN = $00000020;
LLKHF_INJECTED = $00000010;
type
tagKBDLLHOOKSTRUCT = record
vkCode: DWORD;
scanCode: DWORD;
flags: DWORD;
time: DWORD;
dwExtraInfo: DWORD;
end;
KBDLLHOOKSTRUCT = tagKBDLLHOOKSTRUCT;
LPKBDLLHOOKSTRUCT = ^KBDLLHOOKSTRUCT;
PKBDLLHOOKSTRUCT = ^KBDLLHOOKSTRUCT;
var
hhkLowLevelKybd: HHOOK;
function LowLevelKeyBoardProc(nCode: Integer; awParam: WPARAM; alParam: LPARAM): LRESULT; stdcall;
var
fEatKeyStroke: Boolean;
p: PKBDLLHOOKSTRUCT;
begin
fEatKeystroke := False;
if active and( nCode = HC_ACTION) then
begin
case awParam of
WM_KEYDOWN,
WM_SYSKEYDOWN,
WM_KEYUP,
WM_SYSKEYUP:
begin
p := PKBDLLHOOKSTRUCT(alParam);
if DisableWinKeys then
begin
if p^.vkCode = VK_LWIN
then fEatKeystroke := True;
if p^.vkCode = VK_RWIN
then fEatKeystroke := True;
end;
end;
end;
end;
if fEatKeyStroke then
Result := 1
else
Result := CallNextHookEx(hhkLowLevelKybd, nCode, awParam, alParam);
end;
procedure InstallHook;
begin
if hhkLowLevelKybd <> 0 then exit;
hhkLowLevelKybd := SetWindowsHookEx(WH_KEYBOARD_LL, #LowLevelKeyboardProc, hInstance, 0);
end;
procedure UninstallHook;
begin
if hhkLowLevelKybd = 0 then exit;
UnhookWindowsHookEx(hhkLowLevelKybd);
hhkLowLevelKybd := 0;
end;
What is the best way to find whether a web-browser is running?
Using Delphi XE2 and on Windows, I need to find whether the following web-browsers are currently running:
A) Mozilla Firefox
B) Apple Safari
C) Google Chrome
If found, the process will be terminated because the home page of the web-browser needs to be changed programmatically by modifying the web-browser configuration files (which is either not possible or could result in unpredictable results if done when the web-browser is running).
Does the output from the EnumWindows API function contain sufficient information needed to handle the above task? If yes, then are the window class names for each of the above web-browsers documented anywhere? If no, then which method is most reliable?
TIA.
Terminate a process without the user permission is not good practice, instead you must ask to the user if he wants terminate the app (in this case the web browser).
Now back to your question, you can detect if a app(webbroser) is running checking for the process name (firefox.exe, chrome.exe , safari.exe) using the CreateToolhelp32Snapshot method.
uses
Windows,
tlhelp32,
SysUtils;
function IsProcessRunning(const ListProcess: Array of string): boolean;
var
hSnapshot : THandle;
lppe : TProcessEntry32;
I : Integer;
begin
result:=false;
hSnapshot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
if hSnapshot <> INVALID_HANDLE_VALUE then
try
lppe.dwSize := SizeOf(lppe);
if Process32First(hSnapshot, lppe) then
repeat
for I := Low(ListProcess) to High(ListProcess) do
if SameText(lppe.szExeFile, ListProcess[i]) then
Exit(True);
until not Process32Next(hSnapshot, lppe);
finally
CloseHandle(hSnapshot);
end;
end;
and use like so
IsProcessRunning(['firefox.exe','chrome.exe','safari.exe'])
Now if you want a more reliable way you can search for the class name of the Window (using the FindWindowEx method) and then the PID of the process owner of the handle (using GetWindowThreadProcessId), from here you can use the PID of the process to resolve the name of exe.
{$APPTYPE CONSOLE}
uses
Windows,
tlhelp32,
SysUtils;
function GetProcessName(const th32ProcessID: DWORD): string;
var
hSnapshot : THandle;
lppe : TProcessEntry32;
begin
result:='';
hSnapshot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
if hSnapshot <> INVALID_HANDLE_VALUE then
try
lppe.dwSize := SizeOf(lppe);
if Process32First(hSnapshot, lppe) then
repeat
if lppe.th32ProcessID=th32ProcessID then
Exit(lppe.szExeFile);
until not Process32Next(hSnapshot, lppe);
finally
CloseHandle(hSnapshot);
end;
end;
function IsWebBrowserRunning(const ClassName, ExeName :string) : Boolean;
var
hWindow : THandle;
dwProcessId: DWORD;
begin
result:=False;
hWindow:= FindWindowEx(0, 0, PChar(ClassName), nil);
if hWindow<>0 then
begin
dwProcessId:=0;
GetWindowThreadProcessId(hWindow, dwProcessId);
if dwProcessId>0 then
exit(Sametext(GetProcessName(dwProcessId),ExeName));
end;
end;
begin
try
if IsWebBrowserRunning('MozillaWindowClass','firefox.exe') then
Writeln('Firefox is Running');
if IsWebBrowserRunning('{1C03B488-D53B-4a81-97F8-754559640193}','safari.exe') then
Writeln('Safari is Running');
if IsWebBrowserRunning('Chrome_WidgetWin_1','chrome.exe') then
Writeln('Chrome is Running');
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
readln;
end.
I've been using the value of key MachineGuid from HKEY_LOCAL_MACHINE\Software\Microsoft\Cryptography to uniquely identify hosts, but from 32-bit processes running on 64-bit computers, the value appears to be missing. I guess it's searching under Wow6432Node, where it is indeed missing. According to this you should be able to get to the right key by adding a flag, but below code still doesn't appear to do the job. What am I missing?
const
KEY_WOW64_64KEY=$0100;
var
r:HKEY;
s:string;
i,l:integer;
begin
//use cryptography machineguid, keep a local copy of this in initialization?
l:=40;
if RegOpenKeyEx(HKEY_LOCAL_MACHINE,PChar('Software\Microsoft\Cryptography'),
0,KEY_QUERY_VALUE,r)=ERROR_SUCCESS then
begin
SetLength(s,l);
if RegQueryValue(r,'MachineGuid',PChar(s),l)=ERROR_SUCCESS then
begin
SetLength(s,l);
RegCloseKey(r);
end
else
begin
//try from-32-to-64
RegCloseKey(r);
if RegOpenKeyEx(HKEY_LOCAL_MACHINE,PChar('Software\Microsoft\Cryptography'),
0,KEY_QUERY_VALUE or KEY_WOW64_64KEY,r)=ERROR_SUCCESS then
begin
l:=40;
if RegQueryValue(r,'MachineGuid',PChar(s),l)=ERROR_SUCCESS then
SetLength(s,l)
else
l:=0;
RegCloseKey(r);
end;
end;
end;
I would suggest you use the IsWow64Process() function to know when you are a 32-process running on a 64-bit OS, and then only apply the KEY_WOW64_64KEY flags in that specific condition. If the app is a 32-bit process on a 32-bit OS, or a 64-bit process on a 64-bit OS, the flags is not needed.
For example:
const
KEY_WOW64_64KEY = $0100;
var
key: HKEY;
str: string;
len: DWORD;
flag: REGSAM;
wow64: BOOL;
begin
flag := 0;
wow64 := 0;
IsWow64Process(GetCurrentProcess(), #wow64);
if wow64 <> 0 then flag := KEY_WOW64_64KEY;
if RegOpenKeyEx(HKEY_LOCAL_MACHINE, 'Software\Microsoft\Cryptography', 0, KEY_QUERY_VALUE or flag, key) = ERROR_SUCCESS then
try
SetLength(str, 40);
len := Length(str) * SizeOf(Char);
if RegQueryValueEx(key, 'MachineGuid', nil, nil, PByte(Pointer(s)), #len) <> ERROR_SUCCESS then len := 0;
SetLength(str, len div SizeOf(Char));
finally
RegCloseKey(key);
end;
end;
Your code is needlessly complex, largely because you are not taking advantage of the built-in TRegistry class which shields you from all the complexities of the low-level registry API. For example, consider the following code:
type
TRegistryView = (rvDefault, rvRegistry64, rvRegistry32);
function RegistryViewAccessFlag(View: TRegistryView): LongWord;
begin
case View of
rvDefault:
Result := 0;
rvRegistry64:
Result := KEY_WOW64_64KEY;
rvRegistry32:
Result := KEY_WOW64_32KEY;
end;
end;
function ReadRegStr(const Root: HKEY; const Key, Name: string;
const View: TRegistryView=rvDefault): string;
var
Registry: TRegistry;
begin
Registry := TRegistry.Create(KEY_READ or RegistryViewAccessFlag(View));
try
Registry.RootKey := Root;
if not Registry.OpenKey(Key) then
raise ERegistryException.CreateFmt('Key not found: %s', [Key]);
if not Registry.ValueExists(Name) then
raise ERegistryException.CreateFmt('Name not found: %s\%s', [Key, Name]);
Result := Registry.ReadString(Name);//will raise exception in case of failure
finally
Registry.Free;
end;
end;
The function ReadRegStr will return the string value named Name from the key Key relative to the root key Root. If there is an error, for example if the key or name do not exists, or if the value is of the wrong type, then an exception will be raised.
The View parameter is an enumeration that makes it simple for you to access native, 32-bit or 64-bit views of the registry. Note that native means native to the process that is running. So it will be the 32-bit view for a 32-bit process and the 64-bit view for a 64-bit process. This enumeration mirrors the equivalent definition in .net.
In my use of this registry key I went a step further. If the value didn't exist I created it: not in HKEY_LOCAL_MACHINE, that would require elevation, but in HKEY_CURRENT_USER. Anyone seeing the introduced key there is unlikely to realise that it's a dummy.
function GetComputerGUID: String;
var
Reg: TRegistry;
oGuid: TGUID;
sGuid: String;
begin
Result := '';
// Attempt to retrieve the real key
Reg := TRegistry.Create(KEY_READ OR KEY_WOW64_64KEY);
try
Reg.RootKey := HKEY_LOCAL_MACHINE;
if Reg.OpenKeyReadOnly('SOFTWARE\Microsoft\Cryptography') and Reg.ValueExists('MachineGuid') then
Result := Reg.ReadString('MachineGuid');
Reg.CloseKey;
finally
Reg.Free;
end;
// If retrieval fails, look for the surrogate
if Result = '' then begin
Reg := TRegistry.Create;
try
Reg.RootKey := HKEY_CURRENT_USER;
if Reg.OpenKey('SOFTWARE\Microsoft\Cryptography', True) then begin
if Reg.ValueExists('MachineGuid') then
Result := Reg.ReadString('MachineGuid')
else begin
// If the surrogate doesn't exist, create it
if CreateGUID(oGUID) = 0 then begin
sGuid := Lowercase(GUIDToString(oGUID));
Reg.WriteString('MachineGuid', Copy(sGuid, 2, Length(sGUID) - 2));
Result := Reg.ReadString('MachineGuid');
end;
end;
end;
Reg.CloseKey;
finally
Reg.Free;
end;
end;
if Result = '' then
raise Exception.Create('Unable to access registry value in GetComputerGUID');
end;
That's a good point from #Remy Lebeau - TeamB though; I should mod the above code appropriately.
Call reg.exe using this path
C:\Windows\sysnative\reg.exe
For example:
C:\Windows\sysnative\reg.exe QUERY "HKLM\SOFTWARE\JavaSoft\JDK" /v CurrentVersion
source: https://stackoverflow.com/a/25103599