Delphi prevent application shutdown - delphi

I am trying to prevent my application from being shutdown by windows.
The application is running on windows 8 and written in XE6.
I tried following code but it seems to be completely ignored. To test it I simply send "end task" to it through the task manager.
What I need is a way to let my application finish what its doing when the application is closed by the user, by the task manager of by a windows shutdown.
Normal closing is not a problem, this is handled by the FormCloseQuery event. But the other 2 methods I can't get to work. Until windows XP this was easy by catching the wm_endsession and the wm_queryendsession, starting from vista you need the use ShutDownBlockReasonCreate, which returns true but does not seems to work anyway.
procedure WMQueryEndSession(var Msg : TWMQueryEndSession); message WM_QUERYENDSESSION;
procedure WMEndSession(var Msg: TWMEndSession); message WM_ENDSESSION;
function ShutdownBlockReasonCreate(hWnd: HWND; Reason: LPCWSTR): Bool; stdcall; external user32;
function ShutdownBlockReasonDestroy(hWnd: HWND): Bool; stdcall; external user32;
procedure TForm1.WMEndSession(var Msg: TWMEndSession);
begin
inherited;
Msg.Result := lresult(False);
ShutdownBlockReasonCreate(Handle, 'please wait while muting...');
Sleep(45000); // do your work here
ShutdownBlockReasonDestroy(Handle);
end;
procedure TForm1.WMQueryEndSession(var Msg: TWMQueryEndSession);
begin
inherited;
Msg.Result := lresult(False);
ShutdownBlockReasonCreate(Handle, 'please wait while muting...');
Sleep(45000); // do your work here
ShutdownBlockReasonDestroy(Handle);
end;
Update
Changing the message result to true and removing the sleep changes nothing.
procedure TForm1.WMEndSession(var Msg: TWMEndSession);
begin
inherited;
Msg.Result := lresult(True);
ShutdownBlockReasonDestroy(Application.MainForm.Handle);
ShutdownBlockReasonCreate(Application.MainForm.Handle, 'please wait while muting...');
end;
procedure TForm1.WMQueryEndSession(var Msg: TWMQueryEndSession);
begin
inherited;
Msg.Result := lresult(True);
ShutdownBlockReasonDestroy(Application.MainForm.Handle);
ShutdownBlockReasonCreate(Application.MainForm.Handle, 'please wait while muting...');
end;

According to the documentation to block shutdown you need to return FALSE in response to WM_QUERYENDSESSION.
What's more, you must not do work in this message handler. The work must happen elsewhere. If you don't respond to this message in a timely fashion the system won't wait for you.
Call ShutdownBlockReasonCreate before you start working.
Whilst working return FALSE from WM_QUERYENDSESSION. Don't work whilst handling this message. Return immediately.
When the work is done call ShutdownBlockReasonDestroy.
The handler for WM_QUERYENDSESSION can look like this:
procedure TMainForm.WMQueryEndSession(var Msg: TWMQueryEndSession);
begin
if Working then
Msg.Result := 0
else
inherited;
end;
And then the code that performs the work needs to call ShutdownBlockReasonCreate before the work starts, ShutdownBlockReasonDestroy when the work ends, and make sure that the Working property used above evaluates to True during work.
If your work blocks the main thread then you are in trouble. The main thread must be responsive, otherwise the system won't wait for you. Putting the work in a thread is often the way forward. If your main window is not visible then you don't get a chance to block shutdown. The details are explained here: http://msdn.microsoft.com/en-us/library/ms700677.aspx
If you get as far as being sent WM_ENDSESSION then it's too late. The system is going down come what may.
To test it I simply send "end task" to it through the task manager.
That has nothing to do with shutdown blocking. The way you test shutdown blocking is to logoff. If the user insists on killing your process there is little that you can do about it. Sertac's answer covers this in detail.
Finally, ignoring the return values of API calls is also very poor form. Don't do that.

Your code seems to be completely ignored because you're not testing it. You're sending "end task" to it through the task manager, the code you posted is only effective when the system is shutting down.
What is different with Windows 8 seems to be how task manager behaves. Before Windows 8, an end task from task manager will first try closing the app gracefully (sends a WM_CLOSE), this you're handling with OnCloseQuery. But when the application denies closing, the task manager will offer ending the process forcefully. This, you cannot handle. Same if you choose "end process" from task manager.
The Windows 8 task manager does not offer an additional dialog for forcefully closing the application, but immediately proceeds doing so when the application denies closing.

