» Help

Detect if an application has stopped responding

   

In many situations you might like to detect if an application is blocked. For example while automating Internet Explorer, you'd like to know if Internet Explorer has stopped responding.

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, ComObj, StdCtrls;

type
  TForm1 = class(TForm)
    btnLaunch: TButton;
    btnCheck: TButton;
    btnKill: TButton;
    procedure btnLaunchClick(Sender: TObject);
    procedure btnCheckClick(Sender: TObject);
    procedure btnKillClick(Sender: TObject);
  public
    modObjIE : OLEVariant;
    modlngWndIE : THandle;
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.btnLaunchClick(Sender: TObject);
begin
  modObjIE := CreateOleObject('InternetExplorer.Application');
  modObjIE.Visible := true;
  modObjIE.Navigate2('http://www.borland.com');
  modlngWndIE := modObjIE.hwnd;
end;

procedure TForm1.btnCheckClick(Sender: TObject);
var
 dwResult : DWORD;
 lngReturnValue : longint;
begin
  lngReturnValue := SendMessageTimeout(
    modlngWndIE, WM_NULL, 0, 0,
    SMTO_ABORTIFHUNG OR SMTO_BLOCK, 1000, dwResult
  );
  if lngReturnValue > 0 then
    ShowMessage('Responding')
  else
    ShowMessage('Not Responding');
end;

procedure TForm1.btnKillClick(Sender: TObject);
var
 ProcessID : DWORD;
 Process : THandle;
begin
  GetWindowThreadProcessId(modlngWndIE, @ProcessID);
  Process := OpenProcess(PROCESS_ALL_ACCESS, false, ProcessID);
  TerminateProcess(Process, 0);
end;

end.

Although the code is written for Internet Explorer, the idea can be used for other applications as well:

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
var
  H : THandle;
  lngReturnValue : longint;
  DWResult : DWORD;
begin
  H := FindWindow('Notepad', nil);
  if H > 0 then
  begin
    lngReturnValue := SendMessageTimeout(
      H, WM_NULL, 0, 0, SMTO_ABORTIFHUNG And SMTO_BLOCK,
      1000, DWResult
    );
    if lngReturnValue > 0 then
      ShowMessage('Responding')
    else
      ShowMessage('Not responding');
  end
  else
    ShowMessage('Application not found');
end;

end.
Author: Shlomo Abuisak
Contributor: Shlomo Abuisak
Added: 2009-11-05
Last updated: 2009-11-05

« Return to contents »