Private Declare Function OpenProcessToken Lib "advapi32" (ByVal ProcessHandle As Long, ByVal DesiredAccess As Long, TokenHandle As Long) As Long
Private Declare Function GetModuleFileNameEx Lib "psapi.dll" Alias "GetModuleFileNameExW" (ByVal hProcess As Long, ByVal hModule As Long, ByVal lpFileName As Long, ByVal nSize As Long) As Long
Private Declare Function GetProcessImageFileName Lib "psapi.dll" Alias "GetProcessImageFileNameW" (ByVal hProcess As Long, ByVal lpImageFileName As Long, ByVal nSize As Long) As Long
Private Declare Function GetFullPathName Lib "kernel32.dll" Alias "GetFullPathNameW" (ByVal lpFileName As Long, ByVal nBufferLength As Long, ByVal lpBuffer As Long, lpFilePart As Long) As Long
Private Declare Function QueryFullProcessImageName Lib "kernel32.dll" Alias "QueryFullProcessImageNameW" (ByVal hProcess As Long, ByVal dwFlags As Long, ByVal lpExeName As Long, ByVal lpdwSize As Long) As Long
Private Declare Function GetLogicalDriveStrings Lib "kernel32.dll" Alias "GetLogicalDriveStringsW" (ByVal nBufferLength As Long, ByVal lpBuffer As Long) As Long
Private Declare Function QueryDosDevice Lib "kernel32.dll" Alias "QueryDosDeviceW" (ByVal lpDeviceName As Long, ByVal lpTargetPath As Long, ByVal ucchMax As Long) As Long
Function GetFilePathByPID(PID As Long) As String
Const MAX_PATH_W As Long = 32767&
Const PROCESS_VM_READ As Long = 16&
Const PROCESS_QUERY_INFORMATION As Long = 1024&
Const PROCESS_QUERY_LIMITED_INFORMATION As Long = &H1000&
Dim ProcPath As String
Dim hProc As Long
Dim cnt As Long
Dim pos As Long
Dim FullPath As String
Dim SizeOfPath As Long
Dim lpFilePart As Long
hProc = OpenProcess(IIf(bIsWinVistaOrLater, PROCESS_QUERY_LIMITED_INFORMATION, PROCESS_QUERY_INFORMATION) Or PROCESS_VM_READ, 0&, PID)
If hProc <> 0 Then
If bIsWinVistaOrLater Then
cnt = MAX_PATH_W + 1
ProcPath = Space$(cnt)
Call QueryFullProcessImageName(hProc, 0&, StrPtr(ProcPath), VarPtr(cnt))
End If
If 0 <> err.LastDllError Or Not bIsWinVistaOrLater Then 'Win 2008 Server (x64) can cause Error 128 if path contains space characters
ProcPath = Space$(MAX_PATH)
cnt = GetModuleFileNameEx(hProc, 0&, StrPtr(ProcPath), Len(ProcPath))
If cnt = MAX_PATH Then 'Path > MAX_PATH -> realloc
ProcPath = Space$(MAX_PATH_W)
cnt = GetModuleFileNameEx(hProc, 0&, StrPtr(ProcPath), Len(ProcPath))
End If
End If
If cnt <> 0 Then 'clear path
ProcPath = Left$(ProcPath, cnt)
If StrComp("\SystemRoot\", Left$(ProcPath, 12), 1) = 0 Then ProcPath = sWinDir & Mid$(ProcPath, 12)
If "\??\" = Left$(ProcPath, 4) Then ProcPath = Mid$(ProcPath, 5)
End If
If ERROR_PARTIAL_COPY = err.LastDllError Or cnt = 0 Then 'because GetModuleFileNameEx cannot access to that information for 64-bit processes on WOW64
ProcPath = Space$(MAX_PATH)
cnt = GetProcessImageFileName(hProc, StrPtr(ProcPath), Len(ProcPath))
If cnt <> 0 Then
ProcPath = Left$(ProcPath, cnt)
' Convert DosDevice format to Disk drive format
If StrComp(Left$(ProcPath, 8), "\Device\", 1) = 0 Then
pos = InStr(9, ProcPath, "\")
If pos <> 0 Then
FullPath = ConvertDosDeviceToDriveName(Left$(ProcPath, pos - 1))
If Len(FullPath) <> 0 Then
ProcPath = FullPath & Mid$(ProcPath, pos + 1)
End If
End If
End If
End If
End If
If cnt <> 0 Then 'if process ran with 8.3 style, GetModuleFileNameEx will return 8.3 style on x64 and full pathname on x86
'so wee need to expand it ourself
FullPath = Space$(MAX_PATH)
SizeOfPath = GetFullPathName(StrPtr(ProcPath), MAX_PATH, StrPtr(FullPath), lpFilePart)
If SizeOfPath <> 0& Then
GetFilePathByPID = Left$(FullPath, SizeOfPath)
Else
GetFilePathByPID = ProcPath
End If
End If
CloseHandle hProc
End If
End Function
Public Function ConvertDosDeviceToDriveName(inDosDeviceName As String) As String
On Error Resume Next
Static DosDevices As New Collection
If DosDevices.Count Then
ConvertDosDeviceToDriveName = DosDevices(inDosDeviceName)
Exit Function
End If
Dim aDrive() As String
Dim sDrives As String
Dim cnt As Long
Dim i As Long
Dim DosDeviceName As String
cnt = GetLogicalDriveStrings(0&, StrPtr(sDrives))
sDrives = Space(cnt)
cnt = GetLogicalDriveStrings(Len(sDrives), StrPtr(sDrives))
If 0 = err.LastDllError Then
aDrive = Split(Left$(sDrives, cnt - 1), vbNullChar)
For i = 0 To UBound(aDrive)
DosDeviceName = Space(MAX_PATH)
cnt = QueryDosDevice(StrPtr(Left$(aDrive(i), 2)), StrPtr(DosDeviceName), Len(DosDeviceName))
If cnt <> 0 Then
DosDeviceName = Left$(DosDeviceName, InStr(DosDeviceName, vbNullChar) - 1)
DosDevices.Add aDrive(i), DosDeviceName
End If
Next
End If
ConvertDosDeviceToDriveName = DosDevices(inDosDeviceName)
End Function