VB做的详细的WINDOWS进程管理程序

Option Explicit
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal blnheritHandle As Long, ByVal dwAppProcessId As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function TerminateProcess Lib "kernel32" (ByVal ApphProcess As Long, ByVal uExitCode As Long) As Long
Private Declare Function CreateToolhelp32Snapshot Lib "kernel32" (ByVal lFlags As Long, lProcessID As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Private Declare Function GetWindowThreadProcessId& Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long)
Private Declare Function Process32First Lib "kernel32" (ByVal hsnapshot As Long, uprocess As PROCESSENTRY32) As Long
Private Declare Function Process32Next Lib "kernel32" (ByVal hsnapshot As Long, uprocess As PROCESSENTRY32) As Long
'''''''''设置俺的程序优先极为最高
Const THREAD_BASE_PRIORITY_IDLE = -15
Const THREAD_BASE_PRIORITY_LOWRT = 15
Const THREAD_BASE_PRIORITY_MIN = -2
Const THREAD_BASE_PRIORITY_MAX = 2
Const THREAD_PRIORITY_LOWEST = THREAD_BASE_PRIORITY_MIN
Const THREAD_PRIORITY_HIGHEST = THREAD_BASE_PRIORITY_MAX
Const THREAD_PRIORITY_BELOW_NORMAL = (THREAD_PRIORITY_LOWEST + 1)
Const THREAD_PRIORITY_ABOVE_NORMAL = (THREAD_PRIORITY_HIGHEST - 1)
Const THREAD_PRIORITY_IDLE = THREAD_BASE_PRIORITY_IDLE
Const THREAD_PRIORITY_NORMAL = 0
Const THREAD_PRIORITY_TIME_CRITICAL = THREAD_BASE_PRIORITY_LOWRT
Const HIGH_PRIORITY_CLASS = &H80
Const IDLE_PRIORITY_CLASS = &H40
Const NORMAL_PRIORITY_CLASS = &H20
Const REALTIME_PRIORITY_CLASS = &H100
Private Declare Function SetThreadPriority Lib "kernel32" (ByVal hThread As Long, ByVal nPriority As Long) As Long
Private Declare Function SetPriorityClass Lib "kernel32" (ByVal hProcess As Long, ByVal dwPriorityClass As Long) As Long
Private Declare Function GetThreadPriority Lib "kernel32" (ByVal hThread As Long) As Long
Private Declare Function GetPriorityClass Lib "kernel32" (ByVal hProcess As Long) As Long
Private Declare Function GetCurrentThread Lib "kernel32" () As Long
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
'''''''''这儿让我的窗体在最上

Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Const HWND_TOPMOST = -1
Private Const SWP_SHOWWINDOWS = &H40
''''

Private Type PROCESSENTRY32
    dwSize As Long
    cntUsage As Long
    th32ProcessID As Long
    th32DefaultHeapID As Long
    th32ModuleID As Long
    cntThreads As Long
    th32ParentProcessID As Long
    pcPriClassBase As Long
    dwFlags As Long
    szExeFile As String * 260&
End Type
Private Const TH32CS_SNAPPROCESS As Long = 2&
Dim procresult
Private Sub Form_Activate()
       prochlvwlis
End Sub
Sub prochlvwlis()
    Dim uprocess As PROCESSENTRY32
    Dim hsnapshot As Long
    Dim mname As String
    Dim i As Integer
    Dim proclvw As ListItem
    lvw.ListItems.Clear
    DoEvents
    uprocess.dwSize = Len(uprocess)
    hsnapshot = CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0&)
    
       ' If failure -1 (false)
    If hsnapshot Then
        procresult = Process32First(hsnapshot, uprocess)
            ' If failure -1 (false)
        Do While procresult
             i = InStr(1, uprocess.szExeFile, Chr(0))
             mname = LCase$(Left$(uprocess.szExeFile, i - 1))
             Set proclvw = lvw.ListItems.Add(, , Text:=mname)
             proclvw.SubItems(6) = uprocess.th32ModuleID
             proclvw.SubItems(5) = Hex(uprocess.th32ParentProcessID)
             proclvw.SubItems(4) = Hex(uprocess.th32ProcessID)
             proclvw.SubItems(3) = uprocess.cntUsage
             proclvw.SubItems(2) = uprocess.cntThreads
             proclvw.SubItems(1) = uprocess.pcPriClassBase
             procresult = Process32Next(hsnapshot, uprocess)
        Loop
    End If
End Sub
Sub ErrMsgProc(mMsg As String) ''''错误处理
    MsgBox mMsg & vbCrLf & Err.Number & Space(5) & Err.Description
