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
ProcPath = Space$(MAX_PATH)
cnt = GetModuleFileNameEx(hProc, 0&, StrPtr(ProcPath), Len(ProcPath))
If cnt = MAX_PATH Then
ProcPath = Space$(MAX_PATH_W)
cnt = GetModuleFileNameEx(hProc, 0&, StrPtr(ProcPath), Len(ProcPath))
End If
End If
If cnt <> 0 Then
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
ProcPath = Space$(MAX_PATH)
cnt = GetProcessImageFileName(hProc, StrPtr(ProcPath), Len(ProcPath))
If cnt <> 0 Then
ProcPath = Left$(ProcPath, cnt)
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
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