Функция QueryFullProcessImageName врёт и возвращает неправильный, уже не существующий, путь к исполняемому файлу

Option Explicit
Private Declare Function QueryFullProcessImageName Lib "kernel32" Alias "QueryFullProcessImageNameW" (ByVal hProcess As Long, ByVal dwFlags As Long, ByVal lpExeName As Long, lpdwSize As Long) As Long
Private Const MAX_PATH As Long = 260
 
Public Function AppPath() As String
    Dim strProcName As String
    Dim lStr As Long
    
    strProcName = Space$(MAX_PATH * 2): lStr = MAX_PATH
    QueryFullProcessImageName -1, 0, StrPtr(strProcName), lStr
    strProcName = Left$(strProcName, lStr)
    
    AppPath = Left$(strProcName, InStrRev(strProcName, "\"))
End Function
 
Private Sub Command1_Click()
    Me.Cls
    PrintW Chr(34) & AppPath & Chr(34), Me
End Sub
 
Private Sub Command2_Click()
    Me.Cls
    PrintW Chr(34) & App.Path & Chr(34), Me
End Sub

Option Explicit
Private Declare Function DrawText Lib "user32" Alias "DrawTextW" (ByVal hdc As Long, ByVal lpStr As Long, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
 
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
 
Private Const DT_CENTER = &H1
Private Const DT_SINGLELINE = &H20
Private Const DT_VCENTER = &H4
 
Public Function PrintW(PrintText As String, PrintForm As Form)
    Dim myRect As RECT
    
    myRect.Left = 0
    myRect.Top = 0
    myRect.Right = PrintForm.ScaleWidth
    myRect.Bottom = PrintForm.ScaleHeight
    
    DrawText PrintForm.hdc, StrPtr(PrintText), Len(PrintText), myRect, DT_SINGLELINE Or DT_VCENTER Or DT_CENTER
End Function

If Right$(AppPath, 1) = "\" Then AppPath = Mid$(AppPath, 1, Len(AppPath) - 1)

Option Explicit
 
Private Declare Function GetModuleFileNameW Lib "kernel32.dll" (ByVal hModule As Long, ByVal lpFilename As Long, ByVal nSize As Long) As Long
Private Declare Function PathRemoveFileSpecW Lib "shlwapi.dll" (ByVal pszPath As Long) As Byte
 
Private Const MAX_PATH As Long = 260
 
' It works faster here than Static inside the function
Dim SaveAppPath As String
 
Private Function MakeTrue(ByRef bValue As Boolean) As Boolean
    MakeTrue = True
    bValue = True
End Function
 
' //
' // App.Path - Unicode aware
' // by The Trick and HackerVlad
' //
Public Function AppPath() As String
    Dim bInIDE As Boolean
    Dim lNullPos As Long
    
    If Len(SaveAppPath) > 0 Then
        AppPath = SaveAppPath
    Else
        Debug.Assert MakeTrue(bInIDE)
        
        If bInIDE Then
            AppPath = App.Path
            SaveAppPath = AppPath
        Else
            AppPath = Space$(MAX_PATH)
            GetModuleFileNameW 0, StrPtr(AppPath), 260
            PathRemoveFileSpecW StrPtr(AppPath)
            
            lNullPos = InStr(1, AppPath, vbNullChar)
            If lNullPos Then
                AppPath = Left$(AppPath, lNullPos - 1)
                If Right$(AppPath, 1) = "\" Then AppPath = Mid$(AppPath, 1, Len(AppPath) - 1)
                SaveAppPath = AppPath
            Else
                AppPath = App.Path
                If Right$(AppPath, 1) = "\" Then AppPath = Mid$(AppPath, 1, Len(AppPath) - 1)
                SaveAppPath = AppPath
            End If
        End If
    End If
End Function

Option Explicit
Private Declare Function GetModuleFileNameW Lib "kernel32.dll" (ByVal hModule As Long, ByVal lpFilename As Long, ByVal nSize As Long) As Long
Private Declare Function PathRemoveFileSpecW Lib "shlwapi.dll" (ByVal pszPath As Long) As Long
 
Private Const MAX_PATH As Long = 260
 
' It works faster here than Static inside the function
Dim SaveAppPath As String
 
Private Function MakeTrue(ByRef bValue As Boolean) As Boolean
    MakeTrue = True
    bValue = True
End Function
 
' //
' // App.Path - Unicode aware
' // by The Trick and HackerVlad
' //
Public Function AppPath() As String
    Dim bInIDE As Boolean
    Dim lNullPos As Long
    
    If Len(SaveAppPath) > 0 Then
        AppPath = SaveAppPath
    Else
        Debug.Assert MakeTrue(bInIDE)
        
        If bInIDE Then
            AppPath = App.Path
            SaveAppPath = AppPath
        Else
            AppPath = Space$(MAX_PATH)
            GetModuleFileNameW 0, StrPtr(AppPath), 260
            PathRemoveFileSpecW StrPtr(AppPath)
            
            lNullPos = InStr(1, AppPath, vbNullChar)
            If lNullPos Then
                AppPath = Left$(AppPath, lNullPos - 1)
            Else
                AppPath = App.Path
            End If
            
            If Right$(AppPath, 1) = "\" Then AppPath = Mid$(AppPath, 1, Len(AppPath) - 1)
            SaveAppPath = AppPath
        End If
    End If
End Function

Option Explicit
Private Declare Function NtQuerySystemInformation Lib "ntdll.dll" (ByVal infoClass As Long, Buffer As Any, ByVal BufferSize As Long, ret As Long) As Long
Private Declare Function GetMem4 Lib "msvbvm60" (src As Any, dst As Any) As Long
Private Declare Function GetMem8 Lib "msvbvm60" (src As Any, dst As Any) As Long
Private Declare Function GetLogicalDriveStrings Lib "kernel32" Alias "GetLogicalDriveStringsW" (ByVal nBufferLength As Long, ByVal lpBuffer As Long) As Long
Private Declare Function QueryDosDevice Lib "kernel32" Alias "QueryDosDeviceA" (ByVal lpDeviceName As String, ByVal lpTargetPath As String, ByVal ucchMax As Long) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenW" (ByVal lpString As Long) As Long
Private Declare Sub memcpy Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function GetModuleFileNameExW Lib "psapi.dll" (ByVal hProcess As Long, ByVal hModule As Long, ByVal ModuleName As Long, ByVal nSize As Long) As Long
Private Declare Function NtWow64QueryInformationProcess64 Lib "ntdll.dll" (ByVal ProcessHandle As Long, ByVal InformationClass As Long, ByRef ProcessInformation As Any, ByVal ProcessInformationLength As Long, ByRef ReturnLength As Long) As Long
Private Declare Function NtWow64ReadVirtualMemory64 Lib "ntdll.dll" (ByVal hProcess As Long, ByVal BaseAddress As Currency, ByRef Buffer As Any, ByVal BufferLengthL As Long, ByVal BufferLengthH As Long, ByRef ReturnLength As Currency) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
 
Private Const SystemProcessInformation As Long = &H5&
Private Const SystemProcessIdInformation = 88
Private Const ProcessBasicInformation = 0
Private Const STATUS_INFO_LENGTH_MISMATCH As Long = &HC0000004
Private Const STATUS_SUCCESS As Long = 0&
Private Const MAX_PATH = 260
Private Const PROCESS_QUERY_INFORMATION = 1024
Private Const PROCESS_VM_READ = 16
 
Private Type UNICODE_STRING
    Length As Integer
    MaxLength As Integer
    lpBuffer As Long
End Type
 
Private Type SYSTEM_PROCESS_ID_INFORMATION
    ProcessId As Long
    ImageName As UNICODE_STRING
End Type
 
Private Type PROCESS_BASIC_INFORMATION_WOW64
    ExitStatus As Long
    Reserved0 As Long
    PebBaseAddress As Currency
    AffinityMask As Currency
    BasePriority As Long
    Reserved1 As Long
    UniqueProcessId As Currency
    InheritedFromUniqueProcessId As Currency
End Type
 
Private Type UNICODE_STRING64
    Length As Integer
    MaxLength As Integer
    Fill As Long
    lpBuffer As Currency
End Type
 
Private Function GetProcessFullPathEx(ByVal pid As Long) As String
    Dim spii As SYSTEM_PROCESS_ID_INFORMATION
    Dim ProcName As String
    Dim cbRet As Long
    Dim cbMax As Long
    Dim sDrives As String
    Dim strBuff As String * MAX_PATH
    Dim DosDeviceName As String
    Dim cnt As Long
    Dim aDrive() As String
    Dim i As Long
    
    cbMax = MAX_PATH * 2
    ProcName = Space$(cbMax)
    
    spii.ProcessId = pid
    spii.ImageName.MaxLength = cbMax
    spii.ImageName.lpBuffer = StrPtr(ProcName)
    
    If NtQuerySystemInformation(SystemProcessIdInformation, spii, LenB(spii), cbRet) >= 0 Then
        ProcName = Left$(ProcName, spii.ImageName.Length / 2)
        
        cnt = GetLogicalDriveStrings(0&, StrPtr(sDrives))
        sDrives = Space$(cnt * 2)
        cnt = GetLogicalDriveStrings(Len(sDrives), StrPtr(sDrives))
        
        If Err.LastDllError = 0 Then
            aDrive = Split(Left$(sDrives, cnt - 1), vbNullChar)
            
            For i = 0 To UBound(aDrive)
                If QueryDosDevice(Left$(aDrive(i), 2), strBuff, MAX_PATH) Then
                    DosDeviceName = Left$(strBuff, lstrlen(StrPtr(strBuff)))
                    
                    If InStr(1, ProcName, DosDeviceName, vbTextCompare) > 0 Then
                        GetProcessFullPathEx = Replace(ProcName, DosDeviceName, Left$(aDrive(i), 2), , 1, vbTextCompare)
                        Exit Function
                    End If
                End If
            Next
        End If
    End If
End Function
 
' This function should get the correct paths, unlike another functions which can sometimes cheat
Private Function GetProcessPathName(ByVal pid As Long) As String
    Dim hProc As Long
    Dim lStr As Long
    Dim strProcName As String
    Dim cmd64 As UNICODE_STRING64
    Dim pbi64 As PROCESS_BASIC_INFORMATION_WOW64
    Dim pParam64 As Currency
    Dim i As Long
    
    hProc = OpenProcess(PROCESS_QUERY_INFORMATION Or PROCESS_VM_READ, 0, pid)
    
    If hProc > 0 Then
        strProcName = Space$(MAX_PATH)
                
        If GetModuleFileNameExW(hProc, 0, StrPtr(strProcName), MAX_PATH) Then
            strProcName = Left$(strProcName, lstrlen(StrPtr(strProcName)))
            strProcName = Replace(strProcName, "\??\", vbNullString)
            strProcName = Replace(strProcName, "%SystemRoot%", Environ("windir"))
            strProcName = Replace(strProcName, "\SystemRoot", Environ("windir"))
            GetProcessPathName = strProcName
        Else ' 64-bit process
            If NtWow64QueryInformationProcess64(hProc, ProcessBasicInformation, pbi64, Len(pbi64), 0) = STATUS_SUCCESS Then
                If NtWow64ReadVirtualMemory64(hProc, pbi64.PebBaseAddress + 0.0032@, pParam64, Len(pParam64), 0, 0) = STATUS_SUCCESS Then
                    If NtWow64ReadVirtualMemory64(hProc, pParam64 + 0.0112@, cmd64, Len(cmd64), 0, 0) = STATUS_SUCCESS Then
                        If cmd64.Length > 0 Then
                            lStr = cmd64.Length \ 2
                            strProcName = Space$(MAX_PATH) ' We allocate a buffer of sufficient length
                            
                            NtWow64ReadVirtualMemory64 hProc, cmd64.lpBuffer, ByVal StrPtr(strProcName), cmd64.Length, 0, 0
                            
                            If Len(strProcName) > 0 Then
                                If Mid$(strProcName, 1, 1) = Chr(34) And Len(strProcName) > 1 Then
                                    i = InStr(2, strProcName, Chr(34))
                                    strProcName = Mid$(strProcName, 2, i - 2)
                                End If
                                strProcName = Replace(strProcName, vbNullChar, " ")
                                strProcName = Replace(strProcName, "\??\", vbNullString)
                                
                                i = 0
                                i = InStr(1, strProcName, ".exe ", vbTextCompare)
                                If i > 0 Then
                                    strProcName = Mid$(strProcName, 1, i + 3)
                                End If
                                
                                strProcName = Replace(strProcName, "%SystemRoot%", Environ("windir"), , , vbTextCompare)
                                strProcName = Replace(strProcName, "\SystemRoot", Environ("windir"), , , vbTextCompare)
                                strProcName = Trim$(strProcName)
                            End If
                            
                            GetProcessPathName = strProcName
                        End If
                    End If
                End If
            End If
        End If
        
        CloseHandle hProc
    End If
End Function
 
' Universal function
Public Function GetProcessFullPath(ByVal pid As Long) As String
    Dim ProcName As String
    
    ProcName = GetProcessPathName(pid) ' Technology from HackerVlad
    
    If InStr(1, ProcName, "\") = 0 Then ' Retrying
        ProcName = GetProcessFullPathEx(pid) ' Technology from fafalone
    End If
    
    GetProcessFullPath = ProcName
End Function
 
Private Sub Command1_Click()
    Dim ret As Long
    Dim buf() As Byte
    Dim Offset As Long
    Dim deltaOffset As Long
    Dim pid As Long
    Dim ImgName As UNICODE_STRING
    Dim ProcName As String
    Dim nProc As Long
    
    Text1.Text = vbNullString
    
    If NtQuerySystemInformation(SystemProcessInformation, ByVal 0&, 0&, ret) = STATUS_INFO_LENGTH_MISMATCH Then
        ReDim buf(ret - 1)
        
        If NtQuerySystemInformation(SystemProcessInformation, buf(0), ret, ret) = STATUS_SUCCESS Then
            Do
                nProc = nProc + 1
                
                GetMem4 buf(Offset + &H44), pid
                GetMem8 buf(Offset + &H38), ImgName
                ProcName = Space$(ImgName.Length \ 2)
                memcpy ByVal StrPtr(ProcName), ByVal ImgName.lpBuffer, ImgName.Length
                
                If pid = 0 Then
                    PostLog "ProcId 0: [System idle process]"
                ElseIf pid = 4 Then
                    PostLog "ProcId 4: [System]"
                Else
                    PostLog "ProcId " & pid & " (" & ProcName & "): " & Chr(34) & GetProcessFullPath(pid) & Chr(34)
                End If
                
                GetMem4 buf(Offset), deltaOffset
                Offset = Offset + deltaOffset
            Loop While deltaOffset
            
            Text1.Text = Text1.Text & "Done. Enumerated " & nProc & " processes."
        End If
    End If
End Sub
 
Private Sub PostLog(sMsg As String)
    Text1.Text = Text1.Text & sMsg & vbCrLf
End Sub
 
Private Sub Form_Resize()
    On Error Resume Next
    Text1.Width = Me.Width - 380
    Text1.Height = Me.Height - 1270
End Sub