Функция 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

Option Explicit
'/////////////////////////////////////////////////////////////////////////////////
'// Module for correctly get the full path processes in all versions of Windows //
'// Copyright (c) 18.12.2024 by HackerVlad                                      //
'// E-mail: vladislavpeshkov@ya.ru                                              //
'// Version 3.0                                                                 //
'/////////////////////////////////////////////////////////////////////////////////
 
' API declarations ...
Private Declare Function NtQuerySystemInformation Lib "ntdll" (ByVal infoClass As Long, Buffer As Any, ByVal BufferSize As Long, ret As Long) As Long
Private Declare Function GetMem4 Lib "msvbvm60" (ByVal src As Long, dst As Any) As Long
Private Declare Sub PutMem4 Lib "msvbvm60" (ByVal Ptr As Long, ByVal Value 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 "QueryDosDeviceW" (ByVal lpDeviceName As Long, ByVal lpTargetPath As Long, ByVal ucchMax As Long) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenW" (ByVal lpString As Long) 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 CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryW" (ByVal lpBuffer As Long, ByVal uSize As Long) As Long
Private Declare Function GetModuleFileNameExW Lib "psapi" (ByVal hProcess As Long, ByVal hModule As Long, ByVal ModuleName As Long, ByVal nSize As Long) As Long
Private Declare Function SysAllocStringLen Lib "oleaut32" (ByVal olestr As Long, ByVal Length As Long) As Long
Private Declare Function CommandLineToArgv Lib "shell32" Alias "CommandLineToArgvW" (ByVal lpCmdLine As Long, pNumArgs As Integer) As Long
Private Declare Function LocalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Sub SysFreeString Lib "oleaut32" (ByVal bstr As Long)
 
' Undocumented APIs ...
Private Declare Function NtWow64QueryInformationProcess64 Lib "ntdll" (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" (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
 
' Constants ...
Private Const SystemProcessIdInformation = 88
Private Const ProcessBasicInformation = 0
Private Const STATUS_SUCCESS As Long = 0
Private Const MAX_PATH = 260
Private Const PROCESS_QUERY_INFORMATION = 1024
Private Const PROCESS_VM_READ = 16
 
' Types ...
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
 
' Variables for caching ...
Dim MajorWinVer As Long
Dim ArrDosDevice() As String
Dim IsInitArrDosDevice As Boolean
 
' Its my function that caches data and replaces the QueryDosDevice call API
Private Function MyQueryDosDeviceCache(ByVal lpDeviceName As String) As String
    Dim countChars As Long, i As Long, cnt As Long
    Dim DosDeviceName As String
    
    If IsInitArrDosDevice = True Then
        For i = 0 To UBound(ArrDosDevice, 2)
            If ArrDosDevice(0, i) = lpDeviceName Then
                MyQueryDosDeviceCache = ArrDosDevice(1, i)
                Exit Function
            End If
        Next
        
        cnt = UBound(ArrDosDevice, 2) + 1 ' Since the position we need has not been found, we need to add a new position
    End If
    
    DosDeviceName = Space$(2048)
    countChars = QueryDosDevice(StrPtr(lpDeviceName), StrPtr(DosDeviceName), 2048)
    
    If countChars > 0 Then
        DosDeviceName = Left$(DosDeviceName, countChars)
        DosDeviceName = Replace$(DosDeviceName, vbNullChar, "")
    End If
    
    ReDim Preserve ArrDosDevice(1, cnt) As String
    ArrDosDevice(0, cnt) = lpDeviceName
    ArrDosDevice(1, cnt) = DosDeviceName
    
    IsInitArrDosDevice = True
    MyQueryDosDeviceCache = DosDeviceName
End Function
 
' Get the full path to the process using the NtQuerySystemInformation function
' Before Windows 10, sometimes it may incorrect to get the path to the process
Public Function GetProcessFullPathNt(ByVal pid As Long, Optional SaveSystemPath As Boolean, Optional Caching As Boolean = True) As String
    Dim ProcName As String, sDrives As String, strBuff As String, DosDeviceName As String
    Dim cbRet As Long, cbMax As Long, cnt As Long, i As Long
    Dim spii As SYSTEM_PROCESS_ID_INFORMATION
    Dim aDrive() As String
    
    cbMax = MAX_PATH * 2
    PutMem4 VarPtr(ProcName), SysAllocStringLen(0&, cbMax)
    
    spii.ProcessId = pid ' Fafalone wrote this line of code
    spii.ImageName.MaxLength = cbMax ' Fafalone wrote this line of code
    spii.ImageName.lpBuffer = StrPtr(ProcName) ' HackerVlad wrote this line of code
    
    If NtQuerySystemInformation(SystemProcessIdInformation, spii, LenB(spii), cbRet) >= 0 Then ' Technology from fafalone
        ProcName = Left$(ProcName, spii.ImageName.Length / 2)
        GetProcessFullPathNt = ProcName
        
        If SaveSystemPath = False Then
            PutMem4 VarPtr(sDrives), SysAllocStringLen(0&, 2048)
            cnt = GetLogicalDriveStrings(2048, StrPtr(sDrives)) ' HackerVlad's technology of getting all the letters of the drives
            
            If Err.LastDllError = 0 Then
                aDrive = Split(Left$(sDrives, cnt - 1), vbNullChar)
                
                For i = 0 To UBound(aDrive)
                    If Caching = True Then
                        DosDeviceName = MyQueryDosDeviceCache(Left$(aDrive(i), 2)) & "\" ' HackerVlad's caching technology
                    Else
                        PutMem4 VarPtr(strBuff), SysAllocStringLen(0&, 2048)
                        
                        If QueryDosDevice(StrPtr(Left$(aDrive(i), 2)), StrPtr(strBuff), 2048) Then
                            DosDeviceName = Left$(strBuff, lstrlen(StrPtr(strBuff))) & "\"
                        End If
                        
                        SysFreeString StrPtr(strBuff)
                    End If
                    
                    If Left$(ProcName, Len(DosDeviceName)) = DosDeviceName Then
                        GetProcessFullPathNt = Left$(aDrive(i), 2) & Mid$(ProcName, Len(DosDeviceName))
                        Exit Function
                    Else
                        If InStr(1, ProcName, DosDeviceName, vbTextCompare) > 0 Then ' Retrying
                            GetProcessFullPathNt = Replace$(ProcName, DosDeviceName, Left$(aDrive(i), 2) & "\", 1, 1, vbTextCompare)
                            Exit Function
                        End If
                    End If
                Next
            End If
        End If
    End If
End Function
 
' This function should get the correct paths, unlike another functions which can sometimes cheat
Public Function GetProcessFullPathCorrect(ByVal pid As Long) As String
    Dim hProc As Long, lpwstr As Long, CmdStringPtr As Long
    Dim strProcName As String, strProcName2 As String
    Dim pbi64 As PROCESS_BASIC_INFORMATION_WOW64
    Dim cmd64 As UNICODE_STRING64
    Dim pParam64 As Currency
    Dim cnt As Integer
    
    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)))
            GoSub strProcNameArrange
            
            GetProcessFullPathCorrect = 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
                            strProcName = Space$(cmd64.Length / 2) ' We allocate a buffer of sufficient length
                            NtWow64ReadVirtualMemory64 hProc, cmd64.lpBuffer, ByVal StrPtr(strProcName), cmd64.Length, 0, 0
                            
                            If Len(strProcName) > 0 Then
                                strProcName2 = strProcName
                                strProcName = vbNullString
                                
                                lpwstr = CommandLineToArgv(StrPtr(strProcName2), cnt)
                                
                                If lpwstr Then
                                    GetMem4 lpwstr, CmdStringPtr
                                    PutMem4 VarPtr(strProcName), SysAllocStringLen(CmdStringPtr, lstrlen(CmdStringPtr))
                                    
                                    ' This situation will only be possible if privileges "SeDebugPrivilege" are enabled
                                    GoSub strProcNameArrange
                                    LocalFree lpwstr
                                End If
                            End If
                            
                            GetProcessFullPathCorrect = strProcName
                        End If
                    End If
                End If
            End If
        End If
        
        CloseHandle hProc
    End If
    Exit Function
    