End Sub

Private Sub Form_Resize() '''改变窗体大小时的设置
lvw.Width = ProcH.Width - 100
lvw.Height = Abs(ProcH.Height - 4000)
TabStrip1.Height = Abs(ProcH.Height - 3350)
TabStrip1.Width = ProcH.Width - 100
morelvw.Width = TabStrip1.Width - 250
morelvw.Height = Abs(TabStrip1.Height - 500)
End Sub

Private Sub lvw_Click()
ProcH.StatusBar1.Panels(2).Text = lvw.SelectedItem
help
End Sub

Private Sub lvw_DblClick()
Call mnuTe_Click
End Sub

Private Sub fParent()
    If lvw.ListItems.Count = 0 Then
        Exit Sub
    End If
    Dim mParentProcID As Long
    Dim i As Integer
    Dim mFound As Boolean
    mFound = False
    mParentProcID = "&H" & (lvw.ListItems(lvw.SelectedItem.Index).SubItems(5))
    For i = 1 To lvw.ListItems.Count
        If "&H" & (lvw.ListItems(i).SubItems(4)) = mParentProcID Then
            lvw.SelectedItem = lvw.ListItems(i)
            lvw.SetFocus
            mFound = True
            Exit For
        End If
    Next
    If mFound = False Then
        MsgBox "没有父进程的东东----------最好不要试图终止它！"
    End If
End Sub

Private Sub Form_Load() '''''载入窗体时发生
ProcH.Width = 8400
ProcH.Height = 5280
        If App.PrevInstance Then
           MsgBox "程序正在运行，请检查窗口是否被最小化。"
        End If
        App.TaskVisible = False ''''将程序从CTRL+DEL+ALT的列表中隐藏
    Dim hThread As Long, hProcess As Long ''设置优先极了
    hThread = GetCurrentThread
    hProcess = GetCurrentProcess
    SetThreadPriority hThread, THREAD_PRIORITY_HIGHEST
    SetPriorityClass hProcess, REALTIME_PRIORITY_CLASS
    ''''
    Dim retValue As Long
    retValue = SetWindowPos(Me.hwnd, HWND_TOPMOST, Me.CurrentX, Me.CurrentY, 300, 300, SWP_SHOWWINDOWS)
    ''''''
    lvw.ListItems.Clear ''''清空列表，初始化
    lvw.ColumnHeaders.Clear ''''清空表头，初始化
    lvw.ColumnHeaders.Add , , "进程名称", 4000 '''添加到表头第一项，有顺序的
    lvw.ColumnHeaders.Add , , "优先极", 600
    lvw.ColumnHeaders.Add , , "线程数", 600 ''''
    lvw.ColumnHeaders.Add , , "引用", 600 ''
    lvw.ColumnHeaders.Add , , "进程ID", 1000 ''''
    lvw.ColumnHeaders.Add , , "父进程 ID", 1000 ''
    lvw.ColumnHeaders.Add , , "", 0
    lvw.LabelEdit = lvwManual
    lvw.FullRowSelect = True
    lvw.HideSelection = False
    lvw.HideColumnHeaders = False
    lvw.View = lvwReport
    
    
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single) '''''窗体上按下鼠标时发生
      If Button >= 2 Then '''''如果鼠标按键是右键~也有特殊的情况如滚轮鼠标
         Me.PopupMenu mnuprochhead1
      End If
End Sub
Private Sub mnuaboutx_Click()
'''''给出一个消息框,这儿只使用了+VBCRLF+=&vbcrlf&,是实现换行的
      MsgBox "关于 ProcH XP.........." + vbCrLf + "  由 bob008（冻东）完成！" + vbCrLf + "☆☆☆严禁任何未经许可的商业性发布行为及修改！☆☆☆" + vbCrLf + "我会把注册表的偷懒设置设置的更多,如删除打开文件的历史记录等!" + vbCrLf + "最关键的是这是完全免费的程序!并且完全绿色" + vbCrLf + "如果你有什么好的提议或索取源码可与我联系" + vbCrLf + "如果有个免费的主页就好了,可惜-俺又懒的做!烦!" + vbCrLf + "还想加入木马的检测--正在搜集常见木马的特征及标识库!" + vbCrLf + "如果你搜集了,发个MAIL给我!因为我以后会很少用VB了,正在转汇编!"
