在 EnumProcesses 列表中未检测到使用 ShellExecuteEx 启动的应用程序

Question

将我们的代码库转换为 64 位（Delphi Alexandria 11.3）后，我注意到使用

TTTLauncher

的

IsProcessRunning

函数看不到由“我们的”

EnumProcesses

组件启动的进程。我不怀疑检测部分，但也会在这里包含它的代码。

启动应用程序：

var
   lLauncher : TTTLauncher;
   lEXE      : string;
begin
   lLauncher := TTTLauncher.Create(Application);
   lEXE := FPath+EdtProcess.Text;
   try
      lLauncher.FileName := lExe;
      lLauncher.Parameters := '-startprc';
      lLauncher.ShowMode := smNormal;
      lLauncher.WaitUntilFinished := False;
      lLauncher.RunAsAdministrator := True;
      lLauncher.Launch;

      Sleep(2500);

   finally
     FreeAndNil(lLauncher);
   end;
end;

这是启动器（抱歉代码太长）：

unit TTLauncher;

interface

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

type
  TShowMode = ( smNormal, smMaximized, smMinimized, smHide );

const
  ShowWindowModes: array[ TShowMode ] of Integer =
    ( sw_Normal, sw_ShowMaximized, sw_ShowMinimized, sw_Hide );

type
  TTTLauncher = class;

  TTTLaunchThread = class( TThread )
  private
    FLauncher: TTTLauncher;
  protected
    procedure Execute; override;
  public
    constructor Create( ALauncher: TTTLauncher );
  end;

  TTTLaunchErrorEvent = procedure( Sender: TObject; ErrorCode: DWord ) of object;

  TTTWaitType = ( wtFullStop, wtProcessMessages );

  TTTEnumWinInfo = class(TObject)
    ProcessID : integer;
    WindowHandle : HWND;
  end;

  TTTLauncher = class( TComponent )
  private
    FHInstance: THandle;
    FAction: string;
    FFileName: string;
    FParameters: string;
    FShowMode: TShowMode;
    FStartDir: string;
    FTimeout: Integer;
    FWaitType: TTTWaitType;
    FWaitUntilFinished: Boolean;
    FOnFinished: TNotifyEvent;
    FOnTimeout: TNotifyEvent;
    FOnError: TTTLaunchErrorEvent;
    FExitCode: DWord;
    FLastErrorCode: DWord;
    FHProcess: THandle;
    FRunning: Boolean;
    FBackgroundThread: TTTLaunchThread;
    FProcessID: integer;
    FThreadID: integer;
    FHThread: THandle;
    FRunAsAdministrator : Boolean;
  protected
    procedure StartProcess; virtual;

    procedure Finished; dynamic;
    procedure DoTimeout; dynamic;
    procedure LaunchError; dynamic;

    procedure WaitForProcessAndProcessMsgs; virtual;
    procedure WaitForProcessFullStop; virtual;
    procedure WaitForProcessFromThread; virtual;
    procedure StartExecutable;
    procedure StartDataFile;
    procedure SetRunAsAdministrator(ARunAsAdministrator : boolean);

  public
    constructor Create( AOwner: TComponent ); override;
    destructor Destroy; override;

    procedure Launch; virtual;
    procedure StopProcess( ATimeOut : integer = 5000 );

    function GetErrorMsg( ErrorCode: DWord ): string;

    property ExitCode: DWord
      read FExitCode;

    property HProcess: THandle
      read FHProcess;

    property HThread: THandle
      read FHThread;

    property ProcessID: integer
      read FProcessID;

    property ThreadID: integer
      read FThreadID;

    property Running: Boolean
      read FRunning;
  published

    property Action: string
      read FAction
      write FAction;

    property FileName: string
      read FFileName
      write FFileName;

    property Parameters: string
      read FParameters
      write FParameters;

    property ShowMode: TShowMode
      read FShowMode
      write FShowMode
      default smNormal;

    property StartDir: string
      read FStartDir
      write FStartDir;

    property Timeout: Integer
      read FTimeout
      write FTimeout;

    property WaitType: TTTWaitType
      read FWaitType
      write FWaitType
      default wtFullStop;

    property WaitUntilFinished: Boolean
      read FWaitUntilFinished
      write FWaitUntilFinished
      default False;

    property OnFinished: TNotifyEvent
      read FOnFinished
      write FOnFinished;

    property OnError: TTTLaunchErrorEvent
      read FOnError
      write FOnError;

    property OnTimeout: TNotifyEvent
      read FOnTimeout
      write FOnTimeout;

    property RunAsAdministrator : Boolean
      read FRunAsAdministrator
      write SetRunAsAdministrator;
  end;