strProcNameArrange:
    Dim PathWinDir As String
    Dim lengthPathWinDir As Long
    
    If Left$(strProcName, 12) = "\SystemRoot\" And strProcName <> "\SystemRoot\" Then
        PutMem4 VarPtr(PathWinDir), SysAllocStringLen(0&, MAX_PATH)
        lengthPathWinDir = GetWindowsDirectory(StrPtr(PathWinDir), MAX_PATH)
        PathWinDir = Left$(PathWinDir, lengthPathWinDir)
        
        strProcName = PathWinDir & Mid$(strProcName, 12)
    End If
    
    If Left$(strProcName, 13) = "%SystemRoot%\" And strProcName <> "%SystemRoot%\" Then
        If Len(PathWinDir) = 0 Then
            PutMem4 VarPtr(PathWinDir), SysAllocStringLen(0&, MAX_PATH)
            lengthPathWinDir = GetWindowsDirectory(StrPtr(PathWinDir), MAX_PATH)
            PathWinDir = Left$(PathWinDir, lengthPathWinDir)
        End If
        
        strProcName = PathWinDir & Mid$(strProcName, 13)
    End If
    
    If Left$(strProcName, 4) = "\??\" And strProcName <> "\??\" Then
        strProcName = Mid$(strProcName, 5)
    End If
    
    Return
End Function
 