Here are some solution for some different cases tested in Delphi 11.1 Alexandria:
The Form OnCloseQuery gets called when app is being closed by user or by system shutdown, to know which one of these two events is triggered, call GetSystemMetrics and pass SM_SHUTTINGDOWN as an argument.
System metric SM_SHUTTINGDOWN is set when there is a pending system shutdown, clear otherwise.
This is all you need if you only want say suppress exit confirmation message to the user if system is shutting down:
procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
if GetSystemMetrics (SM_SHUTTINGDOWN) > 0 then
Exit; // app is being closed by a system shutdown
// app being closed by user, ask user to confirm exit
if not ConfirmAppExit then
CanClose := False;
end;
Please note if the system is shutting down your Form OnCloseQuery will be called but your Form OnClose will not be called, any code you put in OnClose will not be executed. So, don't put code there if you want it to be executed on system shutdown, Instead, use the WM_EndSession handler described below.
If you want more than that and be able to block the shutdown, First write a handler for the message WM_QueryEndSession:
procedure WMQueryEndSession(var Msg: TWMQueryEndSession); message WM_QueryEndSession;
Inside this handler do not do anything except returning message result, this message is sent to your app to check if it agrees to shutdown the system or not, it does not mean the system shutdown is taking place right now, because all apps must agree to this message first, but if just one app denies this message (return False) then shutdown will not happen (When shutdown is really
taking place you will receive WM_EndSession message).
In the WM_QueryEndSession handler check if there are any critical running tasks which must be completed in one go or if interrupted will cause data loss, If there is a critical task running return False to deny system shutdown, like:
procedure TForm1.WMQueryEndSession(var Msg: TWMQueryEndSession);
begin
if CriticalTaskRunning then
Msg.Result := 0 // Deny system shutdown
else
inherited; // Agree to system shutdown, Same as Msg.Result := 1
end;
Do not return False if your task is not critical and can be interrupted, and do not interrupt your task at this point, just return True and keep your task running because some other app may deny the shutdown and you just interrupted your task for nothing!, Interrupt your task only when you receive WM_EndSession message which means all applications agreed to the shutdown and the system is really shutting down.
By returning False, shutdown is now denied, using ShutdownBlockReasonCreat at this time is redundant, but you can use that to explain to the user (in shutdown screen) why your app is blocking shutdown. If you use this be sure to call ShutdownBlockReasonDestroy after your task is finished.
When receiving WM_EndSession you know now the system is really shutting down.
If you need to do cleanup, abort any running tasks, save changes close DB/files ...etc, then you can use ShutdownBlockReasonCreate to block shutdown until you finish cleaning up, then unblock shutdown once finished, like:
procedure WMEndSession (var Msg: TWMEndSession);
begin
if CleanUpRequired then
begin
ShutdownBlockReasonCreate (Handle, 'My app is preparing to close, just a sec...');
try
DoCleanUp;
finally
ShutdownBlockReasonDestroy (Handle);
end;
end;
end;
Some other shutdown block methods suggest you create a shutdown block every time you start a task and destroy the shutdown block once your task is finished even if the system is not shutting down! my approach here is only create a shutdown block when it is necessary and only when the system is really shutting down.
I Hope it's useful for someone!

Related

Prevent Delphi Service from not responding

