本小程序采用枚舉進(jìn)程的方法，顯示所有進(jìn)程，也能顯示隱藏進(jìn)程。同時，能顯示進(jìn)程的完整路徑。
　　有意思的是，一些已經(jīng)結(jié)束的進(jìn)程，同樣可以顯示。
　　以下是程序運行截圖：
　

''''以下是 VB6 代碼，在 WinXP 調(diào)試通過
'需在窗體放置以下 5 個控件，不必設(shè)置任何屬性，全部采用默認(rèn)設(shè)置：
' Command1、List1、Check1、Timer1、Label1
Private Type tyProc
pID As Long: pName As String: pPath As String: pHide As String
End Type
Dim ctP() As tyProc, ctPs As Long
Private Declare Function EnumProcesses Lib "psapi.dll" (ByRef lpidProcess As Long, ByVal cb As Long, ByRef cbNeeded As Long) As Long
Private Declare Function OpenProcess Lib "kernel32.dll" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function EnumProcessModules Lib "psapi.dll" (ByVal hProcess As Long, ByRef lphModule As Long, ByVal cb As Long, ByRef lpcbNeeded As Long) As Long
Private Declare Function GetModuleFileNameEx Lib "psapi.dll" Alias "GetModuleFileNameExA" (ByVal hProcess As Long, ByVal hModule As Long, ByVal lpFilename As String, ByVal nSize As Long) As Long
Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long
Private Declare Function GetProcessImageFileName Lib "psapi.dll" Alias "GetProcessImageFileNameA" (ByVal hProcess As Long, ByVal lpImageFileName As String, ByVal nSize As Long) As Long

Private Const PROCESS_ALL_ACCESS = &H1F0FFF
Private Const PROCESS_QUERY_INFORMATION = &H400
Private Const PROCESS_VM_READ = &H10
Private Const PROCESS_CREATE_PROCESS = &H80
Private Const PROCESS_CREATE_THREAD = &H2
Private Const PROCESS_DUP_HANDLE = &H40
'Private Const PROCESS_QUERY_INFORMATION = &H400
Private Const PROCESS_QUERY_LIMITED_INFORMATION = &H1000
Private Const PROCESS_SET_QUOTA = &H100
Private Const PROCESS_SET_INFORMATION = &H200
Private Const PROCESS_SUSPEND_RESUME = &H800
Private Const PROCESS_TERMINATE = &H1
Private Const PROCESS_VM_OPERATION = &H8
'Private Const PROCESS_VM_READ = &H10
Private Const PROCESS_VM_WRITE = &H20

'以下是在 NT 系統(tǒng)中提升當(dāng)前進(jìn)程權(quán)限的代碼 ================================
'系統(tǒng)級權(quán)限,可以：PROCESS_ALL_ACCESS OpenProcessToken、LookupPrivilegevalue、AdjustTokenPrivileges
Private Declare Function OpenProcessToken Lib "advapi32.dll" (ByVal ProcessHandle As Long, ByVal DesiredAccess As Long, TokenHandle As Long) As Long
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Declare Function LookupPrivilegeValue Lib "advapi32" Alias "LookupPrivilegeValueA" (ByVal lpSystemName As String, ByVal lpName As String, lpLuid As LUID) As Long
Private Declare Function AdjustTokenPrivileges Lib "advapi32" (ByVal TokenHandle As Long, ByVal DisableAllPrivileges As Long, NewState As TOKEN_Privileges, ByVal BufferLength As Long, PreviousState As TOKEN_Privileges, ReturnLength As Long) As Long
Private Type LUID
UsedPart As Long
IgnoredForNowHigh32BitPart As Long
End Type
Private Type TOKEN_Privileges
PrivilegeCount As Long
TheLuid As LUID
Attributes As Long
End Type

Public Sub AdjustPrivilege()
'NT系統(tǒng)：提升權(quán)限
Dim dl As Long, CurP As Long, nToKen As Long, nLuid As LUID
Dim OldTKP As TOKEN_Privileges, NewTKP As TOKEN_Privileges
Dim pName As String

Const TOKEN_Adjust_Privileges = &H20
Const TOKEN_Query = &H8
Const SE_Privilege_Enabled_BY_DEFAULT = &H1 '默認(rèn)權(quán)限
Const SE_Privilege_Enabled = &H2 '開啟權(quán)限
Const SE_Privilege_USED_FOR_ACCESS = &H80000000 '所有訪問權(quán)限

'獲取當(dāng)前進(jìn)程的一個句柄
CurP = GetCurrentProcess()
'打開進(jìn)程令牌：用 nToKen 獲得進(jìn)程訪問令牌的句柄
dl = OpenProcessToken(CurP, (TOKEN_Adjust_Privileges Or TOKEN_Query), nToKen)

'用 nLuid 返回指定權(quán)限的 LUID 結(jié)構(gòu)
'權(quán)限名稱：SeDebugPrivilege、SeShutdownPrivilege、SeRestorePrivilege、SeBackupPrivilege、SeUnsolicitedInputPrivilege
pName = "SeDebugPrivilege"
dl = LookupPrivilegeValue("", pName, nLuid)

NewTKP.PrivilegeCount = 1
NewTKP.TheLuid = nLuid
NewTKP.Attributes = SE_Privilege_Enabled

'調(diào)整令牌權(quán)限
dl = AdjustTokenPrivileges(nToKen, False, NewTKP, Len(NewTKP), OldTKP, 0&)
End Sub
'===================

Private Sub Form_Load()
Me.Font.Name = "宋體": Me.Caption = "枚舉進(jìn)程"
Command1.Caption = "刷新"
List1.Font.Name = Me.Font.Name
Call AdjustPrivilege '提升本進(jìn)程權(quán)限
Timer1.Interval = 10
Check1.Caption = "自動刷新": Check1.Value = 1
End Sub

Private Sub Check1_Click()
Timer1.Enabled = Check1.Value = 1
End Sub

Private Sub Timer1_Timer()
Static S As Long, S1 As Long
Dim nTai As String

S1 = S1 + 1
If S1 > 2 Then
S1 = 0
nTai = "↖↑↗→↘↓↙←"
S = S + 1
If S > 8 Then S = 1
Label1.Caption = Mid(nTai, S, 1) '動畫顯示
End If
Call ShowProc
End Sub

Private Sub Command1_Click()
List1.Clear: List1.Refresh
Call ShowProc
End Sub

Private Sub Form_Resize()
Dim H1 As Single, T As Single
On Error Resume Next
H1 = Me.TextHeight("A")
Command1.Move H1, H1, H1 * 4, H1 * 2
Label1.Move H1 * 6, H1 * 1.5, H1, H1
Check1.Move H1 * 8, H1, H1 * 8, H1 * 2
T = Command1.Top + Command1.Height + H1 * 0.5
List1.Move 0, T, Me.ScaleWidth, Me.ScaleHeight - T
End Sub


Private Sub ShowProc()
Dim pID(1023) As Long, Ps As Long, dwDesiredAccess As Long
Dim cbNeeded As Long, P As Long, hModule As Long
Dim hProcess As Long, nStr As String, I As Long

Dim IsChange As Boolean, P2() As tyProc, Ps2 As Long

On Error Resume Next
dwDesiredAccess = PROCESS_QUERY_INFORMATION Or PROCESS_VM_READ

Ps2 = ctPs: P2 = ctP
ctPs = 1: ReDim ctP(0 To 1)
ctP(1).pName = "[System Process]"
nStr = String(1024, 0)
' 進(jìn)程ID的數(shù)組，數(shù)組的大小，返回實際進(jìn)程數(shù)組的大小
If EnumProcesses(pID(0), 4& * 1024, cbNeeded) <> 0 Then
Ps = cbNeeded \ 4 '進(jìn)程總數(shù)
For P = 0 To &HFFFF& Step 4
hProcess = OpenProcess(dwDesiredAccess, 0, P) '返回指定進(jìn)程的句柄
If hProcess <> 0 Then
ctPs = ctPs + 1: ReDim Preserve ctP(0 To ctPs)
ctP(ctPs).pHide = "隱藏"
For I = 0 To Ps - 1
If P = pID(I) Then ctP(ctPs).pHide = "": Exit For
Next I

'nStr 返回主模塊全名：每個進(jìn)程的第一模塊即為進(jìn)程主模塊
If EnumProcessModules(hProcess, hModule, 4&, 0&) <> 0 Then
GetModuleFileNameEx hProcess, hModule, nStr, 1024
Else '型如：\Device\HarddiskVolume
GetProcessImageFileName hProcess, nStr, 1024
End If
CloseHandle hProcess '關(guān)閉進(jìn)程的句柄

With ctP(ctPs)
.pID = P '進(jìn)程 ID
.pPath = CutStr(nStr, vbNullChar) '進(jìn)程路徑
If Left(.pPath, 4) = "\??\" Then .pPath = Mid(.pPath, 5) '去掉“\??\”
.pName = CutStr(.pPath, "\", True) '進(jìn)程名
If P = 4 And .pName = "" Then .pName = "System"
End With
End If
Next
End If

'List1.Clear
For P = 1 To ctPs
nStr = AddSpace(P, 4) & ProcStr(ctP(P)) '合成顯示條目
If P > List1.ListCount Then
List1.AddItem nStr
' List1.ListIndex = List1.NewIndex
Else
If nStr <> List1.List(P - 1) Then List1.List(P - 1) = nStr
End If
Next

'刪除多余條目
For P = List1.ListCount - 1 To ctPs Step -1
List1.RemoveItem P
Next
End Sub

Private Function ProcStr(P As tyProc) As String
ProcStr = AddSpace(P.pID) & AddSpace(P.pHide, 6) & AddSpace(P.pName, 20) & AddSpace(P.pPath)
End Function

Private Function AddSpace(ByVal nStr As String, Optional ByVal S As Long) As String
If S < 1 Then S = 6
S = S - LenB(StrConv(nStr, vbFromUnicode))
If S < 1 Then S = 1
AddSpace = nStr & String(S, " ")
End Function

Private Function CutStr(nStr As String, Fu As String, Optional GetRight As Boolean) As String
'GetRight=T 從右到左查找
Dim S As Long
If GetRight Then ' 從右到左查找
S = InStrRev(nStr, Fu)
If S > 0 Then CutStr = Mid(nStr, S + 1) Else CutStr = nStr
Else
S = InStr(nStr, Fu)
If S > 0 Then CutStr = Left(nStr, S - 1) Else CutStr = nStr
End If
End Function