implementation

uses
  Registry,
  ShellApi;

constructor TTTLaunchThread.Create( ALauncher: TTTLauncher );
begin
  inherited Create( False );
  FLauncher := ALauncher;
  FreeOnTerminate := True;
end;

procedure TTTLaunchThread.Execute;
begin
  if FLauncher <> nil then
    FLauncher.StartProcess;
end;

constructor TTTLauncher.Create( AOwner: TComponent );
begin
  inherited;
  FShowMode := smNormal;
  FHInstance := 0;
  FAction := 'Open';
  FRunAsAdministrator := False;
  FHProcess := 0;
  FExitCode := 0;
  FTimeout := -1 {INFINITE};

  FRunning := False;
  FWaitType := wtFullStop;
  FWaitUntilFinished := False;
end;

destructor TTTLauncher.Destroy;
begin
  if FRunning and not FWaitUntilFinished and ( FBackgroundThread <> nil ) and not FBackgroundThread.Terminated then
  begin
    FBackgroundThread.Terminate;
    Sleep( 200 );
  end;

  inherited;
end;

procedure TTTLauncher.Finished;
begin
  if Assigned( FOnFinished ) then
    FOnFinished( Self );
end;

function TTTLauncher.GetErrorMsg( ErrorCode: DWord ): string;
begin
   Result := SysErrorMessage(ErrorCode);
end;

procedure TTTLauncher.LaunchError;
begin
  if Assigned( FOnError ) then
    FOnError( Self, FLastErrorCode );
end;

procedure TTTLauncher.DoTimeout;
begin
  if Assigned( FOnTimeout ) then
    FOnTimeout( Self );
end;

procedure TTTLauncher.WaitForProcessAndProcessMsgs;
begin
  repeat
    case MsgWaitForMultipleObjects( 1, FHProcess, False, Cardinal( FTimeout ),
                                    QS_POSTMESSAGE or QS_SENDMESSAGE or QS_ALLPOSTMESSAGE ) of
      WAIT_OBJECT_0:
      begin
        GetExitCodeProcess( FHProcess, FExitCode );
        Finished;
        Break;
      end;

      WAIT_OBJECT_0 + 1:
      begin
        Application.ProcessMessages;
      end;

      WAIT_TIMEOUT:
      begin
        DoTimeout;
        Break;
      end;
    end;

  until False;
end; // TTTLauncher.WaitForProcessAndProcessMsgs

procedure TTTLauncher.WaitForProcessFullStop;
begin
  case WaitForSingleObject( FHProcess, Cardinal( FTimeout ) ) of
    WAIT_FAILED:
    begin
      FLastErrorCode := GetLastError;
      LaunchError;
    end;

    WAIT_OBJECT_0:
    begin
      GetExitCodeProcess( FHProcess, FExitCode );
      Finished;
    end;

    WAIT_TIMEOUT:
      DoTimeout;
  end; { case }
end; // TTTLauncher.WaitForProcessFullStop

procedure TTTLauncher.WaitForProcessFromThread;
var
  Done: Boolean;
  TimeoutCount: Cardinal;