End Sub
Private Sub mnufileexit_Click()
      Unload Me
End Sub
Private Sub mnurefreshlist_Click()
     prochlvwlis
End Sub

'''''系统文件菜单
Private Sub mnusysfile_Click(Index As Integer)
Select Case Index
       Case 1
        Dim sysfile As String
        Dim openp As String
          sysfile = "c:windowssystem.ini"                  '要打开的文件
          openp = "Notepad.exe"                     '用记事本打开
          Shell openp & " " & sysfile, vbNormalFocus
       Case 2
          sysfile = "c:windowswin.ini"                    '要打开的文件
          openp = "Notepad.exe"                     '用记事本打开
          Shell openp & " " & sysfile, vbNormalFocus
       Case 3
          sysfile = "c:msdos.sys"                           '要打开的文件
          openp = "Notepad.exe"                     '用记事本打开
          Shell openp & " " & sysfile, vbNormalFocus
       Case 4
          sysfile = "c:config.sys"                          '要打开的文件
          openp = "Notepad.exe"                     '用记事本打开
          Shell openp & " " & sysfile, vbNormalFocus
       Case 5
          sysfile = "c:autoexec.bat"                        '要打开的文件
          openp = "Notepad.exe"                     '用记事本打开
          Shell openp & " " & sysfile, vbNormalFocus
End Select
End Sub
Private Sub mnusyspro_Click(Index As Integer)
Select Case Index
       Case 1
           Shell "C:WINDOWSSYSTEMdxdiag.exe", 1 '''DirectX诊断工具
       Case 2
           Shell " C:WINDOWSSYSTEMmsconfig.exe", 1 '''系统配置实用程序
       Case 3
           Shell "c:windowsScanregw.exe", 1 ''''注册表检查程序
       Case 4
           Shell "c:windows
egedit.exe", 1 ''''注册表编辑器
End Select
End Sub
Private Sub mnumailtome_Click()
        Shell "start mailto:abscbn@163.com", vbHide '''''也可以是0，如果改为1，你可以看到效果就会很差
End Sub

Private Sub mnuTe_Click()
If lvw.ListItems.Count = 0 Then ''''如果没有选择就结束
        Exit Sub
    End If
    If MsgBox("结束 " & lvw.SelectedItem & " 吗?", vbYesNo + vbQuestion) <> vbYes Then
        Exit Sub
End If
Dim mProcID As Long
    mProcID = OpenProcess(1&, -1&, "&H" & lvw.SelectedItem.SubItems(4))
    TerminateProcess mProcID, 0&
    DoEvents
    lvw.ListItems.Remove (lvw.SelectedItem.Index)
    lvw.Refresh