my problem is the following:
I implemented a Windows Service with Delphi Tokyo but imho this is no version problem rather than a design problem.
I use the following code to pause my service and be responsive in that state.
procedure TMyService.ServiceExecute(Sender: TService);
begin
while not Terminated do
begin
MyProductiveFunction;
Delay(10000);
end;
end;
procedure TMyService.Delay(Milliseconds: integer);
var
Tick: DWord;
Event: THandle;
begin
LogOnLevel(clogger, CAS_LOGGER.Debug, '', ['Delay', 'ENTER', 'Delayed for ' + Milliseconds.ToString]);
Event := CreateEvent(nil, False, False, nil);
try
Tick := GetTickCount + DWord(Milliseconds);
while (Milliseconds > 0) and (MsgWaitForMultipleObjects(1, Event, False, Milliseconds, QS_ALLINPUT) <>
WAIT_TIMEOUT) do
begin
ServiceThread.ProcessRequests(False);
if Terminated then
exit;
Milliseconds := Tick - GetTickCount;
end;
finally
CloseHandle(Event);
end;
end;
The Function I run sometimes is very time consuming. When I try to Stop the Service while it is in the Delay procedure it stops and everything is fine. But when I try to stop the Service while running "MyProductiveFunction" it will say Service is not responding and after that there is no other way to terminate the Service than killing it by Taskmanager.
Is there a better way to implement that so the Service will be responding independently from its actual state?
You have to write MyProductiveFunction like you programmed your Delay function: periodically process requests and terminate the function if the service is asked to terminate.
Instead, you may also create another thread to execute MyProductiveFunction and from the ServiceExecute call ProcessRequest and check for termination. When termination is requested, you have to terminate the other thread. The best is to have this other thread check something shared such a TEvent for terminating, or ServiceExecute may kill/abort that thread.
Thanks for your Support.
I used the code skeleton from Remys post here:
Delphi Windows Service Design
Works great. Thx to that great community and thx to Remy

Forcing TService OnStop event to wait until some job completes

working with a Windows Service application in Delphi, I stumbled on the issue as in the subject.
I do start a default Delphi Windows Service project on the IDE, follow the wizard and in the end I have a project and a
TService unit. I add to this project another unit, a Data Module (named DM) in which the service code logic is contained.
The DM has a TTimer (design-time) that runs a relatively long job.
Case 1:
DM is created by default in design-time. I have the following code in my TService Start/Stop
procedure TOmegaCAOraNT.ServiceStart(Sender: TService;
var Started: Boolean);
begin
DM.Timer1.Enabled := True;
Started := true;
end;
procedure TOmegaCAOraNT.ServiceStop(Sender: TService; var Stopped: Boolean);
begin
DM.Agent_Stop;
Stopped := true;
end;
When I try to Stop the Service via Windows SCM - in appearance it confirms the Stop, field Status becomes empty - but it does not.
I can see the service .exe still running for a while, and what's more it does terminate the Timer's long job in the middle,
doing part of it only!
This is an undesired behavior!
I fixed this in the second case
Case 2:
DM is created in run-time. The Timer is enabled on DM.OnCreate
I have the following code in my TService Start/Stop
procedure TOmegaCAOraNT.ServiceStart(Sender: TService; var Started: Boolean);
begin
FDataModule := TDM.Create(nil);
Started := true;
end;
procedure TOmegaCAOraNT.ServiceStop(Sender: TService; var Stopped: Boolean);
begin
FreeAndNil(FDataModule);
Stopped := true;
end;
When I try to Stop the Service via Windows SCM - it throws the following Warning:
"Windows could not stop the SERVICE> service on the Local Computer.
The service did not return an error. his could be an internal Windows error or an internal service error.
if the error persists, contact your system Administrator"
field Status remains Started. Timer' long job finishes until the end, and then the service really stops (refresh in SCM to see, Status empty)
This is desired behavior !
My problem is that I would like the DM to be created in design-time, and not in run-time
My question is:
can I have the right behavior of run-time DM (Case 2), with a design-time DM (Case 1) ?
thanks and best regards,
Altin
TService runs in is own worker thread at run-time.
If you configure the DM to be auto-created, it (and its TTimer) will be created in the main thread at run-time, not in the service thread. And thus, the TTimer will run in the main thread, and can be activated only by the main thread, not in the TService.OnStart event handler (an EOutOfResources exception will be raised if you try).
If you manually create the DM in the TService.OnStart event handler, it (and its TTimer) will be created in the service thread, not in the main thread. The TTimer will run in the service thread, and can be (de)activated in the TService events.
Either way, make sure your TTimer.OnTimer event handler uses thread-safe code.
Also, the TService.OnStop event handler must call the TService.ReportStatus() method periodically (before the TService.WaitHint interval elapses) while waiting for other threads to stop whatever they are doing. Which means you shouldn't use thread-blocking code in the TService.OnStop event handler.
You are not handling this correctly, which is why the SCM is having problems.