begin
  Done := False;
  TimeoutCount := 0;
  repeat
    case WaitForSingleObject( FHProcess, Cardinal( 100 ) ) of
      WAIT_FAILED:
      begin
        FLastErrorCode := GetLastError;
        FBackgroundThread.Synchronize( LaunchError );
        Done := True;
      end;

      WAIT_OBJECT_0:
      begin
        GetExitCodeProcess( FHProcess, FExitCode );
        FBackgroundThread.Synchronize( Finished );
        Done := True;
      end;

      WAIT_TIMEOUT:
      begin
        Inc( TimeoutCount, 100 );
        if TimeoutCount >= Cardinal( FTimeout ) then
        begin
          FBackgroundThread.Synchronize( DoTimeout );
          Done := True;
        end;
      end;
    end; { case }
  until Done or FBackgroundThread.Terminated;
end; // WaitForProcessFromThread

procedure TTTLauncher.StartDataFile;
var
  ShellInfo: TShellExecuteInfo;
begin
  FLastErrorCode := 0;
  FHInstance := 0;
  FHProcess := 0;
  FExitCode := 0;

  FillChar( ShellInfo, SizeOf( TShellExecuteInfo ), 0 );
  ShellInfo.cbSize := SizeOf( TShellExecuteInfo );
  ShellInfo.fMask := SEE_MASK_NOCLOSEPROCESS or SEE_MASK_FLAG_NO_UI or SEE_MASK_FLAG_DDEWAIT;
  ShellInfo.Wnd := HWnd_Desktop;
  ShellInfo.lpVerb := PChar( FAction );
  ShellInfo.lpFile := PChar( FFileName );
  ShellInfo.lpParameters := PChar( FParameters );
  ShellInfo.lpDirectory := PChar( FStartDir );
  ShellInfo.nShow := ShowWindowModes[ FShowMode ];

  if ShellExecuteEx( @ShellInfo ) then
  begin
    FHInstance := ShellInfo.hInstApp;
    FHProcess := ShellInfo.hProcess;
    FRunning := True;

    try
      if FWaitUntilFinished then
      begin
        if FWaitType = wtFullStop then
          WaitForProcessFullStop
        else
          WaitForProcessAndProcessMsgs;
      end
      else
        WaitForProcessFromThread;
    finally
      CloseHandle( FHProcess );
      FRunning := False;
    end;
  end
  else
  begin
    FLastErrorCode := ShellInfo.hInstApp;
    if FWaitUntilFinished then
      LaunchError
    else
      FBackgroundThread.Synchronize( LaunchError );
  end;
end; { StartDataFile }

procedure TTTLauncher.StartExecutable;
var
  StartupInfo: TStartupInfo;
  ProcessInfo: TProcessInformation;
  lCmd, lDir : string;
  lOK : Boolean;
begin
  FLastErrorCode := 0;
  FHInstance := 0;
  FHProcess := 0;
  FExitCode := 0;

  FillChar( StartupInfo, SizeOf( TStartupInfo ), 0 );
  StartupInfo.cb := SizeOf( TStartupInfo );
  StartupInfo.dwFlags := STARTF_USESHOWWINDOW;
  StartupInfo.wShowWindow := ShowWindowModes[ FShowMode ];

  FillChar( ProcessInfo, SizeOf( TProcessInformation ), 0 );

  lCmd := FFileName;
  if lCmd[1] <> '"' then lCmd := '"' + lCmd + '"';   // Quotes are needed http://stackoverflow.com/questions/265650/paths-and-createprocess

  if FParameters <> '' then lCmd := lCmd+' '+FParameters;

  lDir := FStartDir;

  if lDir='' then
     lOk := CreateProcess(nil,PChar(lCmd),nil,nil,FALSE,0,nil,nil,StartupInfo, ProcessInfo)
  else
     lOk := CreateProcess(nil,PChar(lCmd),nil,nil,FALSE,0,nil,PChar(FStartDir),StartupInfo, ProcessInfo);

  if lOk then
  begin
    FHInstance := 0;  //Niet bekend
    FHProcess  := ProcessInfo.hProcess;
    FHThread   := ProcessInfo.hThread;
    FProcessID := ProcessInfo.dwProcessId;
    FThreadID  := ProcessInfo.dwThreadId;
    FRunning := True;

    try
      if FWaitUntilFinished then
      begin
        if FWaitType = wtFullStop then
          WaitForProcessFullStop
        else
          WaitForProcessAndProcessMsgs;
      end
      else
        WaitForProcessFromThread;
    finally
      CloseHandle( FHThread );
      CloseHandle( FHProcess );
      FRunning := False;
    end;
  end
  else
  begin
    FLastErrorCode := GetLastError;

    if FWaitUntilFinished then
      LaunchError
    else
      FBackgroundThread.Synchronize( LaunchError );
  end;
