Code funktioniert mit WindowsXP, nicht mit WindowsXP 64

[Shark99]

Hi!

Dieser Code funktioniert mit WindowsXP.

In WindowsXP 64 jedoch, geht er nur mit PIDs von 32 bit Prozessen.

Hier ist der Code:

Delphi-Quellcode:

function GetProcessFilePath(pid:cardinal):string;
var
  hp: THandle;
  Buffer1: array[0..MAX_PATH] of Char;
begin
  Result := '';

  if pid > 0 then
  begin
    hp := OpenProcess(PROCESS_ALL_ACCESS,False,pid);

    if hp > 0 then
    begin
      if GetModuleFileNameEx(hp,0,Buffer1,SizeOf(Buffer1)) > 0 then
      begin
        Result := PathGetLongName(ExtractFilePath(Buffer1));
        CloseHandle(hp);
        Exit;
      end else
      begin
          Result := SysErrorMessage(GetLastError);
      end;
      CloseHandle(hp);
    end;
  end;
end;

GetModuleFileNameEx schlägt fehl wenn PID zu einem 64bit Prozess gehört (z.B. Notepad.exe).

GetLastError gibt dann: Only part of ReadProcessMemory or WriteProcessMemory request was completed

Was ich bis jetzt versuchte (hat alles nicht geholfen).

Priviliges geändert mit:

Delphi-Quellcode:

procedure EnableAllPrivileges;
var c1, c2 : dword;
    ptp    : PTokenPrivileges;
    i1     : integer;
begin
  if OpenProcessToken(windows.GetCurrentProcess, TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, c1) then
    try
      c2 := 0;
      GetTokenInformation(c1, TokenPrivileges, nil, 0, c2);
      if c2 <> 0 then begin
        ptp := AllocMem(c2);
        if GetTokenInformation(c1, TokenPrivileges, ptp, c2, c2) then begin
          for i1 := 0 to integer(ptp^.PrivilegeCount) - 1 do
            ptp^.Privileges[i1].Attributes := ptp^.Privileges[i1].Attributes or SE_PRIVILEGE_ENABLED;
          AdjustTokenPrivileges(c1, false, ptp^, c2, PTokenPrivileges(nil)^, cardinal(pointer(nil)^));
        end;
        FreeMem(ptp);
      end;
    finally CloseHandle(c1) end;
end;

und auch

File System 64 -> 32 bit Redirection abgeschaltet:

Delphi-Quellcode:

function ChangeFSRedirection(bDisable: Boolean): Boolean;
type
     TWow64DisableWow64FsRedirection = Function(Var Wow64FsEnableRedirection: LongBool): LongBool; StdCall;
     TWow64EnableWow64FsRedirection  = Function(var Wow64FsEnableRedirection: LongBool): LongBool; StdCall;
var
    hHandle: THandle;
    Wow64DisableWow64FsRedirection: TWow64DisableWow64FsRedirection;
    Wow64EnableWow64FsRedirection:  TWow64EnableWow64FsRedirection;
    Wow64FsEnableRedirection:       LongBool;
begin
  Result := false;

  if not IsWindows64 then
     Exit;

  try
    hHandle := GetModuleHandle('kernel32.dll');
    @Wow64EnableWow64FsRedirection  := GetProcAddress(hHandle, 'Wow64EnableWow64FsRedirection');
    @Wow64DisableWow64FsRedirection := GetProcAddress(hHandle, 'Wow64DisableWow64FsRedirection');

    if bDisable then
    begin
     if (hHandle <> 0) and (@Wow64DisableWow64FsRedirection <> nil) then
     begin
       Wow64DisableWow64FsRedirection(Wow64FsEnableRedirection);
       Result := True;
     end;
    end else
    begin
     if (hHandle <> 0) and (@Wow64EnableWow64FsRedirection <> nil) then
     begin
       Wow64EnableWow64FsRedirection(Wow64FsEnableRedirection);
       Result := True;
     end;
    end;
  Except
  end;
end;

p.s.

alles andere (64 Bit Prozess beenden, andere Infos wie CPU Usage holen) funktioniert ohne Probleme!

[Lasse2002]

Mit GetProcessImageFileName funktioniert es auch mit 64bit Prozessen. Statt SizeOf(buffer1) solltest du unbedingt Length(buffer1) schreiben, dann geht es auch mit Delphi 2009 und neuer.

Delphi-Quellcode:

function GetProcessImageFileName(    // ab XP
  hProcess: tHANDLE;
  lpImageFileName: LPTSTR;
  nSize: DWORD): DWORD; stdcall; external 'psapi.dll' name 'GetProcessImageFileName'+{$IFDEF UNICODE}'W'{$ELSE}'A'{$ENDIF};