' Universal function
Public Function GetProcessFullPathUniversal(ByVal pid As Long, Optional Caching As Boolean = True) As String
    Dim MajorWindowsVersion As Long
    Dim ProcName As String
    
    If MajorWinVer = 0 Then
        GetMem4 &H7FFE026C, MajorWindowsVersion ' Get the Windows version
        MajorWinVer = MajorWindowsVersion ' Save
    End If
    
    If MajorWinVer < 10 Then ' Old versions Windows
        ProcName = GetProcessFullPathCorrect(pid) ' Technology from HackerVlad
    Else ' Windows 10 and latter
        GetProcessFullPathUniversal = GetProcessFullPathNt(pid, , Caching) ' Technology from fafalone
        Exit Function
    End If
    
    If InStr(1, ProcName, "\") = 0 Then ' Retrying
        ProcName = GetProcessFullPathNt(pid, , Caching) ' Technology from fafalone
    End If
    
    GetProcessFullPathUniversal = ProcName
End Function

Option Explicit
'/////////////////////////////////////////////////////////////////////////////////
'// Module for correctly get the full path processes in all versions of Windows //
'// Copyright (c) 19.12.2024 by HackerVlad                                      //
'// E-mail: vladislavpeshkov@ya.ru                                              //
'// Version 3.5                                                                 //
'/////////////////////////////////////////////////////////////////////////////////
 
' API declarations ...
Private Declare Function NtQuerySystemInformation Lib "ntdll" (ByVal infoClass As Long, Buffer As Any, ByVal BufferSize As Long, ret As Long) As Long
Private Declare Function GetMem4 Lib "msvbvm60" (ByVal src As Long, dst As Any) As Long
Private Declare Sub PutMem4 Lib "msvbvm60" (ByVal Ptr As Long, ByVal Value 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 "QueryDosDeviceW" (ByVal lpDeviceName As Long, ByVal lpTargetPath As Long, ByVal ucchMax As Long) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenW" (ByVal lpString As Long) 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 CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryW" (ByVal lpBuffer As Long, ByVal uSize As Long) As Long
Private Declare Function GetModuleFileNameExW Lib "psapi" (ByVal hProcess As Long, ByVal hModule As Long, ByVal ModuleName As Long, ByVal nSize As Long) As Long
Private Declare Function SysAllocStringLen Lib "oleaut32" (ByVal olestr As Long, ByVal Length As Long) As Long
Private Declare Function CommandLineToArgv Lib "shell32" Alias "CommandLineToArgvW" (ByVal lpCmdLine As Long, pNumArgs As Integer) As Long
Private Declare Function LocalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Sub SysFreeString Lib "oleaut32" (ByVal bstr As Long)
Private Declare Sub GetNativeSystemInfo Lib "kernel32" (lpSystemInfo As SYSTEM_INFO)
Private Declare Function IsWow64Process Lib "kernel32" (ByVal hProc As Long, bWow64Process As Long) As Long
 
' Undocumented APIs ...
Private Declare Function NtWow64QueryInformationProcess64 Lib "ntdll" (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" (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
 
' Constants ...
Private Const SystemProcessIdInformation = 88
Private Const ProcessBasicInformation = 0
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 Const PROCESSOR_ARCHITECTURE_AMD64 As Integer = 9
Private Const PROCESSOR_ARCHITECTURE_IA64 As Integer = 6
 
' Types ...
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 Type SYSTEM_INFO
    wProcessorArchitecture As Integer
    wReserved As Integer
    dwPageSize As Long
    lpMinimumApplicationAddress As Long
    lpMaximumApplicationAddress As Long
    dwActiveProcessorMask As Long
    dwNumberOrfProcessors As Long
    dwProcessorType As Long
    dwAllocationGranularity As Long
    wProcessorLevel As Integer
    wProcessorRevision As Integer
End Type
 
' Variables for caching ...
Dim MajorWinVer As Long
Dim ArrDosDevice() As String
Dim IsInitArrDosDevice As Boolean, IsInitMyOSIs64bit As Boolean, MyOSIs64bit As Boolean
 
' Its my function that caches data and replaces the QueryDosDevice call API
Private Function MyQueryDosDeviceCache(ByVal lpDeviceName As String) As String
    Dim countChars As Long, i As Long, cnt As Long
    Dim DosDeviceName As String
    
    If IsInitArrDosDevice = True Then
        For i = 0 To UBound(ArrDosDevice, 2)
            If ArrDosDevice(0, i) = lpDeviceName Then
                MyQueryDosDeviceCache = ArrDosDevice(1, i)
                Exit Function
            End If
        Next
        
        cnt = UBound(ArrDosDevice, 2) + 1 ' Since the position we need has not been found, we need to add a new position
    End If
    
    DosDeviceName = Space$(2048)
    countChars = QueryDosDevice(StrPtr(lpDeviceName), StrPtr(DosDeviceName), 2048)
    
    If countChars > 0 Then
        DosDeviceName = Left$(DosDeviceName, countChars)
        DosDeviceName = Replace$(DosDeviceName, vbNullChar, "")
    End If
    
    ReDim Preserve ArrDosDevice(1, cnt) As String
    ArrDosDevice(0, cnt) = lpDeviceName
    ArrDosDevice(1, cnt) = DosDeviceName
    
    IsInitArrDosDevice = True
    MyQueryDosDeviceCache = DosDeviceName
End Function
 
' Get the full path to the process using the NtQuerySystemInformation function
' Before Windows 10, sometimes it may incorrect to get the path to the process
Public Function GetProcessFullPathNt(ByVal pid As Long, Optional SaveSystemPath As Boolean, Optional Caching As Boolean = True) As String
    Dim ProcName As String, sDrives As String, strBuff As String, DosDeviceName As String
    Dim cbRet As Long, cbMax As Long, cnt As Long, i As Long
    Dim spii As SYSTEM_PROCESS_ID_INFORMATION
    Dim aDrive() As String
    
    If pid = 0 Then
        GetProcessFullPathNt = "[System idle process]"
    ElseIf pid = 4 Then
        GetProcessFullPathNt = "[System]"
    End If
    If pid = 0 Or pid = 4 Then Exit Function
    
    cbMax = MAX_PATH * 2
    PutMem4 VarPtr(ProcName), SysAllocStringLen(0&, cbMax)
    
    spii.ProcessId = pid ' Fafalone wrote this line of code
    spii.ImageName.MaxLength = cbMax ' Fafalone wrote this line of code
    spii.ImageName.lpBuffer = StrPtr(ProcName) ' HackerVlad wrote this line of code
    
    If NtQuerySystemInformation(SystemProcessIdInformation, spii, LenB(spii), cbRet) >= 0 Then ' Technology from fafalone
        ProcName = Left$(ProcName, spii.ImageName.Length / 2)
        GetProcessFullPathNt = ProcName
        
        If SaveSystemPath = False Then
            PutMem4 VarPtr(sDrives), SysAllocStringLen(0&, 2048)
            cnt = GetLogicalDriveStrings(2048, StrPtr(sDrives)) ' HackerVlad's technology of getting all the letters of the drives
            
            If Err.LastDllError = 0 Then
                aDrive = Split(Left$(sDrives, cnt - 1), vbNullChar)
                
                For i = 0 To UBound(aDrive)
                    If Caching = True Then
                        DosDeviceName = MyQueryDosDeviceCache(Left$(aDrive(i), 2)) & "\" ' HackerVlad's caching technology
                    Else
                        PutMem4 VarPtr(strBuff), SysAllocStringLen(0&, 2048)
                        
                        If QueryDosDevice(StrPtr(Left$(aDrive(i), 2)), StrPtr(strBuff), 2048) Then
                            DosDeviceName = Left$(strBuff, lstrlen(StrPtr(strBuff))) & "\"
                        End If
                        
                        SysFreeString StrPtr(strBuff)
                    End If
                    
                    If Left$(ProcName, Len(DosDeviceName)) = DosDeviceName Then
                        GetProcessFullPathNt = Left$(aDrive(i), 2) & Mid$(ProcName, Len(DosDeviceName))
                        Exit Function
                    Else
                        If InStr(1, ProcName, DosDeviceName, vbTextCompare) > 0 Then ' Retrying
                            GetProcessFullPathNt = Replace$(ProcName, DosDeviceName, Left$(aDrive(i), 2) & "\", 1, 1, vbTextCompare)
                            Exit Function
                        End If
                    End If
                Next
            End If
        End If
    End If
End Function
 
' This function should get the correct paths, unlike another functions which can sometimes cheat
Public Function GetProcessFullPathCorrect(ByVal pid As Long) As String
    Dim hProc As Long, lpwstr As Long, CmdStringPtr As Long, lengthPathWinDir As Long, IsProcRunWOW64 As Long
    Dim strProcName As String, strProcName2 As String, PathWinDir As String
    Dim pbi64 As PROCESS_BASIC_INFORMATION_WOW64
    Dim cmd64 As UNICODE_STRING64
    Dim pParam64 As Currency
    Dim cnt As Integer
    
    If pid = 0 Then
        GetProcessFullPathCorrect = "[System idle process]"
    ElseIf pid = 4 Then
        GetProcessFullPathCorrect = "[System]"
    End If
    If pid = 0 Or pid = 4 Then Exit Function
    
    hProc = OpenProcess(PROCESS_QUERY_INFORMATION Or PROCESS_VM_READ, 0, pid)
    
    If hProc > 0 Then
        ' First of all, you need to find out if the OS is 32-bit or 64-bit?
        If IsInitMyOSIs64bit = False Then
            Dim si As SYSTEM_INFO
            
            GetNativeSystemInfo si
            MyOSIs64bit = (si.wProcessorArchitecture = PROCESSOR_ARCHITECTURE_AMD64 Or si.wProcessorArchitecture = PROCESSOR_ARCHITECTURE_IA64)
            
            IsInitMyOSIs64bit = True
        End If
        If MyOSIs64bit = True Then IsWow64Process hProc, IsProcRunWOW64
        
        If IsProcRunWOW64 = 1 Or MyOSIs64bit = False Then ' 32-bit process
            strProcName = Space$(MAX_PATH)
            If GetModuleFileNameExW(hProc, 0, StrPtr(strProcName), MAX_PATH) Then
                strProcName = Left$(strProcName, lstrlen(StrPtr(strProcName)))
            End If
        Else ' 64-bit process
            #If Win32 Then
                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
                                strProcName = Space$(cmd64.Length / 2) ' We allocate a buffer of sufficient length
                                NtWow64ReadVirtualMemory64 hProc, cmd64.lpBuffer, ByVal StrPtr(strProcName), cmd64.Length, 0, 0
                                
                                If Len(strProcName) > 0 Then
                                    strProcName2 = strProcName
                                    strProcName = vbNullString
                                    lpwstr = CommandLineToArgv(StrPtr(strProcName2), cnt)
                                    
                                    If lpwstr Then
                                        GetMem4 lpwstr, CmdStringPtr
                                        PutMem4 VarPtr(strProcName), SysAllocStringLen(CmdStringPtr, lstrlen(CmdStringPtr))
                                        LocalFree lpwstr
                                    End If
                                End If
                            End If
                        End If
                    End If
                End If
            #End If
        End If
        
        CloseHandle hProc
        
        If Left$(strProcName, 12) = "\SystemRoot\" And strProcName <> "\SystemRoot\" Then
            PutMem4 VarPtr(PathWinDir), SysAllocStringLen(0&, MAX_PATH)
            lengthPathWinDir = GetWindowsDirectory(StrPtr(PathWinDir), MAX_PATH)
            PathWinDir = Left$(PathWinDir, lengthPathWinDir)
            
            strProcName = PathWinDir & Mid$(strProcName, 12)
        End If
        If Left$(strProcName, 13) = "%SystemRoot%\" And strProcName <> "%SystemRoot%\" Then
            If Len(PathWinDir) = 0 Then
                PutMem4 VarPtr(PathWinDir), SysAllocStringLen(0&, MAX_PATH)
                lengthPathWinDir = GetWindowsDirectory(StrPtr(PathWinDir), MAX_PATH)
                PathWinDir = Left$(PathWinDir, lengthPathWinDir)
            End If
            
            strProcName = PathWinDir & Mid$(strProcName, 13)
        End If
        If Left$(strProcName, 4) = "\??\" And strProcName <> "\??\" Then
            strProcName = Mid$(strProcName, 5)
        End If
        
        GetProcessFullPathCorrect = strProcName
    End If
End Function
 
' Universal function
Public Function GetProcessFullPathUniversal(ByVal pid As Long, Optional Caching As Boolean = True) As String
    Dim MajorWindowsVersion As Long
    Dim ProcName As String
    
    If pid = 0 Then
        GetProcessFullPathUniversal = "[System idle process]"
    ElseIf pid = 4 Then
        GetProcessFullPathUniversal = "[System]"
    End If
    If pid = 0 Or pid = 4 Then Exit Function
    
    If MajorWinVer = 0 Then
        GetMem4 &H7FFE026C, MajorWindowsVersion ' Get the Windows version
        MajorWinVer = MajorWindowsVersion ' Save
    End If
    
    If MajorWinVer < 10 Then ' Old versions Windows
        ProcName = GetProcessFullPathCorrect(pid) ' Technology from HackerVlad
    Else ' Windows 10 and latter
        GetProcessFullPathUniversal = GetProcessFullPathNt(pid, , Caching) ' Technology from fafalone
        Exit Function
    End If
    
    If InStr(1, ProcName, "\") = 0 Then ' Retrying
        ProcName = GetProcessFullPathNt(pid, , Caching) ' Technology from fafalone
    End If
    
    GetProcessFullPathUniversal = ProcName
End Function

Option Explicit
' *--------------------------------------------------------------------------*
' | App for correctly get the full path processes in all versions of Windows |
' | Version 3.5                                                              |
' | Copyright (c) 19.12.2024 by HackerVlad                                   |
' | E-mail: vladislavpeshkov@ya.ru                                           |
' *--------------------------------------------------------------------------*
Private Declare Function NtQuerySystemInformation Lib "ntdll" (ByVal infoClass As Long, Buffer As Any, ByVal BufferSize As Long, ret As Long) As Long
Private Declare Sub PutMem4 Lib "msvbvm60" (ByVal Ptr As Long, ByVal Value 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 SysAllocStringLen Lib "oleaut32" (ByVal olestr As Long, ByVal Length As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, ByRef lpPoint As POINTAPI) As Long
Private Declare Function GetTickCount Lib "kernel32" () 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 CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function OpenProcessToken Lib "advapi32" (ByVal ProcessHandle As Long, ByVal DesiredAccess As Long, TokenHandle As Long) As Long
Private Declare Function LookupPrivilegeValue Lib "advapi32" Alias "LookupPrivilegeValueA" (ByVal lpSystemName As Any, ByVal lpName As String, lpLuid As LUID) As Long
Private Declare Function AdjustTokenPrivileges Lib "advapi32" (ByVal TokenHandle As Long, ByVal DisableAllPriv As Long, NewState As TOKEN_PRIVILEGES, ByVal BufferLength As Long, PreviousState As TOKEN_PRIVILEGES, ReturnLength As Long) As Long
Private Declare Function InitCommonControlsEx Lib "comctl32" (tlpinitcommoncontrolsex As InitCommons) As Long
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 SystemProcessInformation As Long = &H5&
Private Const STATUS_INFO_LENGTH_MISMATCH As Long = &HC0000004
Private Const STATUS_SUCCESS As Long = 0
Private Const PROCESS_ALL_ACCESS = 2035711
Private Const TOKEN_ADJUST_PRIVILEGES = &H20
Private Const TOKEN_QUERY = &H8
Private Const TokenPrivileges = 3
Private Const ICC_USEREX_CLASSES As Long = &H200
Private Const PROCESS_QUERY_LIMITED_INFORMATION As Long = &H1000
Private Const MAX_PATH = 260
 
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
 
Private Type POINTAPI
    x As Long
    y As Long
End Type
 
Private Type UNICODE_STRING
    Length As Integer
    MaxLength As Integer
    lpBuffer As Long
End Type
 
Private Type LUID
   lowpart As Long
   highpart As Long
End Type
 
Private Type LUID_AND_ATTRIBUTES
   pLuid As LUID
   Attributes As Long
End Type
 
Private Type TOKEN_PRIVILEGES
   PrivilegeCount As Long
   Privileges As LUID_AND_ATTRIBUTES
End Type
 
Private Type InitCommons
    dwSize As Long
    dwICC As Long
End Type
 
Private Enum EnumProcessesFunction
    fGetProcessFullPathUniversal
    fGetProcessFullPathCorrect
    fGetProcessFullPathNt
    fQueryFullProcessImageName
End Enum
 
Dim MajorWinVer As Long
Dim WidthCaption As Long
Dim HeightCaption As Long
Dim pids() As Long
 
Public Function SetPrivilegeProcess(ByVal Enable As Boolean, Optional ProcessId As Long, Optional seName As String = "SeDebugPrivilege") As Boolean
    Dim hProcess As Long, ret As Long, p_lngToken As Long, p_lngBufferLen As Long
    Dim p_typLUID As LUID
    Dim p_typTokenPriv As TOKEN_PRIVILEGES
    Dim p_typPrevTokenPriv As TOKEN_PRIVILEGES
    
    If ProcessId > 0 Then
        hProcess = OpenProcess(PROCESS_ALL_ACCESS, 0, ProcessId)
    Else
        hProcess = -1
    End If
    
    If hProcess Then
        If OpenProcessToken(hProcess, TOKEN_ADJUST_PRIVILEGES Or TOKEN_QUERY, p_lngToken) Then
            ret = LookupPrivilegeValue(0&, seName, p_typLUID)
            
            If ret Then
                p_typTokenPriv.PrivilegeCount = 1
                p_typTokenPriv.Privileges.Attributes = IIf(Enable, &H2, &H0)
                p_typTokenPriv.Privileges.pLuid = p_typLUID
                
                AdjustTokenPrivileges p_lngToken, False, p_typTokenPriv, Len(p_typPrevTokenPriv), p_typPrevTokenPriv, p_lngBufferLen
                If Err.LastDllError = 0 Then SetPrivilegeProcess = True
            End If
            
            CloseHandle p_lngToken
        End If
        
        If ProcessId > 0 Then CloseHandle hProcess
    End If
End Function
 
Private Sub List_Processes(Optional technology_function As EnumProcessesFunction)
    Dim ret As Long, Offset As Long, deltaOffset As Long, pid As Long, nProc As Long, tick As Long, hProc As Long, lStr As Long
    Dim buf() As Byte
    Dim ImgName As UNICODE_STRING
    Dim ProcName As String, strProcName As String
    Dim PostLog() As String
    
    tick = GetTickCount
    
    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
                GetMem4 buf(Offset + &H44), pid
                
                ReDim Preserve PostLog(nProc)
                ReDim Preserve pids(nProc)
                pids(nProc) = pid
                
                GetMem8 buf(Offset + &H38), ImgName
                PutMem4 VarPtr(ProcName), SysAllocStringLen(ImgName.lpBuffer, ImgName.Length / 2)
                
                If pid = 0 Then
                    PostLog(nProc) = "ProcId 0: [System idle process]"
                ElseIf pid = 4 Then
                    PostLog(nProc) = "ProcId 4: [System]"
                Else
                    Select Case technology_function
                        Case 0
                            PostLog(nProc) = "ProcId " & pid & " (" & ProcName & "): " & Chr(34) & GetProcessFullPathUniversal(pid) & Chr(34)
                        Case 1
                            PostLog(nProc) = "ProcId " & pid & " (" & ProcName & "): " & Chr(34) & GetProcessFullPathCorrect(pid) & Chr(34)
                        Case 2
                            PostLog(nProc) = "ProcId " & pid & " (" & ProcName & "): " & Chr(34) & GetProcessFullPathNt(pid, IIf(Check1.Value = 0, 0, -1), IIf(Check2.Value = 0, 0, -1)) & Chr(34)
                        Case 3
                            If MajorWinVer >= 6 Then
                                strProcName = ""
                                hProc = OpenProcess(PROCESS_QUERY_LIMITED_INFORMATION, 0, pid)
                                
                                If hProc > 0 Then
                                    lStr = MAX_PATH * 2
                                    strProcName = Space$(lStr)
                                    
                                    QueryFullProcessImageName hProc, 0, StrPtr(strProcName), lStr
                                    strProcName = Left$(strProcName, lStr)
                                    
                                    CloseHandle hProc
                                End If
                            End If
                            
                            PostLog(nProc) = "ProcId " & pid & " (" & ProcName & "): " & Chr(34) & strProcName & Chr(34)
                    End Select
                End If
                
                GetMem4 buf(Offset), deltaOffset
                Offset = Offset + deltaOffset
                nProc = nProc + 1
            Loop While deltaOffset
            
            ReDim Preserve PostLog(nProc)
            PostLog(nProc) = "Done. Enumerated " & nProc & " processes in " & GetTickCount - tick & " ms."
            Text1.Text = Join(PostLog, vbNewLine)
            Text1.SelStart = Len(Text1.Text)
        End If
    End If
End Sub
 
Private Sub Check1_Click()
    If Check1.Value <> 0 Then
        Check2.Enabled = False
    Else
        Check2.Enabled = True
    End If
End Sub
 
Private Sub Check3_Click()
    SetPrivilegeProcess IIf(Check3.Value = 0, 0, -1)
End Sub
 
Private Sub Form_Initialize() ' Code for Windows XP
    GetMem4 ByVal &H7FFE026C, MajorWinVer ' Get the Windows version
    
    If MajorWinVer < 6 Then
        Dim ICCEx As InitCommons
        
        ICCEx.dwSize = LenB(ICCEx)
        ICCEx.dwICC = ICC_USEREX_CLASSES
        
        InitCommonControlsEx ICCEx
    End If
End Sub
 
Private Sub Form_Load()
    #If TWINBASIC = 0 Then
        Dim rct As RECT
        Dim ScreenXYCoordinates As POINTAPI
        
        GetWindowRect hwnd, rct
        ClientToScreen hwnd, ScreenXYCoordinates ' This trick only works in VB6
        
        WidthCaption = ScreenXYCoordinates.x - rct.Left ' The width of the window frame
        HeightCaption = ScreenXYCoordinates.y - rct.Top ' The height of the window title + menu (if any)
    #End If
    
    If MajorWinVer < 6 Then ' for XP
        Check3.Value = 1
        Check1.Enabled = False
        Check2.Enabled = False
        Check2.Value = 0
    End If
    
    Me.Cls
    Print "Function: GetProcessFullPathUniversal"
    List_Processes
End Sub
 
Private Sub Form_Resize()
    On Error Resume Next
    
    #If TWINBASIC = 0 Then
        Text1.Width = Form1.Width - (WidthCaption * Screen.TwipsPerPixelX) * 2
        Text1.Height = Form1.Height - Text1.Top - ((HeightCaption * Screen.TwipsPerPixelY) + (WidthCaption * Screen.TwipsPerPixelX))
        
        Check1.Left = Form1.Width - Check1.Width - ((WidthCaption * Screen.TwipsPerPixelX) * 2) - 100
        Check2.Left = Form1.Width - Check2.Width - ((WidthCaption * Screen.TwipsPerPixelX) * 2) - 100
        Check3.Left = Form1.Width - Check3.Width - ((WidthCaption * Screen.TwipsPerPixelX) * 2) - 100
    #End If
End Sub
 
Private Sub mnuAbout_Click()
    MsgBox "EnumProc" & vbNewLine & _
    "Copyright (c) 19.12.2024 by HackerVlad" & vbNewLine & _
    "The original idea by fafalone" & vbNewLine & _
    "Version 3.5", vbInformation
End Sub
 
Private Sub mnuEnumGetProcessFullPathCorrect_Click()
    Me.Cls
    Print "Function: GetProcessFullPathCorrect"
    List_Processes fGetProcessFullPathCorrect
End Sub
 
Private Sub mnuEnumGetProcessFullPathNt_Click()
    If MajorWinVer >= 6 Then
        Me.Cls
        Print "Function: GetProcessFullPathNt"
        List_Processes fGetProcessFullPathNt
    Else
        MsgBox "Minimum Windows Vista is supported for this function!", vbExclamation
    End If
End Sub
 
Private Sub mnuEnumGetProcessFullPathUniversal_Click()
    Me.Cls
    Print "Function: GetProcessFullPathUniversal"
    List_Processes
End Sub
 
Private Sub mnuEnumQueryFullProcessImageName_Click()
    If MajorWinVer >= 6 Then
        Me.Cls
        Print "Function: QueryFullProcessImageName"
        List_Processes fQueryFullProcessImageName
    Else
        MsgBox "Minimum Windows Vista is supported for this function!", vbExclamation
    End If
End Sub
 
Private Sub mnuTestGetProcessFullPathCorrect_Click()
    Dim i As Long, i2 As Long, tick As Long, cnt As Long
    Dim ProcName As String
    
    List_Processes fGetProcessFullPathCorrect
    
    Screen.MousePointer = 13
    tick = GetTickCount
    
    For i = 0 To 3000
        For i2 = 0 To UBound(pids)
            ProcName = GetProcessFullPathCorrect(pids(i2))
            cnt = cnt + 1
        Next
    Next
    
    Me.Cls
    Print "Function: GetProcessFullPathCorrect"
    Print cnt & " cycles in " & GetTickCount - tick & " ms."
    Screen.MousePointer = 0
End Sub
 
Private Sub mnuTestGetProcessFullPathNt_Click()
    If MajorWinVer >= 6 Then
        Dim i As Long, i2 As Long, tick As Long, cnt As Long
        Dim SystemPath As Boolean, Caching As Boolean
        Dim ProcName As String
        
        List_Processes fGetProcessFullPathNt
        
        If Check1.Value = 1 Then
            SystemPath = True
        Else
            SystemPath = False
        End If
        If Check2.Value = 1 Then
            Caching = True
        Else
            Caching = False
        End If
        
        Screen.MousePointer = 13
        tick = GetTickCount
        
        For i = 0 To 3000
            For i2 = 0 To UBound(pids)
                ProcName = GetProcessFullPathNt(pids(i2), SystemPath, Caching)
                cnt = cnt + 1
            Next
        Next
        
        Me.Cls
        Print "Function: GetProcessFullPathNt"
        Print cnt & " cycles in " & GetTickCount - tick & " ms."
        Screen.MousePointer = 0
    Else
        MsgBox "Minimum Windows Vista is supported for this function!", vbExclamation
    End If
End Sub
 
Private Sub mnuTestGetProcessFullPathUniversal_Click()
    Dim i As Long, i2 As Long, tick As Long, cnt As Long
    Dim ProcName As String
    
    List_Processes
    
    Screen.MousePointer = 13
    tick = GetTickCount
    
    For i = 0 To 3000
        For i2 = 0 To UBound(pids)
            ProcName = GetProcessFullPathUniversal(pids(i2))
            cnt = cnt + 1
        Next
    Next
    
    Me.Cls
    Print "Function: GetProcessFullPathUniversal"
    Print cnt & " cycles in " & GetTickCount - tick & " ms."
    Screen.MousePointer = 0
End Sub
 
Private Sub mnuTestQueryFullProcessImageName_Click()
    ' QueryFullProcessImageName is the worst and slowest function, it works 5 times slower
    ' than other functions and sometimes incorrectly defines paths
    
    If MajorWinVer >= 6 Then
        Dim i As Long, i2 As Long, tick As Long, cnt, lStr, hProc As Long
        Dim ProcName As String
        
        List_Processes fQueryFullProcessImageName
        
        Screen.MousePointer = 13
        tick = GetTickCount
        
        For i = 0 To 3000
            For i2 = 0 To UBound(pids)
                ProcName = ""
                hProc = OpenProcess(PROCESS_QUERY_LIMITED_INFORMATION, 0, pids(i2))
                
                If hProc > 0 Then
                    lStr = MAX_PATH * 2
                    ProcName = Space$(lStr)
                    
                    QueryFullProcessImageName hProc, 0, StrPtr(ProcName), lStr
                    ProcName = Left$(ProcName, lStr)
                    
                    CloseHandle hProc
                End If
                
                cnt = cnt + 1
            Next
        Next
        
        Me.Cls
        Print "Function: QueryFullProcessImageName"
        Print cnt & " cycles in " & GetTickCount - tick & " ms."
        Screen.MousePointer = 0
    Else
        MsgBox "Minimum Windows Vista is supported for this function!", vbExclamation
    End If
End Sub