end; // StartExecutable

procedure TTTLauncher.StartProcess;
var Ext: String;
begin
   Ext := lowercase(ExtractFileExt(FFileName));
   if ((Ext = '.exe') or (Ext = '.com')) and (FRunAsAdministrator = False) then
   begin
      StartExecutable;
   end
   else
   begin
      StartDataFile;
   end;
end; // StartProcess

procedure TTTLauncher.Launch;
begin
  if FRunning or ( FFileName = '' ) then
    Exit;

  if FWaitUntilFinished then
    StartProcess
  else
  begin
    FBackgroundThread := TTTLaunchThread.Create( Self );
    repeat
      Sleep( 10 );
    until FRunning or ( FLastErrorCode <> 0 );
  end;
end;

procedure TTTLauncher.StopProcess( ATimeOut : integer = 5000 );
var
   lTijd : integer;
begin
   // Try to close with quit message
   if FRunning then
   begin
      PostThreadMessage(FThreadID,WM_QUIT, 0, 0);
      Sleep(10);
      Application.ProcessMessages;

      // Wait for process to stop or timeout
      lTijd := 0;
      while FRunning and (lTijd<ATimeOut) do
      begin
         Sleep(10);
         Inc(lTijd,10);
         Application.ProcessMessages;
      end;
   end;

   // Kill process if still running
   if FRunning then
   begin
      TerminateProcess(HProcess,1);
      Sleep(200); // Give it some time to clean up
      Application.ProcessMessages;
   end;

   // Close background thread
   if FRunning and not FWaitUntilFinished and ( FBackgroundThread <> nil ) and not FBackgroundThread.Terminated then
   begin
      FBackgroundThread.Terminate;
      Sleep(200); // Some time to clean up
   end;
end;

Function EnumWindowsProc (Wnd: HWND; AEnumInfo : TTTEnumWinInfo): BOOL; stdcall;
var
  lWndProcessId : integer;
begin
   Result := True;

   GetWindowThreadProcessId(Wnd, @lWndProcessId);

   // Proces ID match? => found (1e window is main window)
   if (lWndProcessId = AEnumInfo.ProcessID) then
   begin
      AEnumInfo.WindowHandle := Wnd;
      Result := False;
   end;
end;

function IsUACEnabled: Boolean;
var
  Reg: TRegistry;
begin
  Result := CheckWin32Version(6, 0);
  if Result then
  begin
    Reg := TRegistry.Create(KEY_READ);
    try
      Reg.RootKey := HKEY_LOCAL_MACHINE;
      if Reg.OpenKey('\Software\Microsoft\Windows\CurrentVersion\Policies\System', False) then
        if Reg.ValueExists('EnableLUA') then
          Result := (Reg.ReadInteger('EnableLUA') <> 0)
        else
          Result := False
      else
        Result := False;
    finally
      FreeAndNil(Reg);
    end;
  end;
end;

procedure TTTLauncher.SetRunAsAdministrator(ARunAsAdministrator : boolean);
begin
   FRunAsAdministrator := ARunAsAdministrator;

   if (FRunAsAdministrator = True) and (IsUACEnabled = False) then
   begin
      FRunAsAdministrator := False;
   end;

   if (FRunAsAdministrator = True) then
   begin
      FAction := 'runas';
   end
   else
   begin
      FAction := 'Open';
   end;
end;

end.

检测应用失败并显示

IsProcessRunning(FPath + EdtProcess.Text,true)

或

IsProcessRunning(FPath + EdtProcess.Text,false)

:

type
   TQueryFullProcessImageNameW = function(AProcess: THANDLE; AFlags: DWORD; AFileName: PWideChar; var ASize: DWORD): BOOL; stdcall;
