SystemProcessesAndThreadsInformation VB6

'---------------------------------------------------------------------------------------
' Module : mProcessInformation
' Author : Karcrack
' Now : 26/08/2010 15:00
' Purpose : Native Process Enumeration
' History : 26/08/2010 First cut .........................................................
'---------------------------------------------------------------------------------------

Option Explicit
Option Base 0

Public Type PROCESS
sName As String
lPID As Long
End Type

'NTDLL
Private Declare Function NtQuerySystemInformation Lib "NTDLL" (ByVal SystemInformationClass As Long, ByRef SystemInformation As Any, ByVal SystemInformationLength As Long, ByRef ReturnLength As Long) As Long
Private Declare Sub RtlMoveMemory Lib "NTDLL" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)

Private Const SystemProcessesAndThreadsInformation As Long = 5&
Private Const STATUS_INFO_LENGTH_MISMATCH As Long = &HC0000004

Public Function RetrieveProcesses() As PROCESS()
Dim bvSPI(17) As Long 'As SYSTEM_PROCESS_INFORMATION
Dim bvTmp() As PROCESS
Dim bvBuffer() As Byte
Dim cbBuffer As Long
Dim lRet As Long
Dim lPos As Long
Dim lSize As Long

ReDim bvTmp(0)
cbBuffer = 1
Do
cbBuffer = cbBuffer * 2
ReDim bvBuffer(cbBuffer)
lRet = NtQuerySystemInformation(SystemProcessesAndThreadsInformation, bvBuffer(0), cbBuffer, lSize)
Loop While lRet = STATUS_INFO_LENGTH_MISMATCH

If lRet < 0 Then Exit Function

lPos = VarPtr(bvBuffer(0))

Do
Call RtlMoveMemory(bvSPI(0), ByVal lPos, 18 * 4)
With bvTmp(UBound(bvTmp))
.lPID = bvSPI(17)
.sName = ReadUStr(bvSPI(15))
End With
lPos = lPos + bvSPI(0)
If bvSPI(0) = 0 Then Exit Do
ReDim Preserve bvTmp(UBound(bvTmp) + 1)
Loop

RetrieveProcesses = bvTmp
Erase bvBuffer
End Function

Private Function ReadUStr(ByVal lPtr As Long) As String
Dim i As Long
Dim uChar As Integer

If Not lPtr > 0 Then Exit Function
i = lPtr
Do
Call RtlMoveMemory(uChar, ByVal i, &H2)
If uChar = 0 Then Exit Do
ReadUStr = ReadUStr & ChrW$(uChar)
i = i + 2
Loop
End Function

Sample call:
Private Sub Form_Load()
Dim x() As PROCESS
Dim i As Long

x = RetrieveProcesses

For i = 0 To UBound(x)
Debug.Print x(i).lPID, "->", x(i).sName
Next i
End Sub