Option Explicit
Private Type SYSTEM_HANDLE
UniqueProcessId As Integer
CreatorBackTraceIndex As Integer
ObjectTypeIndex As Byte
HandleAttributes As Byte
HandleValue As Integer
#If VBA7 Then
pObject As LongPtr
#Else
pObject As Long
#End If
GrantedAccess As Long
End Type
Private Type SYSTEM_HANDLE_INFORMATION
uCount As Long
aSH() As SYSTEM_HANDLE
End Type
Private Type OBJECT_ATTRIBUTES
#If VBA7 Then
Length As Long
RootDirectory As LongPtr
ObjectName As LongPtr
Attributes As LongPtr
SecurityDescriptor As LongPtr
SecurityQualityOfService As LongPtr
#Else
Length As Long
RootDirectory As Long
ObjectName As Long
Attributes As Long
SecurityDescriptor As Long
SecurityQualityOfService As Long
#End If
End Type
Private Type CLIENT_ID
#If VBA7 Then
UniqueProcess As LongPtr
UniqueThread As LongPtr
#Else
UniqueProcess As Long
UniqueThread As Long
#End If
End Type
Private Type UNICODE_STRING
uLength As Integer
uMaximumLength As Integer
pBuffer(3) As Byte
End Type
Private Type SYSTEM_HANDLE_TABLE_ENTRY_INFO
UniqueProcessId As Integer
CreatorBackTraceIndex As Integer
ObjectTypeIndex As Byte
HandleAttributes As Byte
HandleValue As Integer
#If VBA7 Then
pObject As LongPtr
GrantedAccess As LongPtr
#Else
pObject As Long
GrantedAccess As Long
#End If
End Type
#If VBA7 Then
Private Declare PtrSafe Function AssocQueryStringA Lib "shlwapi.dll" ( _
ByRef lFlags As Long, _
ByVal str As Long, _
ByVal pszAssoc As String, _
ByVal pszExtra As String, _
ByVal pszOut As String, _
ByRef pcchOut As Long) As Long
Private Declare PtrSafe Function NtQuerySystemInformation Lib "NTDLL.DLL" ( _
ByVal SystemInformationClass As LongPtr, _
ByVal pSystemInformation As LongPtr, _
ByVal SystemInformationLength As Long, _
ByRef ReturnLength As Long) As Long
Private Declare PtrSafe Function GetFinalPathNameByHandleA Lib "kernel32" ( _
ByVal HANDLE As LongPtr, _
ByVal lpszFilePath As String, _
ByVal cchFilePath As Long, _
ByVal dwFla As Long) As Long
Private Declare PtrSafe Function NtOpenProcess Lib "NTDLL.DLL" ( _
ByRef ProcessHandle As LongPtr, _
ByVal AccessMask As Long, _
ByRef ObjectAttributes As OBJECT_ATTRIBUTES, _
ByRef ClientId As CLIENT_ID) As Long
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
Destination As Any, _
Source As Any, _
ByVal Length As LongPtr)
Private Declare PtrSafe Function NtDuplicateObject Lib "NTDLL.DLL" ( _
ByVal SourceProcessHandle As LongPtr, _
ByVal SourceHandle As LongPtr, _
ByVal TargetProcessHandle As LongPtr, _
ByRef TargetHandle As LongPtr, _
ByVal DesiredAccess As Long, _
ByVal HandleAttributes As Long, _
ByVal Options As Long) As Long
Private Declare PtrSafe Function NtClose Lib "NTDLL.DLL" ( _
ByVal ObjectHandle As LongPtr) As Long
Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" ( _
ByVal lpModuleName As String) As LongPtr
Private Declare PtrSafe Function GetProcAddress Lib "kernel32" ( _
ByVal hModule As LongPtr, _
ByVal lpProcName As String) As LongPtr
Private Declare PtrSafe Function FreeLibrary Lib "kernel32" ( _
ByVal hLibModule As LongPtr) As Long
Private Declare PtrSafe Function GetCurrentProcess Lib "kernel32" ( _
) As LongPtr
Private Declare PtrSafe Function CreateRemoteThread Lib "kernel32" ( _
ByVal hProcess As LongPtr, _
lpThreadAttributes As Any, _
ByVal dwStackSize As LongPtr, _
lpStartAddress As LongPtr, _
lpParameter As Any, _
ByVal dwCreationFlags As Long, _
lpThreadId As Long) As LongPtr
Private Declare PtrSafe Function WaitForSingleObject Lib "kernel32" ( _
ByVal hHandle As LongPtr, _
ByVal dwMilliseconds As Long) As Long
Private Declare PtrSafe Function GetExitCodeThread Lib "kernel32" ( _
ByVal hThread As LongPtr, _
lpExitCode As Long) As Long
Private Declare PtrSafe Function TerminateThread Lib "kernel32" ( _
ByVal hThread As LongPtr, _
ByVal dwExitCode As Long) As Long
#Else
Private Declare Function AssocQueryStringA Lib "shlwapi.dll" ( _
ByRef lFlags As Long, _
ByVal str As Long, _
ByVal pszAssoc As String, _
ByVal pszExtra As String, _
ByVal pszOut As String, _
ByRef pcchOut As Long) As Long
Private Declare Function NtQuerySystemInformation Lib "NTDLL.DLL" ( _
ByVal SystemInformationClass As Long, _
ByVal pSystemInformation As Long, _
ByVal SystemInformationLength As Long, _
ByRef ReturnLength As Long) As Long
Private Declare Function GetFinalPathNameByHandleA Lib "kernel32" ( _
ByVal HANDLE As Long, _
ByVal lpszFilePath As String, _
ByVal cchFilePath As Long, _
ByVal dwFla As Long) As Long
Private Declare Function NtOpenProcess Lib "NTDLL.DLL" ( _
ByRef ProcessHandle As Long, _
ByVal AccessMask As Long, _
ByRef ObjectAttributes As OBJECT_ATTRIBUTES, _
ByRef ClientId As CLIENT_ID) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
Destination As Any, _
Source As Any, _
ByVal Length As Long)
Private Declare Function NtDuplicateObject Lib "NTDLL.DLL" ( _
ByVal SourceProcessHandle As Long, _
ByVal SourceHandle As Long, _
ByVal TargetProcessHandle As Long, _
ByRef TargetHandle As Long, _
ByVal DesiredAccess As Long, _
ByVal HandleAttributes As Long, _
ByVal Options As Long) As Long
Private Declare Function NtClose Lib "NTDLL.DLL" ( _
ByVal ObjectHandle As Long) As Long
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" ( _
ByVal lpModuleName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32" ( _
ByVal hModule As Long, _
ByVal lpProcName As String) As Long
Private Declare Function FreeLibrary Lib "kernel32" ( _
ByVal hLibModule As Long) As Long
Private Declare Function GetCurrentProcess Lib "kernel32" ( _
) As Long
Private Declare Function CreateRemoteThread Lib "kernel32" ( _
ByVal hProcess As Long, _
lpThreadAttributes As Any, _
ByVal dwStackSize As Long, _
lpStartAddress As Long, _
lpParameter As Any, _
ByVal dwCreationFlags As Long, _
lpThreadId As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" ( _
ByVal hHandle As Long, _
ByVal dwMilliseconds As Long) As Long
Private Declare Function GetExitCodeThread Lib "kernel32" ( _
ByVal hThread As Long, _
lpExitCode As Long) As Long
Private Declare Function TerminateThread Lib "kernel32" ( _
ByVal hThread As Long, _
ByVal dwExitCode As Long) As Long
#End If
Private Const ASSOCF_INIT_DEFAULTTOFOLDER = &H8
Private Const ASSOCF_NOTRUNCATE = &H20
Private Const ASSOCF_VERIFY = &H40
Private Const ASSOCSTR_EXECUTABLE = &H2
Private Const STATUS_INFO_LENGTH_MISMATCH = &HC0000004
Private Const SystemHandleInformation = 16&
Private Const DUPLICATE_SAME_ACCESS = &H2
Private Const PROCESS_DUP_HANDLE = (&H40)
Private Const OBJ_INHERIT = &H2
Private Const S_OK As Long = &H0
Private Const E_POINTER As Long = &H80004003
Private Const MAX_PATH = 260
#If Win64 Then
Private Const LONG_SIZE = 8
#Else
Private Const LONG_SIZE = 4
#End If
Public Function FindFileHandles(ByVal dwProcessId As Long, ByVal ar As Variant) As Collection
#If VBA7 Then
Dim hProcessToDup As LongPtr, hFileHandle As LongPtr
#Else
Dim hProcessToDup As Long, hFileHandle As Long
#End If
Dim oCID As CLIENT_ID
Dim oOA As OBJECT_ATTRIBUTES
Dim oInfo As SYSTEM_HANDLE_INFORMATION
Dim lHandles As Long, lSize As Long, lStatus As Long, I As Long
Dim sBuffer As String * MAX_PATH, lRet As Long
Dim bBuffer() As Byte
Dim sTempArray() As String, sTempString As String
Dim oTempCollection As New Collection
oOA.Length = Len(oOA)
oOA.Attributes = oOA.Attributes Or OBJ_INHERIT
oCID.UniqueProcess = dwProcessId
lStatus = 0
lSize = 1
Do
ReDim bBuffer(lSize)
lStatus = NtQuerySystemInformation(SystemHandleInformation, VarPtr(bBuffer(0)), lSize, 0&)
If (Not NT_SUCCESS(lStatus)) Then
If (lStatus <> STATUS_INFO_LENGTH_MISMATCH) Then
Erase bBuffer
Exit Function
End If
Else
Exit Do
End If
lSize = lSize * 2
ReDim bBuffer(lSize)
Loop
lHandles = 0
CopyMemory oInfo.uCount, bBuffer(0), LONG_SIZE
lHandles = oInfo.uCount
ReDim oInfo.aSH(lHandles - 1)
Call CopyMemory(oInfo.aSH(0), bBuffer(LONG_SIZE), Len(oInfo.aSH(0)) * lHandles)
For I = 0 To lHandles - 1
lStatus = NtOpenProcess(hProcessToDup, PROCESS_DUP_HANDLE, oOA, oCID)
If hProcessToDup <> 0 Then
lStatus = NtDuplicateObject(hProcessToDup, oInfo.aSH(I).HandleValue, _
GetCurrentProcess, hFileHandle, 0, 0, DUPLICATE_SAME_ACCESS)
If (NT_SUCCESS(lStatus)) Then
lStatus = MyGetFileType(hFileHandle)
If lStatus Then
lRet = GetFinalPathNameByHandleA(hFileHandle, sBuffer, MAX_PATH, 0&)
If lRet Then
sTempString = Left(sBuffer, lRet)
sTempArray = Split(sTempString, ".")
sTempString = sTempArray(UBound(sTempArray))
If Application.IfError(Application.Match(sTempString, ar, 0), 0) Then
On Error Resume Next
oTempCollection.Add Mid(Left(sBuffer, lRet), 5) & _
"|" & ExeFromFileExtension(Mid(Left(sBuffer, lRet), 5), ASSOCSTR_EXECUTABLE) _
& "|" & dwProcessId, Left(sBuffer, lRet)
End If
End If
End If
End If
End If
Call NtClose(hProcessToDup)
NtClose hFileHandle
DoEvents
Next I
Set FindFileHandles = oTempCollection
End Function
Public Function ExeFromFileExtension(ByVal Extension As String, ByVal NameType As Long) As String
Dim sExtra As String
Dim sOutFile As String
Dim lFlags As Long
Dim lLenOutFile As Long
Dim lRes As Long
sOutFile = Space$(MAX_PATH)
sExtra = vbNullString '"OPEN"
lLenOutFile = Len(sOutFile)
lRes = AssocQueryStringA(lFlags:=ASSOCF_INIT_DEFAULTTOFOLDER + _
ASSOCF_NOTRUNCATE + ASSOCF_VERIFY, _
str:=NameType, _
pszAssoc:=Extension, _
pszExtra:=sExtra, _
pszOut:=sOutFile, _
pcchOut:=lLenOutFile)
Select Case lRes
Case S_OK
ExeFromFileExtension = Left(sOutFile, lLenOutFile - 1)
Case E_POINTER
Debug.Print "E_POINTER: sOutFile buffer too small. Bytes Required: " & CStr(lLenOutFile)
Case Else
Debug.Print "Other Error: " & CStr(lRes) & " Hex: " & Hex(lRes) & " Ext: " & Extension
End Select
End Function
#If VBA7 Then
Private Function MyGetFileType(ByVal hFile As LongPtr) As Long
Dim hRemProcess As LongPtr
Dim hThread As LongPtr
Dim pfnThreadRtn As LongPtr
Dim hKernel As LongPtr
#Else
Private Function MyGetFileType(ByVal hFile As Long) As Long
Dim hRemProcess As Long
Dim hThread As Long
Dim pfnThreadRtn As Long
Dim hKernel As Long
#End If
Dim dwEax As Long
Dim dwTimeOut As Long
Dim lResult As Long
hRemProcess = GetCurrentProcess
hKernel = GetModuleHandle("kernel32")
If hKernel = 0 Then
MyGetFileType = 0
Exit Function
End If
pfnThreadRtn = GetProcAddress(hKernel, "GetFileType")
If pfnThreadRtn = 0 Then
FreeLibrary hKernel
MyGetFileType = 0
Exit Function
End If
hThread = CreateRemoteThread(hRemProcess, ByVal 0&, 0&, ByVal pfnThreadRtn, ByVal hFile, 0, ByVal 0&)
dwEax = WaitForSingleObject(hThread, 50)
If dwEax = &H102 Then
Call GetExitCodeThread(hThread, dwTimeOut)
Call TerminateThread(hThread, dwTimeOut)
NtClose hThread
MyGetFileType = 0
Exit Function
End If
If hThread = 0 Then
FreeLibrary hKernel
MyGetFileType = False
Exit Function
End If
GetExitCodeThread hThread, lResult
MyGetFileType = lResult
NtClose hThread
NtClose hRemProcess
FreeLibrary hKernel
End Function
Private Function NT_SUCCESS(ByVal nStatus As Long) As Boolean
NT_SUCCESS = (nStatus >= 0)
End Function
