Klasse zum Beenden eines Prozesses

[Luckie]

Aktuelle Version:

Delphi-Quellcode:

// Klasse zum Benden eines Processes mittels TerminateProcess
// Class for terminating a process via TerminateProcess
// Michael Puff [http://www.michael-puff.de]
// 2010-11-22

unit MpuKillProcessCls;

interface

uses
  Windows,
  Messages,
  SysUtils,
  TlHelp32;

type
  TOnTerminated = procedure(HasTerminated: Boolean; ProcessExefile: string) of object;
  TOnProcessNotFound = procedure(ProcessExefile: string) of object;
  TKillProcess = class(TObject)
  private
    FProcessExefile: string;
    FProcessID: Cardinal;
    FTimeOut: Cardinal;
    FOnTerminated: TOnTerminated;
    FOnProcessNotFound: TOnProcessNotFound;
    function GetProcessID: Cardinal;
    procedure SetProcessExefile(const Value: string);
    procedure SetPID(Value: Cardinal);
    function EnablePrivilege(const Privilege: string; fEnable: Boolean; out
      PreviousState: Boolean): DWORD;
  public
    property ProcessExefile: string read FProcessExefile write SetProcessExefile;
    property PID: Cardinal read FProcessID write SetPID;
    property TimeOutMSecs: Cardinal read FTimeOut write FTimeOut;
    property OnTerminated: TOnTerminated read FOnTerminated write FOnTerminated;
    property OnProcessNotFound: TOnProcessNotFound read FOnProcessNotFound write FOnProcessNotFound;
    constructor Create;
    procedure Kill;
  end;

implementation

constructor TKillProcess.Create;
begin
  FTimeOut := 0;
end;

function TKillProcess.EnablePrivilege(const Privilege: string;
  fEnable: Boolean; out PreviousState: Boolean): DWORD;
var
  Token: THandle;
  NewState: TTokenPrivileges;
  Luid: TLargeInteger;
  PrevState: TTokenPrivileges;
  Return: DWORD;
begin
  PreviousState := True;
  if (GetVersion() > $80000000) then
    // Win9x
    Result := ERROR_SUCCESS
  else
  begin
    // WinNT
    if not OpenProcessToken(GetCurrentProcess(), MAXIMUM_ALLOWED, Token) then
      Result := GetLastError()
    else
    try
      if not LookupPrivilegeValue(nil, PChar(Privilege), Luid) then
        Result := GetLastError()
      else
      begin
        NewState.PrivilegeCount := 1;
        NewState.Privileges[0].Luid := Luid;
        if fEnable then
          NewState.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED
        else
          NewState.Privileges[0].Attributes := 0;
        if not AdjustTokenPrivileges(Token, False, NewState,
          SizeOf(TTokenPrivileges), PrevState, Return) then
          Result := GetLastError()
        else
        begin
          Result := ERROR_SUCCESS;
          PreviousState :=
            (PrevState.Privileges[0].Attributes and SE_PRIVILEGE_ENABLED <> 0);
        end;
      end;
    finally
      CloseHandle(Token);
    end;
  end;
end;

function TKillProcess.GetProcessID: Cardinal;
var
  ProcessSnapShot: THandle;
  pe32: TProcessEntry32;
  ProcessID: Cardinal;
begin
  ProcessID := 0;
  ProcessSnapShot := CreateToolHelp32SnapShot(TH32CS_SNAPPROCESS, 0);
  if ProcessSnapShot <> INVALID_HANDLE_VALUE then
  begin
    pe32.dwSize := SizeOf(ProcessEntry32);
    if Process32First(ProcessSnapShot, pe32) then
    begin
      while Process32Next(ProcessSnapShot, pe32) do
      begin
        if AnsiSameText(FProcessExefile, pe32.szExeFile) then
        begin
          ProcessID := pe32.th32ProcessID;
          Break;
        end;
      end;
    end
    else
    begin
      RaiseLastOSError;
    end;
  end
  else
  begin
    RaiseLastOSError;
  end;
  CloseHandle(ProcessSnapShot);
  if ProcessID = 0 then
  begin
    if Assigned(OnProcessNotFound) then
      OnProcessNotFound(FProcessExefile);
  end;
  Result := ProcessID;
