1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
| ' Process List by Alex Dragokas
Option Explicit
Const MAX_PATH As Long = 260&
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 Sub memcpy Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExW" (lpVersionInformation As Any) 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 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 GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryW" (ByVal lpBuffer As Long, ByVal nSize As Long) As Long
Private Declare Function ExpandEnvironmentStrings Lib "kernel32" Alias "ExpandEnvironmentStringsW" (ByVal lpSrc As Long, ByVal lpDst As Long, ByVal nSize As Long) As Long
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Declare Function LookupPrivilegeValue Lib "advapi32" Alias "LookupPrivilegeValueW" (ByVal lpSystemName As Long, ByVal lpName As Long, lpLuid 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 AdjustTokenPrivileges Lib "advapi32" (ByVal TokenHandle As Long, ByVal DisableAllPrivileges As Long, NewState As TOKEN_PRIVILEGES, ByVal BufferLength As Long, ByVal PreviousState As Long, ByVal ReturnLength 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
Private Type TOKEN_PRIVILEGES
PrivilegeCount As Long
LuidLowPart As Long
LuidHighPart As Long
Attributes As Long
End Type
Private Type LARGE_INTEGER
LowPart As Long
HighPart As Long
End Type
Private Type CLIENT_ID
UniqueProcess As Long ' HANDLE
UniqueThread As Long ' HANDLE
End Type
Private Type UNICODE_STRING
Length As Integer
MaxLength As Integer
lpBuffer As Long
End Type
Private Type VM_COUNTERS
PeakVirtualSize As Long
VirtualSize As Long
PageFaultCount As Long
PeakWorkingSetSize As Long
WorkingSetSize As Long
QuotaPeakPagedPoolUsage As Long
QuotaPagedPoolUsage As Long
QuotaPeakNonPagedPoolUsage As Long
QuotaNonPagedPoolUsage As Long
PagefileUsage As Long
PeakPagefileUsage As Long
End Type
Private Type IO_COUNTERS
ReadOperationCount As Currency 'ULONGLONG
WriteOperationCount As Currency
OtherOperationCount As Currency
ReadTransferCount As Currency
WriteTransferCount As Currency
OtherTransferCount As Currency
End Type
Private Type SYSTEM_THREAD
KernelTime As LARGE_INTEGER
UserTime As LARGE_INTEGER
CreateTime As LARGE_INTEGER
WaitTime As Long
StartAddress As Long
ClientId As CLIENT_ID
Priority As Long
BasePriority As Long
ContextSwitchCount As Long
State As Long 'enum KTHREAD_STATE
WaitReason As Long 'enum KWAIT_REASON
dReserved01 As Long
End Type
Private Type SYSTEM_PROCESS_INFORMATION
NextEntryOffset As Long
NumberOfThreads As Long
SpareLi1 As LARGE_INTEGER
SpareLi2 As LARGE_INTEGER
SpareLi3 As LARGE_INTEGER
CreateTime As LARGE_INTEGER
UserTime As LARGE_INTEGER
KernelTime As LARGE_INTEGER
ImageName As UNICODE_STRING
BasePriority As Long
ProcessId As Long
InheritedFromProcessId As Long
HandleCount As Long
SessionId As Long
pPageDirectoryBase As Long '_PTR
VirtualMemoryCounters As VM_COUNTERS
PrivatePageCount As Long
IoCounters As IO_COUNTERS
Threads() As SYSTEM_THREAD
End Type
Const SystemProcessInformation As Long = &H5&
Const STATUS_INFO_LENGTH_MISMATCH As Long = &HC0000004
Const STATUS_SUCCESS As Long = 0&
Const ERROR_PARTIAL_COPY As Long = 299&
Dim sWinDir As String
Dim bIsWinVistaOrLater As Boolean
Private Sub Form_Load()
Const SPI_SIZE As Long = &HB8&
Const THREAD_SIZE As Long = &H40&
Dim i As Long
Dim ret As Long
Dim buf() As Byte
Dim Offset As Long
Dim Process As SYSTEM_PROCESS_INFORMATION
Dim ProcName As String
Dim ProcPath As String
Dim inf(68) As Long
inf(0) = 276: GetVersionEx inf(0): bIsWinVistaOrLater = (inf(1) >= 6)
sWinDir = GetWinDir()
SetCurrentProcessPrivileges "SeDebugPrivilege"
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
With Process
Do
memcpy Process, buf(Offset), SPI_SIZE
ReDim .Threads(0 To .NumberOfThreads - 1)
For i = 0 To .NumberOfThreads - 1
memcpy .Threads(i), buf(Offset + SPI_SIZE + i * THREAD_SIZE), THREAD_SIZE
Next
If .ProcessId = 0 Then
ProcName = "System Idle Process"
Else
ProcName = Space$(.ImageName.Length \ 2)
memcpy ByVal StrPtr(ProcName), ByVal .ImageName.lpBuffer, .ImageName.Length
ProcPath = GetFilePathByPID(.ProcessId)
End If
Debug.Print Right$("00000" & .ProcessId, 6) & " - " & ProcName & " - " & ProcPath
Offset = Offset + .NextEntryOffset
Loop While .NextEntryOffset
End With
End If
End If
End
End Sub
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 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
Function GetWinDir() As String
Dim ret&, sWinDir$
sWinDir = Space$(MAX_PATH)
ret = GetWindowsDirectory(StrPtr(sWinDir), MAX_PATH)
If ret Then
sWinDir = Left$(sWinDir, ret)
Else
ret = ExpandEnvironmentStrings(StrPtr("%SystemRoot%"), StrPtr(sWinDir), MAX_PATH + 1)
If ret Then sWinDir = Left$(sWinDir, ret - 1)
End If
GetWinDir = sWinDir
End Function
Public Function SetCurrentProcessPrivileges(PrivilegeName As String) As Boolean
Const TOKEN_ADJUST_PRIVILEGES As Long = &H20
Const SE_PRIVILEGE_ENABLED As Long = &H2
Dim tp As TOKEN_PRIVILEGES, hToken&
If LookupPrivilegeValue(0&, StrPtr(PrivilegeName), tp.LuidLowPart) Then 'i.e. "SeDebugPrivilege"
If OpenProcessToken(GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES, hToken) Then
tp.PrivilegeCount = 1
tp.Attributes = SE_PRIVILEGE_ENABLED
SetCurrentProcessPrivileges = AdjustTokenPrivileges(hToken, 0&, tp, Len(tp), 0&, 0&)
CloseHandle hToken
End If
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 |