OnShown event for TForm?

At program start, in the OnActivate event handler, I need to do something which blocks the program for a few seconds. During this time the form's client area is still not completely painted, which looks ugly for the user. (During this blocked time I don't need the program to respond to clicks or other user actions, so there is no need to put the blocking operation into a thread - I just need the form to be completely painted). So I use TForm.Update and Application-ProcessMessages to update the form before the blocking operation which works very well:
procedure TForm1.FormActivate(Sender: TObject);
begin
Form1.Update;
Application.ProcessMessages;
Sleep(7000);
end;
However, I wonder whether there is not another more elegant solution for this problem. This could be for example a OnShown event implemented in a descendant of TForm which will be fired AFTER the form has been completely painted. How could such an event be implemented?
Your real problem is that you are blocking the UI thread. Simply put, you must never do that. Move the long running task onto a different thread and thus allow the UI to remain responsive.
If you are looking for event which is fired when application finishes loading/repainting you should use TApplication.OnIdle event
http://docwiki.embarcadero.com/Libraries/XE3/en/Vcl.Forms.TApplication.OnIdle
This event is fired once application is read to recieve users input. NOTE this event will be fired every time application becomes idle so you need to implement some controll variable which will tel you when OnIdle even was fired for the first time.
But as David already pointed out it is not good to block your UI (main thread). Why? When you block your main thread the application can't normally process its messages. This could lead to OS recognizing your application as being "Hanged". And aou definitly wanna avoid this becouse it could cause the users to go and forcefully kill your application whihc would probably lead to data loss. Also if you ever wanna design your application for any other platforms than Windows your application might fail the certification proces becouse of that.
In the past a simple PostMessage did the trick.
Essentially you fire it during DoShow of the base form:
procedure TBaseForm.DoShow;
begin
inherited;
PostMessage(Handle, APP_AFTERSHOW, 0, 0);
end;
then catch the msg and create an AfterShow event for all forms inherited from this base form.
But that no longer works, well not if you are skinning and have a good number of VCL controls.
My next trick was to spawn a simple thread in DoShow and check for IsWindowVisible(Handle) and IsWindowEnabled(Handle). That really sped things up it cut 250ms from load time since db opening and other stuff was already in the AfterShow event.
Then finally I thought of madHooks, easy enough to hook the API ShowWindow for my application and fire APP_AFTERSHOW from that.
function ShowWindowCB(hWnd: HWND; nCmdShow: Integer): BOOL; stdcall;
begin
Result := ShowWindowNext(hWnd, nCmdShow);
PostMessage(hWnd, APP_AFTERSHOW, 0, 0);
end;
procedure TBaseForm.Loaded;
begin
inherited;
if not Assigned(Application.MainForm) then // Must be Mainform it gets assigned after creation completes
HookAPI(user32, 'ShowWindow', #ShowWindowCB, #ShowWindowNext);
end;
To get the whole thing to completely paint before AfterShow it still needed a ProcessPaintMessages call
procedure TBaseForm.APPAFTERSHOW(var AMessage: TMessage);
begin
ProcessPaintMessages;
AfterShow;
end;
procedure ProcessPaintMessages; // << not tested, pulled out of code
var
msg: TMsg;
begin
while PeekMessage(msg, 0, WM_PAINT, WM_PAINT, PM_REMOVE) do
DispatchMessage(msg);
end;
My final test was to add a Sleep to the AfterShow event and see the Form fully painted with empty db containers since the AfterShow events had not yet completed.
procedure TMainForm.AfterShow;
begin
inherited;
Sleep(8*1000);
......

How to pause Windows shutdown

I need to mute/un-mute the sound card at startup and shutdown.
I have found some code to do the work, but often Windows slams through the shutdown and the sound never gets muted.
Can someone please tell me how to pause the shutdown long enough for my app to mute the sound? I can use a simple TTimer to pause the app long enough for it to run the muting and then let Windows get on with shutting down.
How do I tell Windows to wait though?
I notice that if I leave Firefox running and try to shutdown, Windows stops with a message, "These programs are preventing windows closing..." and needs a click to force Firefox to close. I need to find that.
Since Windows Vista, if you register a shutdown reason string with the OS or if your application has a top level window, the OS will wait indefinitely for your program to return from WM_QUERYENDSESSION while displaying the blocking applications screen - or until the user chooses to forcefully end the program of course.
The below sample code simulates a 45 seconds wait with Sleep. In the first five seconds of the wait the OS waits patiently, only then it displays the full screen UI. The only way to show the screen immediately is to immediately return false from WM_QUERYENDSESSION. But in this case you won't be able to resume shutdown.
For details on shutdown behavior of the OS for Vista and later, see documentation.
type
TForm1 = class(TForm)
..
protected
procedure WMQueryEndSession(var Message: TWMQueryEndSession);
message WM_QUERYENDSESSION;
..
...
function ShutdownBlockReasonCreate(hWnd: HWND; Reason: LPCWSTR): Bool;
stdcall; external user32;
function ShutdownBlockReasonDestroy(hWnd: HWND): Bool; stdcall; external user32;
procedure TForm1.WMQueryEndSession(var Message: TWMQueryEndSession);
const
ENDSESSION_CRITICAL = $40000000;
begin
Message.Result := LRESULT(True);
if ((Message.Unused and ENDSESSION_CRITICAL) = 0) then begin
ShutdownBlockReasonCreate(Handle, 'please wait while muting...');
Sleep(45000); // do your work here
ShutdownBlockReasonDestroy(Handle);
end;
end;
You need to handle the WM_QUERYENDSESSION messsage. It's sent to each application before Windows starts the shutdown process. Do what you need quickly, because failure to respond rapidly enough causes the behavior you're observing in FireFox, which is usually a sign of a badly designed app (and the user may terminate it before you get a chance to finish).
interface
...
type
TForm1 = class(TForm)
procedure WMQueryEndSession(var Msg: TWMQueryEndSession);
message WM_QUERYENDSESSION;
end;
implementation
procedure TForm1.WMQueryEndSession(var Msg: TWMQueryEndSession);
begin
// Do what you need to do (quickly!) before closing
Msg.Result := True;
end;
(Just as an aside: The enabling/disabling of sounds is a per-user setting, and you should have a very good need for interfering with the user's choice. If I were you, I'd make sure my uninstaller was well-tested, because any app that interfered with my sound preferences this way would be removed from my system very quickly.)

Closing a Client thread gracefully

I am troubleshooting a Delphi 7 Indy9 polling client. I have tried adding a TEvent with a waitforsingleobject and many other ways to disconnect gracefully. The error occurs in the readln. The error is usually an 'EIDConnection...not connected'. I have put a watch on it and the thread terminates. but the 'while' doesn't reevaluate the condition until the connection receives a msg from the server, so it just grinds at the readln until it receives a msg. So sometimes it disconnects gracefully but most times crashes. Is there a way to do this or do I just put a try...except around the readln and carry on...thanks in advance
procedure TReadingThread.Execute;
begin
while not Terminated and FConn.Connected do
begin
// read msg from server
Msg := FConn.ReadLn;
Synchronize(ReceiveLine);
end;
end;
I think you need to add some code to handle the Disconnect event. I had a similar problem to what you describe, and here's what I did (in this example, tcpServer is an instance of TIdTCPServer):
procedure TformRemoteControlWnd.tcpServerDisconnect(AContext: TIdContext);
(*
Connection is disconnected. Be careful, because this also gets called when
the app is shutting down while a connection is active, in which case
tcpServer may be gone already.
*)
begin
if not Application.Terminated and Assigned(tcpServer) then
begin
sbarStatus.SimpleText := 'TCP/IP Disconnected';
tcpServer.Tag := 0; // used to prevent rentrancy
end;
// shut down connection to stop thread from calling OnExecute event
try
AContext.Connection.Disconnect;
except
Sleep(0);
end;
end;
I have found the answer...Readln will wait indefinitely until it receives a carriage return. So the Thread sits at Readln until the server sends a message or the socket is disconnected (which causes the crash). In the Delphi compiler code, a comment was written in the OnDisconnect to trap the error using a try...except. So I just need to be careful to clean up before disconnecting the socket. I thought I could find a cleaner close method. Thanks for all the help.

Resources