mdlprocess.bas

一款比较专业

    ByVal lpszFile As String, _
    ByVal lpszTitle As String, _
    ByVal cbBuf As Integer) As Integer
Private Declare Function OpenFile Lib _
    "kernel32.dll" (ByVal lpFileName As String, _
    ByRef lpReOpenBuff As OFSTRUCT, _
    ByVal wStyle As Long) As Long
Private Declare Function GetFileSize Lib _
    "kernel32" (ByVal hFile As Long, _
    lpFileSizeHigh As Long) As Long
Private Declare Function GetProcessMemoryInfo Lib _
    "psapi.dll" (ByVal Process As Long, _
    ByRef ppsmemCounters As PROCESS_MEMORY_COUNTERS, _
    ByVal cb As Long) As Long
Private Declare Function GetLongPathName Lib _
    "kernel32.dll" Alias "GetLongPathNameA" ( _
    ByVal lpszShortPath As String, _
    ByVal lpszLongPath As String, _
    ByVal cchBuffer As Long) As Long
Private Declare Function GetShortPathNameA Lib _
    "kernel32" (ByVal lpszLongPath As String, _
    ByVal lpszShortPath As String, _
    ByVal cchBuffer As Long) As Long
Private Declare Function GetFileVersionInfo Lib _
    "Version.dll" Alias "GetFileVersionInfoA" ( _
    ByVal lptstrFilename As String, _
    ByVal dwhandle As Long, _
    ByVal dwlen As Long, _
    lpData As Any) As Long
Private Declare Function GetFileVersionInfoSize Lib _
    "Version.dll" Alias "GetFileVersionInfoSizeA" ( _
    ByVal lptstrFilename As String, _
    lpdwHandle As Long) As Long
Private Declare Function VerQueryValue Lib _
    "Version.dll" Alias "VerQueryValueA" ( _
    pBlock As Any, _
    ByVal lpSubBlock As String, _
    lplpBuffer As Any, _
    puLen As Long) As Long
Private Declare Sub MoveMemory Lib _
    "kernel32" Alias "RtlMoveMemory" ( _
    dest As Any, _
    ByVal Source As Long, _
    ByVal Length As Long)
Private Declare Function lstrcpy Lib _
    "kernel32" Alias "lstrcpyA" ( _
    ByVal lpString1 As String, _
    ByVal lpString2 As Long) As Long

Public Enum PriorityClass
   REALTIME_PRIORITY_CLASS = &H100
   HIGH_PRIORITY_CLASS = &H80
   NORMAL_PRIORITY_CLASS = &H20
   IDLE_PRIORITY_CLASS = &H40
End Enum

Dim GetIco As New clsGetIconFile

Function StripNulls(ByVal sStr As String) As String
    StripNulls = Left$(sStr, lstrlen(sStr))
End Function

Public Function NTProcessList(lvwProc As ListView, _
    ilsProc As ImageList) As Long
    On Error Resume Next
    Screen.MousePointer = vbHourglass
    Dim Filename As String, ExePath As String
    Dim hProcSnap As Long, hModuleSnap As Long, _
        lProc As Long
    Dim uProcess As PROCESSENTRY32, _
        uModule As MODULEENTRY32
    Dim lvwProcItem As ListItem
    Dim intLVW As Integer
    Dim hVer As VERHEADER
    ExePath = String$(128, Chr$(0))
    hProcSnap = CreateToolhelp32Snapshot(TH32CS_SNAPALL, 0&)
    uProcess.dwSize = Len(uProcess)
    lProc = Process32First(hProcSnap, uProcess)
    ilsProc.ListImages.Clear
    lvwProc.ListItems.Clear
    lvwProc.Visible = False
    Do While lProc
        If uProcess.th32ProcessID <> 0 Then
            hModuleSnap = CreateToolhelp32Snapshot(TH32CS_SNAPALL, _
                uProcess.th32ProcessID)
            uModule.dwSize = Len(uModule)
            Module32First hModuleSnap, uModule
            If hModuleSnap > 0 Then
                ExePath = StripNulls(uModule.szExePath)
                Filename = GetFileName(ExePath)
                GetVerHeader ExePath, hVer
                ilsProc.ListImages.Add , "PID" & uProcess.th32ProcessID, _
                    GetIco.Icon(ExePath, SmallIcon)
                Set lvwProcItem = lvwProc.ListItems.Add(, , Filename, , _
                    "PID" & uProcess.th32ProcessID)
                With lvwProcItem
                    .SubItems(1) = GetLongPath(ExePath)
                    .SubItems(2) = Format(GetSizeOfFile(ExePath) / 1024, _
                        "###,###") & " KB"
                    .SubItems(3) = GetAttribute(ExePath)
                    .SubItems(4) = hVer.FileDescription
                    .SubItems(5) = uProcess.th32ProcessID
                    .SubItems(6) = uProcess.cntThreads
                    .SubItems(7) = Format(GetMemory(uProcess.th32ProcessID) / 1024, _
                        "###,####") & " KB"
                    .SubItems(8) = GetBasePriority(uProcess.th32ProcessID)
                End With
            End If
        End If
        lProc = Process32Next(hProcSnap, uProcess)
    Loop
    Call CloseHandle(hProcSnap)
    For intLVW = 1 To lvwProc.ColumnHeaders.Count
        LV_AutoSizeColumn lvwProc, lvwProc.ColumnHeaders.Item(intLVW)
    Next intLVW
    With lvwProc
        With .ColumnHeaders
            .Item(4).Width = 900
            .Item(6).Width = 950
            .Item(7).Width = 800
            .Item(8).Width = 1250
            .Item(9).Width = 800
        End With
        .Refresh
        .Visible = True
        .SetFocus
    End With
    Screen.MousePointer = vbNormal
