Dica: Verificando processos no Windows

Hoje é dia das dicas. Mais uma enviada pelo colega Rubem Nascimento. Dessa vez a dica são funções para listar e verificar se o processo está ou não respondendo. Vamos lá:

Crie uma nova aplicação e nessa declare um novo tipo e uma constante como segue:

type
__TProcessStatus = (pcsNotFound = -1, pcsNotResponding, pcsRunning);

const
__ProcessStatusNames : array[TProcessStatus] of string =
(‘** NÃO ENCONTRADO **’, ‘Em Execução’, ‘Não Respondendo’);

Em seguida declare e implemente as funções abaixo na área public:

function ProcessResponding(AProcessName: string): TProcessStatus;
procedure FindProcesses(Process: TStrings);

Veja trecho de código das declarações e implementações:

unit uResidencialKiller;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, Types, Psapi, tlhelp32, StdCtrls;

type
TProcessStatus = (pcsNotFound = -1, pcsNotResponding, pcsRunning);

const
ProcessStatusNames          : array[TProcessStatus] of string =
('** NÃO ENCONTRADO **', 'Em Execução', 'Não Respondendo');

...
private
{ Private declarations }
function ProcessResponding(
AProcessName: string): TProcessStatus;
procedure FindProcesses(Process: TStrings);
end;
...

procedure TfrmResidencialKiller.FindProcesses(Process: TStrings);
var
ContinueLoop                : BOOL;
FSnapshotHandle             : THandle;
FProcessEntry32             : TProcessEntry32;
begin
FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
FProcessEntry32.dwSize := SizeOf(FProcessEntry32);
ContinueLoop := Process32First(FSnapshotHandle, FProcessEntry32);
  while ContinueLoop {and (not Boolean(Result))} do
  begin
Process.Add(FProcessEntry32.szExeFile);
ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32);
  end;
end;

function FindProcess(ProcessName: string): DWORD;
var
ContinueLoop                : BOOL;
FSnapshotHandle             : THandle;
FProcessEntry32             : TProcessEntry32;
begin
Result := 0;
FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
FProcessEntry32.dwSize := SizeOf(FProcessEntry32);
ContinueLoop := Process32First(FSnapshotHandle, FProcessEntry32);
  while ContinueLoop and (not Boolean(Result)) do
  begin
if ((UpperCase(ExtractFileName(FProcessEntry32.szExeFile)) =
UpperCase(ProcessName)) or (UpperCase(FProcessEntry32.szExeFile) =
UpperCase(ProcessName))) then
Result := FProcessEntry32.th32ProcessID;
ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32);
  end;
end;

function TfrmResidencialKiller.ProcessResponding(
AProcessName: string): TProcessStatus;
var
H                           : DWORD;
lngReturnValue              : longint;
DWResult                    : DWORD;
begin
Result := pcsNotFound;
H := FindProcess(AProcessName);
if H > 0 then
begin
lngReturnValue :=
SendMessageTimeout(H, WM_NULL, 0, 0, SMTO_ABORTIFHUNG and SMTO_BLOCK,
1000, DWResult);
Result := TProcessStatus(Ord((lngReturnValue > 0)));
end;
end;

...

Para utilização, insira dois botões e um listbox na tela. No primeiro botão codifique como baixo:

FindProcesses(ListBox1.Items);

No segundo:

procedure TfrmResidencialKiller.Button2Click(Sender: TObject);
begin
if ListBox1.ItemIndex <> -1 then
case ProcessResponding(ListBox1.Items[ListBox1.ItemIndex]) of
pcsNotFound: ShowMessage(Pr
ocessStatusNames[pcsNotFound]);
pcsNotResponding: ShowMessage(ProcessStatusNames[pcsNotResponding]);
pcsRunning: ShowMessage(ProcessStatusNames[pcsRunning]);
end;
end;

Veja uma imagem:

Donwload: Exemplo Process Killer

Adriano Santos
Editor Técnico Revista ClubeDelphi e WebMobile