end;

procedure TKillProcess.Kill;
var
  EnablePrivelege: DWORD;
  PreviousPriviliegeState: Boolean;
  ProcessHandle: Cardinal;
  WFSOReturnCode: DWORD;
begin
  FProcessID := GetProcessID;
  if FProcessID <> 0 then
  begin
    repeat
      EnablePrivelege := EnablePrivilege('SE_DEBUG_NAME', true, PreviousPriviliegeState);
      if EnablePrivelege <> 0 then
      begin
        ProcessHandle := OpenProcess(SYNCHRONIZE or PROCESS_TERMINATE, False, FProcessID);
        if ProcessHandle <> 0 then
        begin
          if TerminateProcess(ProcessHandle, 0) then
          begin
            WFSOReturnCode := WaitForSingleObject(ProcessHandle, FTimeOut);
            case WFSOReturnCode of
              WAIT_TIMEOUT:
                begin
                  if GetProcessID = 0 then
                  begin
                    if Assigned(OnTerminated) then
                      OnTerminated(True, FProcessExefile);
                  end
                  else
                  begin
                    if Assigned(OnTerminated) then
                      OnTerminated(False, FProcessExefile);
                    Exit;
                  end;
                  if FTimeOut > 0 then
                  begin
                    raise Exception.Create('Timeout');
                  end;
                end;
              WAIT_FAILED:
                begin
                  RaiseLastOSError;
                end;
              WAIT_OBJECT_0:
                begin
                  if Assigned(OnTerminated) then
                    OnTerminated(True, FProcessExefile);
                end;
            end;
          end
          else
          begin
            RaiseLastOSError;
          end;
          CloseHandle(ProcessHandle);
        end
        else
        begin
          RaiseLastOSError;
        end;
      end
      else
      begin
        raise Exception.Create(SysErrorMessage(GetLastError));
      end;
      FProcessID := GetProcessID;
    until FProcessID = 0;
  end;
end;

procedure TKillProcess.SetProcessExefile(const Value: string);
begin
  FProcessExefile := Value;
end;

procedure TKillProcess.SetPID(Value: Cardinal);
begin
  FProcessID := Value;
end;

end.

Demo:

Delphi-Quellcode:

program Project2;

{$APPTYPE CONSOLE}

uses
  SysUtils,
  MpuKillProcessCls in 'MpuKillProcessCls.pas';

type
  TMain = class(TObject)
  public
    procedure OnTerminated(HasTerminated: Boolean; ProcessExefile: string);
    procedure OnProcessNotFound(ProcessExefile: string);
  end;

procedure TMain.OnProcessNotFound(ProcessExefile: string);
begin
  Writeln('Fehler. Process ' + ProcessExeFile + ' nicht gefunden.');
end;

procedure TMain.OnTerminated(HasTerminated: Boolean; ProcessExefile: string);
begin
  if HasTerminated then
    Writeln('Prozess ' + ProcessExefile + ' beendet')
  else
    Writeln('Fehler beim Beenden des Prozesses ' + ProcessExefile);
end;

var
  Main: TMain;
  KillProcess: TKillProcess;
begin
  Main := TMain.Create;
  try
    KillProcess := TKillProcess.Create;
    try
      try
        KillProcess.OnTerminated := Main.OnTerminated;
        KillProcess.OnProcessNotFound := Main.OnProcessNotFound;
        KillProcess.TimeOutMSecs := 5000;
        KillProcess.ProcessExefile := 'photofiltre.exe';
        //KillProcess.ProcessExefile := 'svchost.exe';
        //KillProcess.PID := 2696;
        KillProcess.Kill;
      except
        on E: Exception do
          Writeln(E.Message);
      end;
    finally
      KillProcess.Free;
    end;
  finally
    Main.Free;
  end;
  Readln;
end.

[HeikoAdams]

Ich habe den kompletten Thread jetzt nicht durchgelesen, aber was mir noch fehlen würde, wäre die Möglichkeit, Prozesse anhand des Fenstertitels zu beenden.

[Luckie]

Immer langsam mit den jungen Pferden. Man muss sich ja noch für Version 2 was aufheben.