End Function

Public Function GetBasePriority(ReadPID As Long) As String
    Dim hPID As Long
    hPID = OpenProcess(PROCESS_QUERY_INFORMATION, 0, ReadPID)
    Select Case GetPriorityClass(hPID)
        Case 32: GetBasePriority = "Normal"
        Case 64: GetBasePriority = "Idle"
        Case 128: GetBasePriority = "High"
        Case 256: GetBasePriority = "Realtime"
        Case Else: GetBasePriority = "N/A"
    End Select
    Call CloseHandle(hPID)
End Function

Public Function SetBasePriority(lvwProc As ListView, _
    ItemProcessID As Integer, BasePriority As PriorityClass) As Long
    Dim hPID As Long
    hPID = OpenProcess(PROCESS_ALL_ACCESS, 0, lvwProc.SelectedItem.SubItems( _
        ItemProcessID))
    SetBasePriority = SetPriorityClass(hPID, BasePriority)
    Call CloseHandle(hPID)
End Function

Private Function Thread32Enum(ByRef Thread() As THREADENTRY32, _
    ByVal lProcessID As Long) As Long
    On Error Resume Next
    ReDim Thread(0)
    Dim THREADENTRY32 As THREADENTRY32
    Dim hThreadSnap As Long
    Dim lThread As Long
    hThreadSnap = CreateToolhelp32Snapshot(TH32CS_SNAPTHREAD, lProcessID)
    THREADENTRY32.dwSize = Len(THREADENTRY32)
    If Thread32First(hThreadSnap, THREADENTRY32) = False Then
        Thread32Enum = -1
        Exit Function
    Else
        ReDim Thread(lThread)
        Thread(lThread) = THREADENTRY32
    End If
    Do
        If Thread32Next(hThreadSnap, THREADENTRY32) = False Then
            Exit Do
        Else
            lThread = lThread + 1
            ReDim Preserve Thread(lThread)
            Thread(lThread) = THREADENTRY32
        End If
    Loop
    Thread32Enum = lThread
    Call CloseHandle(hThreadSnap)
End Function

Public Function SetSuspendResumeThread(lvwProc As ListView, _
    ItemProcessID As Integer, SuspendNow As Boolean) As Long
    Dim Thread() As THREADENTRY32, hPID As Long, hThread As Long, i As Long
    hPID = lvwProc.SelectedItem.SubItems(ItemProcessID)
    Thread32Enum Thread(), hPID
    For i = 0 To UBound(Thread)
        If Thread(i).th32OwnerProcessID = hPID Then
            hThread = OpenThread(THREAD_SUSPEND_RESUME, False, (Thread(i).th32ThreadID))
            If SuspendNow Then
                SetSuspendResumeThread = SuspendThread(hThread)
            Else
                SetSuspendResumeThread = ResumeThread(hThread)
            End If
            Call CloseHandle(hThread)
        End If
    Next i
End Function

Public Function TerminateProcessID(lvwProc As ListView, _
    ItemProcessID As Integer) As Long
    Dim hPID As Long
    hPID = OpenProcess(PROCESS_ALL_ACCESS, 0, lvwProc.SelectedItem.SubItems( _
        ItemProcessID))
    TerminateProcessID = TerminateProcess(hPID, 0)
    Call CloseHandle(hPID)
End Function

Public Function GetAttribute(ByVal sFilePath As String) As String
    Select Case GetFileAttributes(sFilePath)
        Case 1: GetAttribute = "R": Case 2: GetAttribute _
            = "H": Case 3: GetAttribute = "RH": Case 4: _
            GetAttribute = "S": Case 5: GetAttribute = _
            "RS": Case 6: GetAttribute = "HS": Case 7: _
            GetAttribute = "RHS"
        Case 32: GetAttribute = "A": Case 33: GetAttribute _
            = "RA": Case 34: GetAttribute = "HA": Case 35: _
            GetAttribute = "RHA": Case 36: GetAttribute = _
            "SA": Case 37: GetAttribute = "RSA": Case 38: _
            GetAttribute = "HSA": Case 39: GetAttribute = _
            "RHSA"
        Case 128: GetAttribute = "Normal"
        Case 2048: GetAttribute = "C": Case 2049: _
            GetAttribute = "RC": Case 2050: GetAttribute = _
            "HC": Case 2051: GetAttribute = "RHC": Case _
            2052: GetAttribute = "SC": Case 2053: _
            GetAttribute = "RSC": Case 2054: GetAttribute _
            = "HSC": Case 2055: GetAttribute = "RHSC": Case _
            2080: GetAttribute = "AC": Case 2081: _
            GetAttribute = "RAC": Case 2082: GetAttribute _
            = "HAC": Case 2083: GetAttribute = "RHAC": Case _
            2084: GetAttribute = "SAC": Case 2085: _
            GetAttribute = "RSAC": Case 2086: GetAttribute _
            = "HSAC": Case 2087: GetAttribute = "RHSAC"
        Case Else: GetAttribute = "N/A"
    End Select
End Function

Public Function GetFileName(ByVal sFileName As String) As String
    Dim buffer As String