I have the following code which creates an instance of an RemObjects service and makes a call to a .net server
class function TLabelPrintingServiceProxy.GetInstance: ILabelPrintingManager;
var
LRoRemoteService: TRoRemoteService;
begin
LRoRemoteService := TRoRemoteService.Create(nil);
LRoRemoteService.Message := TROSOAPMessage.Create();
LRoRemoteService.Channel := TROIndyHTTPChannel.Create(nil);
LRoRemoteService.Channel.TargetUri := TROUri.Create(ILabelPrintingIntf.LabelPrintingManager_EndPointURI);
Result := (LRoRemoteService as ILabelPrintingManager);
end;
call to the .net service is performed like this:
try
Result := BinaryArray.Create;
LLabelPrintingManager := TLabelPrintingServiceProxy.GetInstance();
Result.Add(LLabelPrintingManager.GetVSSLabelImage(APrintJob));
finally
TLabelPrintingServiceProxy.ReleaseLabelPrintingServiceProxyInstance(LLabelPrintingManager);
end;
After the call is made the LLabelPrintingManager interface should be released automatically by RemObjects, but it isn't and leaks the objects used.
I've tried on the ReleaseLabelPrintingServiceProxyInstance (code bellow) to release manually all the objects from the service instance, but it's still leaking
class procedure TLabelPrintingServiceProxy.ReleaseLabelPrintingServiceProxyInstance(aILabelPrintingManagerIntf: ILabelPrintingManager);
var
lProxy: TRoProxy;
begin
lProxy := TROProxy(aILabelPrintingManagerIntf);
TROIndyHTTPChannel(lProxy.__TransportChannel).TargetUri.Free;
// TROIndyHTTPChannel(lProxy.__TransportChannel).Free; this is generating an AV
TRoMessage(lProxy.__Message).free;
TRoRemoteService(aILabelPrintingManagerIntf).Free;
I'm missing something?
After discussing with guys from RemObjects, here is the solution:
class function TLabelPrintingServiceProxy.GetRemoteServiceInstance: TRoRemoteService;
var
LRoRemoteService: TRoRemoteService;
begin
Result := TRoRemoteService.Create(nil);
Result.Message := TROSOAPMessage.Create();
Result.Channel := TROIndyHTTPChannel.Create(nil);
Result.Channel.TargetUri := TROUri.Create(ILabelPrintingIntf.LabelPrintingManager_EndPointURI);
end;
call
try
LLabelPrintingRemoteService := TLabelPrintingServiceProxy.GetRemoteServiceInstance();
(LLabelPrintingRemoteService as ILabelPrintingManager).PrintVSSJob(printJob);
finally
TLabelPrintingServiceProxy.ReleaseLabelPrintingServiceProxyInstance(LLabelPrintingRemoteService);
end;
and releasing the objects
try
LLabelPrintingRemoteService := TLabelPrintingServiceProxy.GetRemoteServiceInstance();
(LLabelPrintingRemoteService as ILabelPrintingManager).PrintVSSJob(printJob);
finally
TLabelPrintingServiceProxy.ReleaseLabelPrintingServiceProxyInstance(LLabelPrintingRemoteService);
end;
Related
I use D7 with Python4Delphi. After users have imported much of py-files, Python have all these modules cached. I need a way to reset Py engine. So that Py "forgets" all user-imported modules, and I have "clean" Python, w/out restarting the app.
How to do it?
There is a demo showing you how to unload/reload python using P4D at https://github.com/pyscripter/python4delphi/tree/master/PythonForDelphi/Demos/Demo34. The key method that (re)creates the python components and (re)loads different versions of python is shown below:
procedure TForm1.CreatePythonComponents;
begin
if cbPyVersions.ItemIndex <0 then begin
ShowMessage('No Python version is selected');
Exit;
end;
// Destroy P4D components
FreeAndNil(PythonEngine1);
FreeAndNil(PythonType1);
FreeAndNil(PythonModule1);
{ TPythonEngine }
PythonEngine1 := TPythonEngine.Create(Self);
PyVersions[cbPyVersions.ItemIndex].AssignTo(PythonEngine1);
PythonEngine1.IO := PythonGUIInputOutput1;
{ TPythonModule }
PythonModule1 := TPythonModule.Create(Self);
PythonModule1.Name := 'PythonModule1';
PythonModule1.Engine := PythonEngine1;
PythonModule1.ModuleName := 'spam';
with PythonModule1.Errors.Add do begin
Name := 'PointError';
ErrorType := etClass;
end;
with PythonModule1.Errors.Add do begin
Name := 'EBadPoint';
ErrorType := etClass;
ParentClass.Name := 'PointError';
end;
{ TPythonType }
PythonType1 := TPythonType.Create(Self);
PythonType1.Name := 'PythonType1';
PythonType1.Engine := PythonEngine1;
PythonType1.OnInitialization := PythonType1Initialization;
PythonType1.TypeName := 'Point';
PythonType1.Prefix := 'Create';
PythonType1.Services.Basic := [bsRepr,bsStr,bsGetAttrO,bsSetAttrO];
PythonType1.TypeFlags :=
[tpfHaveGetCharBuffer,tpfHaveSequenceIn,tpfHaveInplaceOps,
tpfHaveRichCompare,tpfHaveWeakRefs,tpfHaveIter,tpfHaveClass,tpfBaseType];
PythonType1.Module := PythonModule1;
PythonEngine1.LoadDll;
end;
The demo uses the unit PythonVersions to discover installed python versions.
It should be sufficient to destroy and re-create the TPythonEngine object:
OriginalOwner := GetPythonEngine.Owner;
GetPythonEngine.Free;
TPythonEngine.Create(OriginalOwner);
Destroying it calls Py_Finalize, which frees all memory allocated by the Python DLL.
Or, if you're just using the Python API without the VCL wrappers, you can probably just call Py_NewInterpreter on your TPythonInterface object to get a fresh execution environment without necessarily discarding everything done before.
I have a small application that is used to process some files made in another program.
I use an older component by Angus Johnson called TDirectoryWatch
On my FormCreate I have the following code
DirectoryWatch := TDirectoryWatch.Create(self);
DirectoryWatch.OnChange := FileAction;
DirectoryWatch.Directory := Folders.Path(dirInput);
DirectoryWatch.Active := True;
If the program is started and there is put a new file in the directory everything fires and runs OK.
But if there is a file in the directory when the program is started nothing happens even if I make a call to FileAction(nil);
FileAction is the name of the procedure that handles the files
I have a call to FileAction from a popupmenu and that handles the files in the directory
So my question is: how to make sure that existing files are handled at program start?
Or is there a better way to handle this problem.
Added code for FileAction
procedure TfrmMain.FileAction(Sender: TObject);
var
MailFile: string;
MailInfo: TMailInfo;
ListAttachments: TstringList;
i: integer;
MailBody: string;
begin
for MailFile in TDirectory.GetFiles(Folders.Path(dirInput), CheckType) do
begin
if FileExists(MailFile) then
begin
MailInfo := TMailInfo.Create(MailFile);
try
if FileProcessing = False then
begin
Logfile.Event('Behandler fil: ' + MailFile);
FileProcessing := True;
MailBody := '';
Settings.Load;
MailInfo.Load;
Settings.Mail.Signature := '';
Settings.Mail.Subject := MailInfo.Subject;
ListAttachments := TStringList.Create;
ListAttachments.Clear;
for i := 1 to MaxEntries do
begin
if (MailInfo.Attachment[i] <> '') and (FileExists(MailInfo.Attachment[i])) then
ListAttachments.Add(MailInfo.Attachment[i]);
end;
for i := 1 to MaxEntries do
begin
MailBody := MailBody + MailInfo.MailBody[i];
end;
try
if MailBody <> '' then
begin
if MailInfo.SenderBcc then
Mailing.Send(MailInfo.SenderMail, MailInfo.Recipient, MailInfo.SenderMail, MailInfo.Subject, MailBody, ListAttachments, True)
else
Mailing.Send(MailInfo.SenderMail, MailInfo.Recipient, MailInfo.Subject, MailBody, ListAttachments, True);
end;
finally
ListAttachments.Free;
end;
FileProcessing := False;
DeleteFile(MailFile);
end;
finally
MailInfo.Free;
end;
end;
end;
end;
The component doesn't notify about changes when your program starts up because at the time your program starts, there haven't been any changes yet.
Your policy appears to be that at the time your program starts up, all existing files are to be considered "new" or "newly changed," so your approach of manually calling the change-notification handler is correct.
The only thing the component does when it detects a change is to call the change-notification handler. If you explicitly call that function, and yet you still observe that "nothing happens," then there are more deep-seated problems in your program that you need to debug; it's not an issue with the component or with the basic approach described here.
I am trying to find a safe/deterministic way to release an interface which is encapsulated in an OleVariant.
AFAICS Delphi releases interface references at the end of a procedure, but in my case I have to do it earlier, because I have to shut down COM.
procedure Test;
var
LLibrary: OleVariant;
begin
CoInitialize(nil);
try
LLibrary := Null;
try
LLibrary := CreateOleObject(LibraryName);
finally
LLibrary := Unassigned; // <-- I would like to release the interface here
end;
finally
CoUninitialize; // <-- Shutdown of COM
end;
end; // <-- The compiler releases the interface here
I though of putting the OleVariant in an extra class instance that I can free before I call CoUninitialize.
procedure Test;
var
Container: TLibraryContainer; // Holds the OleVariant
begin
CoInitialize(nil);
try
Container := TLibraryContainer.Create;
try
{...}
finally
Container.Free;
end;
finally
CoUninitialize;
end;
end;
Is this solution safe or is there a better solution I have overlooked?
The compiler is clearly using an implicit local interface variable for the return value from CreateOleObject. This is then released at the end of the routine, too late for you.
There are a couple of ways to defeat this. First of all you could be explicit about the IDispatch interface reference returned by CreateOleObject. This allows you to control its lifetime.
procedure Test;
var
intf: IDispatch;
LLibrary: OleVariant;
begin
CoInitialize(nil);
try
intf := CreateOleObject(LibraryName);
try
LLibrary := intf;
finally
VarClear(LLibrary);
intf := nil;
end;
finally
CoUninitialize;
end;
end;
An alternative would be to move the code that called CreateOleObject into a separate routine with its own scope.
procedure DoWork;
var
LLibrary: OleVariant;
begin
LLibrary := CreateOleObject(LibraryName);
//do stuff with LLibrary
end;
procedure Test;
begin
CoInitialize(nil);
try
DoWork;
finally
CoUninitialize;
end;
end;
Since the implicit local reference is within the scope of DoWork it is released at the end of DoWork and therefore before you run CoUninitialize.
My recommendation is to use the second option which is cleaner and forces the compiler to do the work on your behalf.
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.
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;