Delphi Get the handle of a EXE - delphi

Heres an example of how I'm doing it right now :
var
Client : String;
Handle : Integer;
begin
Client := 'Window Name';
GetWindowThreadProcessId(FindWindow(nil, PAnsiChar(Client)), #ProcessId);
Handle := OpenProcess(PROCESS_ALL_ACCESS, False, ProcessId);
end;
I'd rather grab the Process's handle with its exe name...
Is this possible this?

Since the link provided by vcldeveloper is broken, here's the full function code that works without 3rd party components.
First we will find process id (PID), and then we'll get process handle by opening all access (since the OP mentioned in the comments he will need this for ReadProcessMemory functionality).
If the function for PID returns 0, it means that the process is most likely not running (or just not found in the running process list)
function GetPIDbyProcessName(processName:String):integer;
var
GotProcess: Boolean;
tempHandle: tHandle;
procE: tProcessEntry32;
begin
tempHandle:=CreateToolHelp32SnapShot(TH32CS_SNAPALL, 0);
procE.dwSize:=SizeOf(procE);
GotProcess:=Process32First(tempHandle, procE);
{$B-}
if GotProcess and not SameText(procE.szExeFile, processName) then
repeat GotProcess := Process32Next(tempHandle, procE);
until (not GotProcess) or SameText(procE.szExeFile,processName);
{$B+}
if GotProcess then
result := procE.th32ProcessID
else
result := 0; // process not found in running process list
CloseHandle(tempHandle);
end;
Next, we will get/open Process handle from the PID we got. The whole code/usage is as follows:
var myPID, myProcessHandle: integer;
begin
myPID:=GetPIDbyProcessName('someExeName.exe');
myProcessHandle:=OpenProcess(PROCESS_ALL_ACCESS,False,myPID);
end;
You should store the myProcessHandle in such way that it is accessable for ReadProcessMemory(myProcessHandle...) as first parameter.
Also, add these to your global uses clauses:
Winapi.Windows (for ReadProcessMemory and OpenProcess)
Winapi.tlHelp32(for getting PID tProcessEntry32 variable)

Application.Handle?
Looks like you're trying to program in Delphi by WinAPI. In the vast majority do not need it, VCL provides appropriate object-oriented wrappers.
May be You will find something in this component pack: GLibWMI

You can use ProcessInfo:
var
ProcessInfo : TProcessInfo;
Process : TProcessItem;
PID: Cardinal;
ProcessHandle : THandle;
begin
ProcessInfo := TProcessInfo.Create(nil);
try
Process := ProcessInfo.RunningProcesses.FindByName('Notepad.exe');
if Assigned(Process) then
begin
PID := Process.ProcessID;
ProcessHandle := OpenProcess(PROCESS_ALL_ACCESS,False,PID);
if ProcessHandle > 0 then
try
{Add your code here}
finally
CloseHandle(ProcessHandle);
end;
end;
finally
ProcessInfo.Free;
end;
end;
If you do not like using a third-party component, you can study source code of ProcessInfo to see how it retrieves list of running processes, and their properties. Basically it relays on Windows Tool Help API for most of its features.

Related

How to get the image path of all running processses as a standard user (XP / Server 2003 and below)?

I am trying to get the full path of all running processes in the system as a standard user without administrative rights on Windows XP / Server 2003. Getting the list of all running processes and handles to them is not a problem (Toolhelp "Process32First" / Native API "NtQuerySystemInformation" / PsApi "EnumProcesses"). My problem is that these calls do not return proper process handles, but some sort of handle that I first have to pass to "OpenProcess" to get a proper process handle that I then can use to query for the full image path (by calling "GetProcessImageFileName" or some low level function). But, for processes not started by the current user, "OpenProcess" fails if I am not an admin.
Can anybody point me in the rights direction on how to retrieve this information? Process Hacker and Process Explorer are able to do it, so it should be possible. I am aware that Process Hacker's source code is available, but as far as I understand it uses some sort of driver to query running processes.
Correction: As David Heffernan pointed out in his answer Process Explorer and Process Hacker do not display the full image path on Windows XP when started by a non admin user.
Here's the requested code (written in Delphi):
function GetProcessDetails (const th32ProcessID: THandle) : String;
var
szImageFileName : array [0..MAX_PATH] of Char;
hProcess : THandle;
begin
hProcess := OpenProcess (PROCESS_QUERY_INFORMATION or PROCESS_VM_READ,
false, th32ProcessID);
if (hProcess = 0) then
exit;
if (GetProcessImageFileName (hProcess, #szImageFileName [0],
MAX_PATH) > 0) then
Result := szImageFileName;
CloseHandle (hProcess);
end; { GetProcessDetails }
And here's the function that uses "Process32First / Process32Next" to retrieve the process information:
procedure FillProcessListToolHelp;
var
hSnapShot : THandle;
PE : TProcessEntry32;
sImageFileName : String;
begin
hSnapShot := CreateToolhelp32Snapshot (TH32CS_SNAPPROCESS, 0);
PE.dwSize := SizeOf (TProcessEntry32);
if (Process32First (hSnapShot, PE)) then
repeat
if (PE.th32ProcessID <> 0) then
sImageFileName := GetProcessDetails (PE.th32ProcessID);
until (Process32Next (hSnapShot, PE) = false);
CloseHandle (hSnapShot);
end; { FillProcessListToolHelp }
Please be aware that "SeDebugPrivilege" has been assigned before making the call to "FillProcessListToolHelp". Also, right now I am only interested in a solution for 32 bit Windows.
The code that you present works as intended and is the best that you can do. You can add a little more diagnostics to it to see better what is going on:
hProcess := OpenProcess (PROCESS_QUERY_INFORMATION or PROCESS_VM_READ,
false, th32ProcessID);
if (hProcess = 0) then
begin
Writeln(IntToStr(GetLastError));
exit;
end;
What you will then learn is that when OpenProcess is failing, it is because GetLastError is returning 5, aka ERROR_ACCESS_DENIED. And that is because, as you yourself have identified, the processes in question are owned by a different user.
Windows security means that your standard user process is simply unable to open a handle to these processes with the necessary access rights. If you wish to obtain information about these processes you will need to execute your code with sufficient privileges, for example by running as administrator.
I believe that the best you can do without admin privileges is to use the information returned in the szExeFile member of TProcessEntry32.
{$APPTYPE CONSOLE}
uses
System.SysUtils, Winapi.Windows, Winapi.TlHelp32;
function GetProcessImageFileName(hProcess: THandle; lpImageFileName: LPTSTR;
nSize: DWORD): DWORD; stdcall;
external 'PSAPI.dll' name 'GetProcessImageFileNameW';
function ImageFileName(const PE: TProcessEntry32): string;
var
szImageFileName: array [0 .. MAX_PATH] of Char;
hProcess: THandle;
begin
Result := PE.szExeFile; // fallback in case the other API calls fail
hProcess := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, false,
PE.th32ProcessID);
if (hProcess = 0) then
exit;
if (GetProcessImageFileName(hProcess, #szImageFileName[0], MAX_PATH) > 0) then
Result := szImageFileName;
CloseHandle(hProcess);
end;
procedure FillProcessListToolHelp;
var
hSnapShot: THandle;
PE: TProcessEntry32;
begin
hSnapShot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
PE.dwSize := SizeOf(TProcessEntry32);
if (Process32First(hSnapShot, PE)) then
repeat
if (PE.th32ProcessID <> 0) then
Writeln(ImageFileName(PE));
until (Process32Next(hSnapShot, PE) = false);
CloseHandle(hSnapShot);
end;
begin
FillProcessListToolHelp;
Readln;
end.
Now, in the question you state:
Process Hacker and Process Explorer are able to do it, so it should be possible.
But that is not the case. At least for Process Explorer which is what I use. Here's what Process Explorer, when running as standard user, has to offer for the smss process:
Having just tried out Process Hacker, I can see that it will yield the information you want, even when not running elevated. So if you wish to do this yourself you simply need to read the Process Hacker and do what it does.

Named Pipes from Windows Service to Client Application

My story is that I am designing a new app which must communicate with a Windows service. After much research I have come to the conclusion that Named Pipes are the recommended method ( How do I send a string from one instance of my Delphi program to another? ) however, it appears that I can't use SendMessage or Named Pipes in Win7 due to security problems... the messages never reach outside the service to the application.
I am using the Russell Libby's named Pipe components, which work without a hitch between normal desktop apps, but the Windows service seems to be throwing a wrench in the solution. Further research tells me that it may be possible to open up security on both sides to let them communicate, however, my knowledge level on this is minimal at best, and I haven't been able to make heads or tails of the possible API calls.
Based on the Delphi component pipes.pas, what needs to be done to open up this baby so both sides can start talking? I'm sure the following two functions from the pipes.pas file identify the security attributes, is anyone able to help me out here?
Thanks!
procedure InitializeSecurity(var SA: TSecurityAttributes);
var
sd: PSecurityDescriptor;
begin
// Allocate memory for the security descriptor
sd := AllocMem(SECURITY_DESCRIPTOR_MIN_LENGTH);
// Initialize the new security descriptor
if InitializeSecurityDescriptor(sd, SECURITY_DESCRIPTOR_REVISION) then
begin
// Add a NULL descriptor ACL to the security descriptor
if SetSecurityDescriptorDacl(sd, True, nil, False) then
begin
// Set up the security attributes structure
SA.nLength := SizeOf(TSecurityAttributes);
SA.lpSecurityDescriptor := sd;
SA.bInheritHandle := True;
end
else
// Failed to init the sec descriptor
RaiseWindowsError;
end
else
// Failed to init the sec descriptor
RaiseWindowsError;
end;
procedure FinalizeSecurity(var SA: TSecurityAttributes);
begin
// Release memory that was assigned to security descriptor
if Assigned(SA.lpSecurityDescriptor) then
begin
// Reource protection
try
// Free memory
FreeMem(SA.lpSecurityDescriptor);
finally
// Clear pointer
SA.lpSecurityDescriptor := nil;
end;
end;
end;
Windows Vista, Seven and 2008 enforce a more secure use of named pipes, see for example http://blogs.technet.com/b/nettracer/archive/2010/07/23/why-does-anonymous-pipe-access-fail-on-windows-vista-2008-windows-7-or-windows-2008-r2.aspx
When we migrated our product from Win 2K to Win7, we ran our Named Pipes quit working. After 2 weeks talking with MS (and $275), we discovered it was being caused by the Use Shared Folders file settings. Unchecking this feature allowed us to continue with pipes.
I tried to implement this one:
function GetUserSid(var SID: PSID; var Token: THandle): boolean;
var TokenUserSize: DWORD;
TokenUserP: PSIDAndAttributes;
begin
result := false;
if not OpenThreadToken(GetCurrentThread, TOKEN_QUERY, True, Token) then
if (GetLastError <> ERROR_NO_TOKEN) or
not OpenProcessToken(GetCurrentProcess, TOKEN_QUERY, Token) then
Exit;
TokenUserP := nil;
TokenUserSize := 0;
try
if not GetTokenInformation(Token, TokenUser, nil, 0, TokenUserSize) and
(GetLastError <> ERROR_INSUFFICIENT_BUFFER) then
Exit;
TokenUserP := AllocMem(TokenUserSize);
if not GetTokenInformation(Token, TokenUser, TokenUserP,
TokenUserSize, TokenUserSize) then
Exit;
SID := TokenUserP^.Sid;
result := true;
finally
FreeMem(TokenUserP);
end;
end;
function ConvertSidToStringSidA(aSID: PSID; var aStr: PAnsiChar): BOOL; stdcall; external advapi32;
function ConvertStringSecurityDescriptorToSecurityDescriptorA(
StringSecurityDescriptor: PAnsiChar; StringSDRevision: DWORD;
SecurityDescriptor: pointer; SecurityDescriptorSize: Pointer): BOOL; stdcall; external advapi32;
const
SDDL_REVISION_1 = 1;
procedure InitializeSecurity(var SA: TSecurityAttributes; var SD; Client: boolean);
var OK: boolean;
Token: THandle;
pSidOwner: PSID;
pSid: PAnsiChar;
SACL: AnsiString;
begin
fillchar(SD,SECURITY_DESCRIPTOR_MIN_LENGTH,0);
// Initialize the new security descriptor
OK := false;
if InitializeSecurityDescriptor(#SD, SECURITY_DESCRIPTOR_REVISION) then begin
if Client or (OSVersionInfo.dwMajorVersion<6) then
// before Vista: add a NULL descriptor ACL to the security descriptor
OK := SetSecurityDescriptorDacl(#SD, true, nil, false)
else begin
// since Vista: need to specify special ACL
if GetUserSid(pSidOwner,Token) then
try
if ConvertSidToStringSidA(pSidOwner,pSid) then
try
SACL := 'D:(A;;GA;;;'+pSID+')(A;;GWGR;;;AN)(A;;GWGR;;;WD)S:(ML;;NW;;;S-1-16-0)';
OK := ConvertStringSecurityDescriptorToSecurityDescriptorA(
pointer(SACL),SDDL_REVISION_1,#SD,nil);
finally
LocalFree(PtrUInt(pSid));
end;
finally
FreeSid(pSidOwner);
CloseHandle(Token);
end;
end;
end;
if OK then begin
// Set up the security attributes structure
SA.nLength := sizeof(TSecurityAttributes);
SA.bInheritHandle := true;
SA.lpSecurityDescriptor := #SD;
end else
fillchar(SA,sizeof(SA),0); // mark error: no security
end;
It seems to work on the server side (i.e. the security attributes are created as expected), and you will have to write the client side code, without forgetting to add the pipe name in SYSTEM\CurrentControlSet\Services\lanmanserver\parameters\NullSessionPipes registry key, as expected.
I seem to remember that RemObjects has a named pipe client/server control in their package. Unless you are on a budget I would strongly recommend that you have a look at finished components for things like this. It is both time consuming and tricky to get right.
Alternatively, Justin Smyth has an article on named pipes right now. Check out his blog on the subject here: http://smythconsulting.blogspot.com/2011/07/smartmediaplayer-pipes-part4.html
Good luck!
I had the same kind of problem and just solved it. For me the reason it didn't work was because Russels TPipe implementetion has a check on the threads ID's just before the Pipe gets created: if not(Sync.SyncBaseTID = FNotifyThread) then..
It turned out I was creating the TPipeServer at the wrong place in my service. (I overrided DoStart etc instead of using the event OnStart... don't do that!)
I am now creating the TPipeServer instance in the same thread I later on activate it in.

WM_COPYDATA string not appearing in target application

I'm trying to pass information between two of my applications in Delphi 2010.
I'm using a simplified version of code that I've used successfully in the past (simplified because I don't need the sender to know that the send has been successful) I've boiled down the send received to a pair of example applications, which in essence are as follows
Send
procedure TMF.SendString;
var
copyDataStruct: TCopyDataStruct;
s: AnsiString;
begin
s := ebFirm.Text;
copyDataStruct.cbData := 1 + length(s);
copyDataStruct.lpData := PAnsiChar(s);
SendData(copyDataStruct);
end;
procedure TMF.SendData(copyDataStruct: TCopyDataStruct);
var
rh: THandle;
res: integer;
begin
rh := FindWindow(PChar('TMF'), PChar('Get Phone'));
if rh = 0 then
begin
// Launch the target application
ShellExecute(Handle, 'open', GetPhone, nil, nil, SW_SHOWNORMAL);
// Give time for the application to launch
Sleep(3000);
SendData(copyDataStruct); // RECURSION!
end;
SendMessage(rh, WM_COPYDATA, Integer(Handle), Integer(#copyDataStruct));
end;
Receive Application
procedure TMF.WMCopyData(var Msg: TWMCopyData);
var
s : AnsiString;
begin
s := PAnsiChar(Msg.CopyDataStruct.lpData) ;
jobstatus.Panels[1].Text := s;
end;
The major difference between the working test applications and the application I am adding the code to is that there is a lot of extra activity going on in target application. Especially on startup.
Any suggestions on why the WMCopyData procedure seems not to be firing at all?
CHeers
Dan
There are a few problems with your code.
One, you are not assigning a unique ID to the message. The VCL, and various third-party components, also use WM_COPYDATA, so you have to make sure you are actually processing YOUR message and not SOMEONE ELSE'S message.
Two, you may not be waiting long enough for the second app to start. Instead of Sleep(), use ShellExecuteEx() with the SEE_MASK_WAITFORINPUTIDLE flag (or use CreateProcess() and WaitForInputIdle()).
Third, when starting the second app, your recursive logic is attempting to send the message a second time. If that happened to fail, you would launch a third app, and so on. You should take out the recursion altogether, you don't need it.
Try this:
var
GetPhoneMsg: DWORD = 0;
procedure TMF.SendString;
var
copyDataStruct: TCopyDataStruct;
s: AnsiString;
begin
if GetPhoneMsg = 0 then Exit;
s := ebFirm.Text;
copyDataStruct.dwData := GetPhoneMsg;
copyDataStruct.cbData := Length(s);
copyDataStruct.lpData := PAnsiChar(s);
SendData(copyDataStruct);
end;
procedure TMF.SendData(copyDataStruct: TCopyDataStruct);
var
rh: HWND;
si: TShellExecuteInfo;
res: Integer;
begin
rh := FindWindow(PChar('TMF'), PChar('Get Phone'));
if rh = 0 then
begin
// Launch the target application and give time to start
ZeroMemory(#si, SizeOf(si));
si.cbSize := SizeOf(si);
si.fMask := SEE_MASK_WAITFORINPUTIDLE;
si.hwnd := Handle;
si.lpVerb := 'open';
si.lpFile := GetPhone;
si.nShow := SW_SHOWNORMAL;
if not ShellExecuteEx(#si) then Exit;
rh := FindWindow(PChar('TMF'), PChar('Get Phone'));
if rh = 0 then Exit;
end;
SendMessage(rh, WM_COPYDATA, WParam(Handle), LParam(#copyDataStruct));
end;
initialization
GetPhoneMsg := RegisterWindowMessage('TMF_GetPhone');
Receive Application
var
GetPhoneMsg: DWORD = 0;
procedure TMF.WMCopyData(var Msg: TWMCopyData);
var
s : AnsiString;
begin
if (GetPhoneMsg <> 0) and (Msg.CopyDataStruct.dwData = GetPhoneMsg) then
begin
SetString(s, PAnsiChar(Msg.CopyDataStruct.lpData), Msg.CopyDataStruct.cbData);
jobstatus.Panels[1].Text := s;
end else
inherited;
end;
initialization
GetPhoneMsg := RegisterWindowMessage('TMF_GetPhone');
I think it is a good habit to add
copyDataStruct.dwData := Handle;
in procedure TMF.SendString; - if you don't have a custom identifier, putting the source HWND value will help debugging on the destination (you can check for this value in the other side, and therefore avoid misunderstand of broadcasted WMCOPY_DATA e.g. - yes, there should not be, but I've seen some!).
And
procedure WMCopyData(var Msg : TWMCopyData); message WM_COPYDATA;
in TMF client class definition, right?
There should be a missing exit or else after the nested SendData call:
procedure TMF.SendData(copyDataStruct: TCopyDataStruct);
(...)
Sleep(3000);
SendData(copyDataStruct);
end else
SendMessage(rh, WM_COPYDATA, NativeInt(Handle), NativeInt(#copyDataStruct));
end;
But this won't change much.
Check the rh := FindWindow() returned handle: is it the Handle of the TMF client form, or the Application.Handle?
It doesn't work anymore if you are using Windows 7.
If you are using it, check this page to see how to add an exception: http://msdn.microsoft.com/en-us/library/ms649011%28v=vs.85%29.aspx
I thought there was a problem with the (rh) handle being 0 when you call it, if the app needed to be started. But now I see that SendData calls itself recursively. I added a comment in the code for that, as it was non-obvious. But now there's another problem. The 2nd instance of SendData will have the right handle. But then you're going to pop out of that, back into the first instance where the handle is still 0, and then you WILL call SendMessage again, this time with a 0 handle. This probably is not the cause of your trouble, but it's unintended, unnecessary, and altogether bad. IMO, this is a case complicating things by trying to be too clever.

Catch the start applications

How to catch the start and completion of applications (processes) in Win.
How to measure the time of each application?
You can use the GetProcessTimes function to get timing information for a particular process.
BOOL WINAPI GetProcessTimes(
__in HANDLE hProcess,
__out LPFILETIME lpCreationTime,
__out LPFILETIME lpExitTime,
__out LPFILETIME lpKernelTime,
__out LPFILETIME lpUserTime
);
See this example
program GetProcessTime;
{$APPTYPE CONSOLE}
uses
DateUtils,
Windows,
tlhelp32,
SysUtils;
Procedure GetAllProcessTime;
var
HandleSnapShot : THandle;
EntryParentProc : TProcessEntry32;
DummyCreateFileTime : Windows.FILETIME;
DummyExitFileTime : Windows.FILETIME;
DummyKernelFileTime : Windows.FILETIME;
DummyUserFileTime : Windows.FILETIME;
aFileName : String;
h : THandle;
ActualTime : TDateTime;
Dif : TDateTime;
CreationTime : TDateTime;
function FileTime2DateTime(FileTime: TFileTime): TDateTime; //Convert then FileTime to TDatetime format
var
LocalTime: TFileTime;
DOSTime : Integer;
begin
FileTimeToLocalFileTime(FileTime, LocalTime);
FileTimeToDosDateTime(LocalTime, LongRec(DOSTime).Hi, LongRec(DOSTime).Lo);
Result := FileDateToDateTime(DOSTime);
end;
begin
HandleSnapShot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0); //get the list of process
if HandleSnapShot <> INVALID_HANDLE_VALUE then
begin
EntryParentProc.dwSize := SizeOf(EntryParentProc);
if Process32First(HandleSnapShot, EntryParentProc) then //Get the first process in the list
begin
Writeln( Format('%-30s %-20s %-16s',['FileName','Start','Running Time']) );
ActualTime:=Now;
repeat
h:=OpenProcess(PROCESS_QUERY_INFORMATION,false,EntryParentProc.th32ProcessID); //open a particular process
if GetProcessTimes(h, DummyCreateFileTime, DummyExitFileTime, DummyKernelFileTime, DummyUserFileTime) then //get the timing info
begin
aFileName:=ExtractFileName(EntryParentProc.szExeFile);
CreationTime:=FileTime2DateTime(DummyCreateFileTime); //get the initial time of the process
Dif := ActualTime-CreationTime; //calculate the elapsed time
Writeln( Format('%-30s %-20s %-16s',[aFileName,FormatDateTime('DD-MM-YYYY HH:NN:SS',CreationTime),FormatDateTime('HH:NN:SS',Dif)]) );
end;
CloseHandle(h);
until not Process32Next(HandleSnapShot, EntryParentProc);
end;
CloseHandle(HandleSnapShot);
end;
end;
begin
try
GetAllProcessTime();
Readln;
except
on E: Exception do
begin
Writeln(E.ClassName, ': ', E.Message);
Readln;
end;
end;
end.
There are a couple or so Windows API calls with 'hook' in the name that allow you to capture systemwide events. You'll have to build those into a DLL, and then make calls to the 'hooking' DLL from a separate application.
That, VERY briefly, is it. Hope that gets you started!
Windows Performance Analyzer has features specifically for timing applications from the moment they start, even if they're in the boot or log-in sequence.
the WH_CBT hook is most likely the one you are after. It allows you to be notified by the OS whenever a window is created or destroyed. You will want to use this hook to grab the handle and from the handle get the process id using GetWindowThreadProcessId. You can then pass this handle to the function GetProcessTimes (suggested by RRUZ) to get the times. An example (although dated, the concepts are still the same) is available in the GpSysHook source.
Windows Management Instrumentation offers event subscription. The nice thing with WMI is that it works remote too, using DCOM and SOAP.
WMI offers the capability to notify a subscriber for any event it is interested in.
WMI uses the WMI Query Language (WQL)
to submit WQL event queries and
defines the type of events to be
returned. The eventing mechanism, with
all related callbacks, is part of the
WMI COM/DCOM and automation
interfaces.
A free WMI client implementation for Delphi is available online (not sure if it supports event callbacks):
Magenta Systems WMI and SMART Component

Determine if running as VCL Forms or Service

I have code which is used both in services and within VCL Form applications (win32 application). How can I determine if the underlying application is running as a NT Service or as an application?
Thanks.
BEGIN OF EDIT
Since this still seems to be getting some attention I decided to update the answer with missing info and newer windows patches. In any case you should not copy / paste the code. The code is just a showcase on how the things should be done.
END OF EDIT:
You can check if the parent process is SCM (service control manager). If you are running as service this is always the case and never the case if running as standard application. Also I think that SCM has always the same PID.
You can check it like this:
type
TAppType = (atUnknown, atDesktop, atService);
var
AppType: TAppType;
function InternalIsService: Boolean;
var
PL: TProcessList;
MyProcessId: DWORD;
MyProcess: PPROCESSENTRY32;
ParentProcess: PPROCESSENTRY32;
GrandParentProcess: PPROCESSENTRY32;
begin
Result := False;
PL := TProcessList.Create;
try
PL.CreateSnapshot;
MyProcessId := GetCurrentProcessId;
MyProcess := PL.FindProcess(MyProcessId);
if MyProcess <> nil then
begin
ParentProcess := PL.FindProcess(MyProcess^.th32ParentProcessID);
if ParentProcess <> nil then
begin
GrandParentProcess := PL.FindProcess(ParentProcess^.th32ParentProcessID);
if GrandParentProcess <> nil then
begin
Result := SameText(string(ParentProcess^.szExeFile), 'services.exe') and
(SameText(string(GrandParentProcess^.szExeFile), 'winlogon.exe') or
SameText(string(GrandParentProcess^.szExeFile), 'wininit.exe'));
end;
end;
end;
finally
PL.Free;
end;
end;
function IsService: Boolean;
begin
if AppType = atUnknown then
begin
try
if InternalIsService then
AppType := atService
else
AppType := atDesktop;
except
AppType := atService;
end;
end;
Result := AppType = atService;
end;
initialization
AppType := atUnknown;
The TProcessList is implemented like this (again THashTable is not included but any hash table should be fine):
type
TProcessEntryList = class(TList)
private
function Get(Index: Integer): PPROCESSENTRY32;
procedure Put(Index: Integer; const Value: PPROCESSENTRY32);
public
property Items[Index: Integer]: PPROCESSENTRY32 read Get write Put; default;
function Add(const Entry: TProcessEntry32): Integer; reintroduce;
procedure Clear; override;
end;
TProcessList = class
private
ProcessIdHashTable: THashTable;
ProcessEntryList: TProcessEntryList;
public
constructor Create; reintroduce;
destructor Destroy; override;
procedure CreateSnapshot;
function FindProcess(const ProcessId: DWORD): PPROCESSENTRY32;
end;
implementation
{ TProcessEntryList }
procedure TProcessEntryList.Clear;
var
i: Integer;
begin
i := 0;
while i < Count do
begin
FreeMem(Items[i]);
Inc(i);
end;
inherited;
end;
procedure TProcessEntryList.Put(Index: Integer; const Value: PPROCESSENTRY32);
var
Item: Pointer;
begin
Item := inherited Get(Index);
CopyMemory(Item, Value, SizeOf(tagPROCESSENTRY32));
end;
function TProcessEntryList.Get(Index: Integer): PPROCESSENTRY32;
begin
Result := PPROCESSENTRY32(inherited Get(Index));
end;
function TProcessEntryList.Add(const Entry: TProcessEntry32): Integer;
var
EntryCopy: PPROCESSENTRY32;
begin
GetMem(EntryCopy, SizeOf(tagPROCESSENTRY32));
CopyMemory(EntryCopy, #Entry, SizeOf(tagPROCESSENTRY32));
Result := inherited Add(EntryCopy);
end;
{ TProcessList }
constructor TProcessList.Create;
begin
inherited;
ProcessEntryList := TProcessEntryList.Create;
ProcessIdHashTable := THashTable.Create;
end;
destructor TProcessList.Destroy;
begin
FreeAndNil(ProcessIdHashTable);
FreeAndNil(ProcessEntryList);
inherited;
end;
function TProcessList.FindProcess(const ProcessId: DWORD): PPROCESSENTRY32;
var
ItemIndex: Integer;
begin
Result := nil;
if not ProcessIdHashTable.ContainsKey(IntToStr(ProcessId)) then
Exit;
ItemIndex := Integer(ProcessIdHashTable.Item[IntToStr(ProcessId)]);
Result := ProcessEntryList.Items[ItemIndex];
end;
procedure TProcessList.CreateSnapshot;
var
SnapShot: THandle;
ProcessEntry: TProcessEntry32;
ItemIndex: Integer;
begin
SnapShot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
if SnapShot <> 0 then
try
ProcessEntry.dwSize := SizeOf(ProcessEntry);
if Process32First(SnapShot, ProcessEntry) then
repeat
ItemIndex := ProcessEntryList.Add(ProcessEntry);
ProcessIdHashTable.Add(IntToStr(ProcessEntry.th32ProcessID), TObject(ItemIndex));
until not Process32Next(SnapShot, ProcessEntry);
finally
CloseHandle(SnapShot);
end;
end;
The application object (Forms.application) mainform will be nil if it is not a forms based application.
uses
Forms, ... ;
function IsFormBased : boolean;
begin
Result := Assigned(Forms.Application.MainForm);
end;
How about matching GetCurrentProcessId against EnumServicesStatusEx?
The lpServices parameter points to a buffer that receives an array of ENUM_SERVICE_STATUS_PROCESS structures.
The match is done against the enumerated service process ID: ServiceStatusProcess.dwProcessId in that structure.
Another option is using WMI to query for Win32_Service instances where ProcessId=GetCurrentProcessId.
I doubt that
System.IsConsole
System.IsLibrary
will give you the expected results.
All I can think of is to pass an Application object as TObject to the method where you need to make that distinction and test for the passed object's classname being a
TServiceApplication
or
TApplication
That said, there shouldn't be a need for you to know if your code is running in a service or a GUI. You should probably rethink your design and make the caller to pass an object to handle messages you want (or don't want) to show. (I assume it is for showing messages/exceptions you'd like to know).
You can try something like this
Function IsMyformInsideaWindowsService(aForm:TObject) :Boolean;
Begin
Result:=aForm.ClassParent.ClassName='TService'; //When a form is running under a service the Class Parent is a TService
End;
A single project cannot (or I should say ideally is not) both a service and a forms application, at least not if you are able to distinguish between the Forms Application object and the SvcMgr Application object - you must presumably have separate projects for the forms code and the service code.
So perhaps the easiest solution is a project conditional define. i.e. in your project settings for the service project add "SERVICEAPP" to the Conditional Defines.
Then whenever you need to change behaviour simply:
{$ifdef SERVICEAPP}
{$else}
{$endif}
For belts and braces you might adopt one of the previously described tests within some startup code to ensure that your project has been compiled with the expected symbol defined.
program ... ;
:
begin
{$ifdef SERVICEAPP}
// test for service app - ASSERT if not
{$else}
// test for forms app - ASSERT if not
{$endif}
:
end.
It is possible that your Forms app is actually running as a service, using the crude technique that allows any application to be running as a service.
In that case of course your app will always be a Forms application and the easiest way to handle that situation is to have a command line switch that you specify only in the service definition for your executable so that your app can respond appropriate by testing for that command line switch.
This does allow you to more easily test your "service mode" behaviour of course, since you can run your app in "debug" mode with that switch defined from within the IDE, but it's not an ideal way to build a service application so I would not recommend it on the strength of that alone. It's a technique that is usually only used when you have an EXE that you wish to run as a service but have no way to modify the source code to turn it into a "proper" service.
The answer from "Runner" ( https://stackoverflow.com/a/1568462 ) looked very helpful, but I could not use it since neither TProcessList, nor CreateSnapshot is defined. Searching for "TProcessList CreateSnapshot" in Google will just find 7 pages, including this one and mirrors/quotes of this page. No code exists. Alas, my reputation is too low to send him a comment, asking where I can find the code of TProcessList.
Another problem: At my computer (Win7 x64), the "services.exe" is NOT inside "winlogon.exe". It is inside "wininit.exe". Since it seems to be an implementation detail of Windows, I would suggest not querying the grand parent. Also, services.exe does not need to be the direct parent, since processes could be forked.
So this is my version using TlHelp32 directly, solving all the problems:
uses
Classes, TlHelp32;
function IsRunningAsService: boolean;
function FindProcess(FSnapshotHandle: THandle; PID: DWORD; var lppe: TProcessEntry32): boolean;
var
ContinueLoop: BOOL;
begin
ContinueLoop := Process32First(FSnapshotHandle, lppe);
while Integer(ContinueLoop) <> 0 do
begin
if lppe.th32ProcessID = PID then
begin
result := true;
Exit;
end;
ContinueLoop := Process32Next(FSnapshotHandle, lppe);
end;
result := false;
end;
var
CurProcessId: DWORD;
FSnapshotHandle: THandle;
FProcessEntry32: TProcessEntry32;
ExeName, PrevExeName: string;
DeadlockProtection: TList<Integer>;
begin
Result := false;
FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
DeadlockProtection := TList<Integer>.Create;
try
CurProcessId := GetCurrentProcessId;
FProcessEntry32.dwSize := SizeOf(FProcessEntry32);
ExeName := '';
while FindProcess(FSnapshotHandle, CurProcessId, FProcessEntry32) do
begin
if DeadlockProtection.IndexOf(FProcessEntry32.th32ProcessID) > -1 then break;
DeadlockProtection.Add(FProcessEntry32.th32ProcessID);
PrevExeName := ExeName;
ExeName := FProcessEntry32.szExeFile;
(*
Result := SameText(PrevExeName, 'services.exe') and // Parent
SameText(ExeName, 'winlogon.exe'); // Grandparent
*)
Result := SameText(ExeName, 'services.exe'); // Parent
if Result then Exit;
CurProcessId := FProcessEntry32.th32ParentProcessID;
end;
finally
CloseHandle(FSnapshotHandle);
DeadlockProtection.Free;
end;
end;
This code works, also even in applications without MainForm (e.g. CLI apps).
you can use GetStdHandle method for get out console handle.when applications run as windows service has not output console.if GetStdHandle equals zero means your application run as windows service.
{$APPTYPE CONSOLE} // important
uses
uServerForm in 'uServerForm.pas' {ServerForm},
uWinService in 'uWinService.pas' {mofidWinServer: TService},
Windows,
System.SysUtils,
WinSvc,
SvcMgr,
Forms,etc;
function RunAsWinService: Boolean;
var
H: THandle;
begin
if FindCmdLineSwitch('install', ['-', '/'], True) then
Exit(True);
if FindCmdLineSwitch('uninstall', ['-', '/'], True) then
Exit(True);
H := GetStdHandle(STD_OUTPUT_HANDLE);
Result := H = 0;
end;
begin
if RunAsWinService then
begin
SvcMgr.Application.Initialize;
SvcMgr.Application.CreateForm(TmofidWinServer, mofidWinServer);
SvcMgr.Application.Run;
end
else
begin
Forms.Application.Initialize;
Forms.Application.CreateForm(TServerForm, ServerForm);
Forms.Application.Run;
end;
end.
I didn't find the simple answer which can be used easily and does not require recompilation and allows using one exe as a service and an application. You can install your program as a service with the command line parameter like ā€œā€¦\myapp.exe ā€“sā€ and then check it from the program:
if ParamStr(ParamCount) = '-s' then
You can base the check on checking the session ID of the current process. All services runs with session ID = 0.
function IsServiceProcess: Boolean;
var
LSessionID, LSize: Cardinal;
LToken: THandle;
begin
Result := False;
LSize := 0;
if not OpenProcessToken(GetCurrentProcess, TOKEN_QUERY, LToken) then
Exit;
try
if not GetTokenInformation(LToken, TokenSessionId, #LSessionID, SizeOf(LSessionID), LSize) then
Exit;
if LSize = 0 then
Exit;
Result := LSessionID = 0;
finally
CloseHandle(LToken);
end;
end;
I actually ended up checking the application.showmainform variable.
The problem with skamradt's isFormBased is that some of this code is called before the main form is created.
I am using a software library called SvCom_NTService from aldyn-software. One of purposes is for errors; either to log them or show a message. I totally agree with #Rob; our code should be better maintained and handle this outside of the functions.
The other intention is for failed database connections and queries; I have different logic in my functions to open queries. If it is a service then it will return nil but continue the process. But if failed queries/connections occur in an application then I would like to display a messaage and halt the application.
Check if your Applicatoin is an instance of TServiceApplication:
IsServiceApp := Application is TServiceApplication;

Resources