function GetProcessFilePath(pid:cardinal):string;
var
  hp: THandle;
  Buffer1: array[0..MAX_PATH] of Char;
  Len: DWORD;
begin
  Result := '';

  if pid > 0 then
  begin
    hp := OpenProcess(PROCESS_QUERY_INFORMATION, False, pid);
    if hp > 0 then
      try
        Len := GetProcessImageFileName(hp, buffer1, Length(buffer1));
        if Len > 0 then
          Result := Copy(buffer1, 1, Len)
        else
          Result := SysErrorMessage(GetLastError);
      finally
        CloseHandle(hp);
      end;
  end;
end;

[Shark99]

Das Programm wurde mit Delphi 5 geschrieben. Hier bringt eine Änderung auf Length nichts. Würde mich auch wundern, es gibt ja keinen Unterschied zwischen Sizeof und Length bei einem Array.

Es scheint auch kein Unicode Problem zu sein, weil ich auch GetModuleFileNameExW testete (mit einem WideString buffer) und das Ergebnis war gleich (das heisst gleiche Fehlermeldung).

[Lasse2002]

SizeOf und Length sind identisch in Delphi 5, aber vielleicht willst du ja irgendwann mal upgraden, z.B. auf Delphi x64 wenn es da ist?

Aber schau dir trotzdem mal mein Beispiel an, das verwendet GetProcessImageFileName um dein Problem zu lösen. :wink:

[Shark99]

Mit GetProcessImageFileName klappt es unter 64 bit! Danke für den Tipp.

Allerdings kommen die Pfade dann als

\Device\HardDiskVolume1\Windows\System32

Hat jemand eine Ahnung wie man es ins

c:\Windows\System32

umwandelt?

[Shark99]

Damit könnte es gehen:

http://msdn.microsoft.com/en-us/library/ms684919(VS.85).aspx

ist aber leider Vista only. Es muss aber auch unter WindowsXP x64 funktionieren.

[nicodex]

Kannst es ja mit Win32_Process.ExecutablePath versuchen (oder über das Property CommandLine, welches aber andere Informationen enthält).
Man könnte es noch über den Process Environment Block auslesen (nur für die aktuellen Windows-Versionen dokumentiert und für Win64 ziemlich aufwendig).

[Shark99]

Commandline für fremde Prozesse?

[nicodex]

Zitat:

Zitat von Shark99

Commandline für fremde Prozesse?

Ja, siehe folgende Diskussion:
http://forum.madshi.net/viewtopic.php?t=4768

[Shark99]

Hab hier eine fast komplette Lösung:

Delphi-Quellcode:

function DevicePathToWin32Path(path:string):string;
var c:char;
    s:string;
    i:integer;
begin
  i:=posex('\', path, 2);
  i:=posex('\', path, i+1);
  result:=copy(path, i, length(path));
  delete(path, i, length(path));
  for c:='A' to 'Z' do
  begin
    setlength(s, 1000);
    if querydosdevice(pchar(string(c)+':'), pchar(s), 1000)<>0 then
    begin
      s:=pchar(s);
      if sametext(path, s) then
      begin
        result:=c+':'+result;
        exit;
      end;
    end;
  end;
  result:='';
end;


function GetProcessFilePath(pid:cardinal):string;
var
  hp: THandle;
  Buffer1: array[0..MAX_PATH] of Char;
begin
  Result := '';

  if pid > 0 then
  begin
    hp := OpenProcess(PROCESS_ALL_ACCESS,False,pid);

    if hp > 0 then
    begin
        if IsWinNT4 or IsWin2K then
        begin
             if GetModuleFileNameEx(hp,0,Buffer1,Length(Buffer1)) > 0 then
               Result := PathGetLongName(
                              StringReplace(
                                             ExtractFilePath( Buffer1 ),
                                             '\??\', '', [rfReplaceAll, rfIgnoreCase]
                                           )
                                        );
        end else
        begin
             GetProcessImageFileName(hp, Buffer1, Length(Buffer1));

             Result := PathGetLongName(
                              StringReplace(
                                             ExtractFilePath(
                                                  DevicePathToWin32Path(Buffer1)
                                                            ),
                                             '\??\', '', [rfReplaceAll, rfIgnoreCase]
                                           )
                                      );
        end;
        CloseHandle(hp);
    end;
  end;
end;

Leider startet die Exe mit Windows 2000 erst gar nicht (GetProcessImageFileNameA entry point not found).