Using Process32First/Next inside DLL procedure

问题:

I have the following procedure:

procedure MyMainThread.MapProc;
var
  Handle: THandle;
  PID: dword;
  Struct: TProcessEntry32;
  Processes: TStringList;
begin
  Handle:= CreateToolHelp32SnapShot(TH32CS_SNAPPROCESS, 0);
  Struct.dwSize:=Sizeof(TProcessEntry32);
  Process32First(Handle, Struct);
  Processes:= TStringList.Create;
  repeat
    Processes.Add(Struct.szExeFile);
    Processes.SaveToFile('C:\Log.txt');
    PID:= Struct.th32ProcessID;
    PIDHandle:= OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_OPERATION or
      PROCESS_VM_READ, false, PID);
    CloseHandle(PIDHandle);
  until (not Process32Next(Handle,Struct));
  Processes.Free;
end;

As you can see, I save the running processes inside C:\Log.txt, and this works nice when inside an .exe file. Now I'm trying to implement this inside a .DLL file, and the concept is: The DLL will be loaded, and it will have an EntryPoint calling a Thread.Create... This Thread will use a SetTimer to run the procedure MapProc every 10 seconds to save the running processes in C:\Log.txt. The code is:

library Project1;

uses
  Windows,
  SysUtils,
  Classes,
  Registry,
  EncdDecd,
  TLHelp32,
  IdHTTP;

{$R *.res}
type
  MyMainThread = Class(TThread)
  var
    DestDir, ContactHost: String;
    Sent: TStringList;
    PIDHandle: THandle; //need to be public because we use in MapProc / CatchYa
  private
    procedure MapProc;
    procedure MapMemory(ProcessName: string);
    procedure CreateMessagePump;
  protected
    constructor Create;
    procedure Execute; override;
  end;

constructor MyMainThread.Create;
begin
  inherited Create(false);
  FreeOnTerminate:= true;
  Priority:= tpNormal;
end;

procedure MyMainThread.Execute;
begin
  while not Terminated do
    begin
      SetTimer(0, 0, 10000, @MyMainThread.MapProc); //setting timer 10 seconds calling MapProc
      CreateMessagePump; //we are inside DLL so I think we need Message Pump to timer work
      Terminate;
    end;
end;


procedure MyMainThread.MapProc;
var
  Handle: THandle;
  PID: dword;
  Struct: TProcessEntry32;
  Processes: TStringList;
begin
  Handle:= CreateToolHelp32SnapShot(TH32CS_SNAPPROCESS, 0);
  Struct.dwSize:=Sizeof(TProcessEntry32);
  Process32First(Handle, Struct);
  Processes:= TStringList.Create;
  repeat
    Processes.Add(Struct.szExeFile);
    Processes.SaveToFile('C:\Log.txt');
    PID:= Struct.th32ProcessID;
    PIDHandle:= OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_OPERATION or
      PROCESS_VM_READ, false, PID);
    if POS(Struct.szExeFile, ExeName) = 0 then
      MapMemory(Struct.szExeFile); //procedure called for verification purposes, but it's not even getting called
    CloseHandle(PIDHandle);
  until (not Process32Next(Handle,Struct));
  Processes.Free;
end;


procedure MyMainThread.CreateMessagePump;
var
  AppMsg: TMsg;
begin
  while GetMessage(AppMsg, 0, 0, 0) do
    begin
      TranslateMessage(AppMsg);
      DispatchMessage(AppMsg);
    end;
  //if needed to quit this procedure use PostQuitMessage(0);
end;


procedure EntryPoint(Reason: integer);
begin
  if Reason = DLL_PROCESS_ATTACH then
    begin
      MyMainThread.Create;
    end
  else
  if Reason = DLL_PROCESS_DETACH then
    begin
      MessageBox(0, 'DLL De-Injected', 'DLL De-Injected', 0);
    end;
end;

begin
  DLLProc:= @EntryPoint;
  EntryPoint(DLL_PROCESS_ATTACH);
end.

But when running this, I get in the Log.txt file only the line: [System Process]

The exe hosting DLL is:

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;


implementation

{$R *.dfm}



procedure TForm1.Button1Click(Sender: TObject);
var
  HD: THandle;
begin
  HD:= LoadLibrary('C:\Project1.dll');
end;

end.

回答1:

The reason that your code fails is that you're not using a proper callback for the SetTimer function. As per the documentation that should have a signature like

procedure (hwnd: HWND; uMsg: UINT; idEvent: UINT_PTR; dwTime: DWORD); stdcall;

Your incompatible callback - which is a class method - causes the code to think the Self lives at a completely arbitrary memory address, as class methods has an implicit Self parameter but winapi has no knowledge of that. Now when the code tries to write to an invalid address - 'PIDHandle', assuming there should be a class field, an AV is raised and since the exception is not handled the rest of the code is not executed - also as explained in David's answer.

Your solution is to use a proper callback. To access class members you can use a global variable. Not using a global variable would require some hacky code (google for MethodToProcedure f.i.)

A sample could be like:

threadvar
  MyThread: MyMainThread;