prochlvwlis
End Sub
Private Sub mnutouprocesshomepage_Click()
Shell "rundll32.exe url.dll,FileProtocolHandler http://www.csdn.net"     ''''你可以更改你要的链接
End Sub

Private Sub TabStrip1_Click()
Select Case TabStrip1.SelectedItem.Key
       Case "modlis"
           morelisa
       Case "thrlis"
           morelisb
       Case "verlis"
           morelisc
       Case "proclis"
End Select
End Sub

Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
Select Case Button.Index
       Case 1
       Call mnuTe_Click
       Case 3
       fParent
       Case 5
       Dim b As Object
       Dim s As String
       Dim o As String
       Dim g As String
       Dim h As String
       Dim k As String
       
       On Error Resume Next
       Set b = CreateObject("wscript.shell")
       s = "HKCUSoftwareMicrosoftWindowsCurrentVersionPoliciesSystemDisableRegistryTools"
       b.regdelete s
       On Error Resume Next
       o = "HKLMSYSTEMCurrentControlSetServicesCdromAUTORUN"
       b.regwrite o, 0, "REG_DWORD"
       On Error Resume Next
       g = "HKCUSoftwareMicrosoftWindowsCurentVersionExplorerRunMRU"
       b.regdelete g
       On Error Resume Next
       h = "HKCUSoftwareMicrosoftWindowsCurentVersionExplorerDoc Find Spec MRU"
       b.regdelete h
       On Error Resume Next
       k = "HKCUSoftwareMicrosoftWindowsCurentVersionExplorerRecentDocs"
       b.regdelete k
       On Error Resume Next
End Select
End Sub
Sub help() ''''''statusbar上的常见提示
If ProcH.StatusBar1.Panels(2).Text = "c:windowssystemkernel32.dll" Then ProcH.StatusBar1.Panels(2).Text = lvw.SelectedItem + "   内核驱动--警告:不要试图终止它!"
If ProcH.StatusBar1.Panels(2).Text = "c:windowssystemmmtask.tsk" Then ProcH.StatusBar1.Panels(2).Text = lvw.SelectedItem + "   计划任务--讨厌的家伙!俺从不用它!"
If ProcH.StatusBar1.Panels(2).Text = "c:windowssystemddhelp.exe" Then ProcH.StatusBar1.Panels(2).Text = lvw.SelectedItem + "   实时帮助--不要终止它,这个东东的优先极极高!"
If ProcH.StatusBar1.Panels(2).Text = "c:windowssysteminternat.exe" Then ProcH.StatusBar1.Panels(2).Text = lvw.SelectedItem + "   输入法图标--不要终止它!"
If ProcH.StatusBar1.Panels(2).Text = "c:windowssystemsystray.exe" Then ProcH.StatusBar1.Panels(2).Text = lvw.SelectedItem + "   音量控制图标--不要终止它!"
If ProcH.StatusBar1.Panels(2).Text = "c:windowssystemmsgsrv.exe" Then ProcH.StatusBar1.Panels(2).Text = lvw.SelectedItem + "   ☆★☆严重警告--你好毒啊!☆★☆"
If ProcH.StatusBar1.Panels(2).Text = "c:windowsexplorer.exe" Then ProcH.StatusBar1.Panels(2).Text = lvw.SelectedItem + "   警告--不要试图终止它!!!"
If ProcH.StatusBar1.Panels(2).Text = "c:windowssystemmprexe.exe" Then ProcH.StatusBar1.Panels(2).Text = lvw.SelectedItem + " 警告--不要试图终止它!!!   "
If ProcH.StatusBar1.Panels(2).Text = "c:windowssystemwmiexe.exe" Then ProcH.StatusBar1.Panels(2).Text = lvw.SelectedItem + " 警告--不要试图终止它!!!   "
If ProcH.StatusBar1.Panels(2).Text = "c:windowssystemmsgsrv32.exe" Then ProcH.StatusBar1.Panels(2).Text = lvw.SelectedItem + " 警告--不要试图终止它!!!   "
End Sub

Sub morelisa()
     morelvw.ListItems.Clear ''''清空列表，初始化
    morelvw.ColumnHeaders.Clear ''''清空表头，初始化
    morelvw.ColumnHeaders.Add , , "模块名称", 2000 '''添加到表头第一项，有顺序的
    morelvw.ColumnHeaders.Add , , "模块路径", 4000
    morelvw.ColumnHeaders.Add , , "占用内存", 1000 ''''
    morelvw.ColumnHeaders.Add , , "引用数", 1000 ''
    morelvw.ColumnHeaders.Add , , "全局引用", 1000 ''''
    morelvw.ColumnHeaders.Add , , "模块ID", 1000 ''
    morelvw.LabelEdit = lvwManual
    morelvw.FullRowSelect = True
    morelvw.HideSelection = False
    morelvw.HideColumnHeaders = False
    morelvw.View = lvwReport
End Sub
Sub morelisb()
    morelvw.ListItems.Clear ''''清空列表，初始化
    morelvw.ColumnHeaders.Clear ''''清空表头，初始化
    morelvw.ColumnHeaders.Add , , "线程ID", 1400 '''添加到表头第一项，有顺序的
    morelvw.ColumnHeaders.Add , , "基础优先极", 2000
    morelvw.ColumnHeaders.Add , , "线程优先极", 2000 ''''
    morelvw.ColumnHeaders.Add , , "引用数", 1000 ''
    morelvw.LabelEdit = lvwManual
    morelvw.FullRowSelect = True
    morelvw.HideSelection = False
    morelvw.HideColumnHeaders = False
    morelvw.View = lvwReport
End Sub

Sub morelisc()
    morelvw.ListItems.Clear ''''清空列表，初始化
    morelvw.ColumnHeaders.Clear ''''清空表头，初始化
    morelvw.ColumnHeaders.Add , , "项目名称", 3000 '''添加到表头第一项，有顺序的
    morelvw.ColumnHeaders.Add , , "信息", 4000
    morelvw.FullRowSelect = True
    morelvw.HideSelection = False
    morelvw.HideColumnHeaders = False