const
   QueryFullProcessImageNameW: TQueryFullProcessImageNameW = nil;
   PROCESS_QUERY_LIMITED_INFORMATION = $1000;
var
   Kernel32Lib: HMODULE;

function IsProcessRunning(AFileName: string; AIncludePath : Boolean = False): Boolean;
var
  PIDList: array[0..1023] of DWORD;
  i: integer;
  ListCount: cardinal;
  hProcess: THandle;
  lFileName : string;
  lStrModuleName: String;
  Len : DWORD;
begin
  Result:= False;

  if not AIncludePath then
     AFileName := ExtractFileName(AFileName);

  // PSAPI.DLL required
  if not EnumProcesses(@PIDList, sizeof(PIDList), ListCount) then Exit;

  ListCount:= ListCount div sizeof(THandle);

  FrmIsProcRunning.MmoProcesses.Lines.Add('Process count: ' + IntToStr(ListCount));
  FrmIsProcRunning.MmoProcesses.Lines.Add('');

  for i := 0 to ListCount-1 do
  begin

    if assigned(QueryFullProcessImageNameW) then
    begin
       hProcess:= OpenProcess(PROCESS_QUERY_LIMITED_INFORMATION, false, PIDList[i]);

       try
          if hProcess <> 0 then
          begin
             Len := MAX_PATH;
             SetLength(lStrModuleName, Len-1);
             if QueryFullProcessImageNameW( hProcess, 0, PWideChar(lStrModuleName), Len) then
             // Niet meer @Len, maar Len, omdat-ie nu als var parameter gedefinieerd is
             begin
                SetLength(lStrModuleName, Len);
                lFileName := lStrModuleName;
                FrmIsProcRunning.MmoProcesses.Lines.Add(lFilename);
             end;
          end;
       finally
         CloseHandle(hProcess);
       end;
    end;

    if (not AIncludePath) then
       lFileName := ExtractFileName(lFileName);

    if CompareText(lFileName, AFileName) = 0 then
    begin
      Result := true;
      Exit;
    end;
  end;
end;

带有初始化代码：

FPath := ExtractFilePath(ParamStr(0));
Kernel32Lib := GetModuleHandle(kernel32);
QueryFullProcessImageNameW := GetProcAddress(Kernel32Lib, 'QueryFullProcessImageNameW');

我一直在查看

TTTLauncher

，但没有看到哪些内容在 64 位下不再起作用。有什么建议吗？

备注：

所有应用程序均为 64 位，并且位于我具有完全访问权限的同一文件夹（位于 D: 上）
我测试了以调用者身份运行启动应用程序，最高可用，需要管理员
我测试了从 IDE 内部或外部运行启动应用程序
我很惊讶
```
TTTLauncher.StartProcess
```
调用
```
StartDataFile
```
（不是
```
StartExecutable
```
），因为
```
FRunAsAdministrator
```
是真的。为什么会这样呢？（旧代码，不是我的）
Windows 10

Answer 1

哇，问题是

EnumProcesses()

没有“检测”正在运行的进程的PID。但看看这个：

var
  PIDList: array[0..1023] of DWORD;
  ListCount: cardinal;
begin
  if not EnumProcesses(@PIDList, sizeof(PIDList), ListCount) then Exit;
  ListCount:= ListCount div sizeof(THandle);  // <=== !!!

```
sizeof(THandle)
```
= 8,
```
sizeof(DWORD)
```
= 4（均在 64 位平台上）

我将代码更改为：

ListCount := ListCount div sizeof(DWORD);

这给了我大约 150 个（之前：73 个），这更符合我在任务管理器中看到的情况。然后在列表中“找到”PID。

^{* 32位代码使用了}

THandle

，当转为64位时我将其更改为

DWORD

，但忘记了

ListCount

计算。

在 EnumProcesses 列表中未检测到使用 ShellExecuteEx 启动的应用程序

问题描述投票：0回答：1

1个回答

最新问题

在 EnumProcesses 列表中未检测到使用 ShellExecuteEx 启动的应用程序

问题描述 投票：0回答：1

1个回答

最新问题

问题描述投票：0回答：1