procedure TimerProc(hwnd: HWND; uMsg: UINT; idEvent: UINT_PTR; dwTime: DWORD);
  stdcall;
var
  Handle: THandle;
  PID: dword;
  Struct: TProcessEntry32;
  Processes: TStringList;
begin
  Handle:= CreateToolHelp32SnapShot(TH32CS_SNAPPROCESS, 0);
  Struct.dwSize:=Sizeof(TProcessEntry32);
  Process32First(Handle, Struct);
  Processes:= TStringList.Create;
  repeat
    Processes.Add(Struct.szExeFile);
    Processes.SaveToFile('C:\Temp\Log3.txt');
    PID:= Struct.th32ProcessID;
    MyThread.PIDHandle:= OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_OPERATION or
      PROCESS_VM_READ, false, PID);
    if POS(Struct.szExeFile, ExeName) = 0 then
      MyThread.MapMemory(Struct.szExeFile);
    CloseHandle(MyThread.PIDHandle);
  until (not Process32Next(Handle,Struct));
  Processes.Free;
end;

procedure MyMainThread.Execute;
begin
  while not Terminated do
    begin
      MyThread := Self;
      SetTimer(0, 0, 10000, @TimerProc);
      CreateMessagePump;
      Terminate;
    end;
end;

To take David's advice, not to get beaten by the '@' operator, we should first redeclare the SetTimer function to use the callback correctly. That would look something like:

threadvar
  MyThread: MyMainThread;

procedure TimerProc(hwnd: HWND; uMsg: UINT; idEvent: UINT_PTR; dwTime: DWORD);
  stdcall;
var
  ..
begin
  ..
end;

type
  TFnTimerProc = procedure (hwnd: HWND; uMsg: UINT; idEvent: UIntPtr;
      dwTime: DWORD); stdcall;

function SetTimer(hWnd: HWND; nIDEvent: UIntPtr; uElapse: UINT;
  lpTimerFunc: TFNTimerProc): UINT; stdcall; external user32;

procedure MyMainThread.Execute;
begin
  MyThread := Self;
  SetTimer(0, 0, 10000, TimerProc);
  CreateMessagePump;
end;

回答2:

Here's a version that works as you'd expect. This proves that process enumeration using toolhelp32 works perfectly well from a DLL.

Library

library ProcessEnumLib;

uses
  SysUtils, Classes, Windows, TlHelp32;

type
  TMyThread = class(TThread)
  protected
    procedure Execute; override;
  end;

procedure TMyThread.Execute;
var
  Handle: THandle;
  PID: dword;
  ProcessEntry: TProcessEntry32;
  Processes: TStringList;
begin
  Handle := CreateToolHelp32SnapShot(TH32CS_SNAPPROCESS, 0);
  Win32Check(Handle<>0);
  try
    ProcessEntry.dwSize := Sizeof(TProcessEntry32);
    Win32Check(Process32First(Handle, ProcessEntry));
    Processes := TStringList.Create;
    try
      repeat
        Processes.Add(ProcessEntry.szExeFile);
      until not Process32Next(Handle, ProcessEntry);
      Processes.SaveToFile('C:\Desktop\Log.txt');
    finally
      Processes.Free;
    end;
  finally
    CloseHandle(Handle);
  end;
end;

begin
  TMyThread.Create;
end.

Host

program ProcessEnumHost;

{$APPTYPE CONSOLE}

uses
  Windows;

begin
  LoadLibrary('ProcessEnumLib.dll');
  Sleep(1000);
end.

Your version is failing because the call to OpenProcess is raising an access violation which is killing the thread. Right now, I'm not sure why that is so.

I suggest that you simplify grossly. You don't need a message loop, and you don't need a timer. You can use Sleep in your thread to pause between process maps. Something like this:

library ProcessEnumLib;

uses
  SysUtils, Classes, Windows, TlHelp32;

type
  TMyThread = class(TThread)
  protected
    procedure Execute; override;
  end;

procedure TMyThread.Execute;
var
  Handle, ProcessHandle: THandle;
  ProcessEntry: TProcessEntry32;
  Processes: TStringList;
begin
  while True do
  begin
    Handle := CreateToolHelp32SnapShot(TH32CS_SNAPPROCESS, 0);
    Win32Check(Handle<>0);
    try
      ProcessEntry.dwSize := Sizeof(TProcessEntry32);
      Win32Check(Process32First(Handle, ProcessEntry));
      Processes := TStringList.Create;
      try
        repeat
          Processes.Add(ProcessEntry.szExeFile);
          ProcessHandle := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_OPERATION or PROCESS_VM_READ, false, ProcessEntry.th32ProcessID);
          CloseHandle(ProcessHandle);
        until not Process32Next(Handle, ProcessEntry);
        Processes.SaveToFile('C:\Desktop\Log.txt');
      finally
        Processes.Free;
      end;
    finally
      CloseHandle(Handle);
    end;

    Sleep(10000);//10s sleep
  end;
end;

begin
  TMyThread.Create;
end.

I've no idea why, but this variant avoids the AV when calling OpenProcess. I'd love to know why. But it's the right way for you to do what you want, and it side-steps the problem.