Mohon maaf server download kami mengalami masalah

Cara Membuat Task Manager Dengan Visual Basic 6.0

Langsung Ke Tutor Dan Sourcenya

••Siapkan 1 Buah Form
1 Buah Module

2 Buah Class Module


Name Form "FrmProccess"
Name Module "ModMem"
Name Class Module -"clsGetIcon"
                                -"clsScanProc"


••Form 1 Components
"  • 1 Buah Timer (Interval = '1000')
   • 3 Buah Command Button (Name = 'CmdTerminate, CmdRefresh, CmdExplore')
   • 1 Buah ListView "Caranya Klik Menu Project Lalu Pilih Components Atau Ctrl+T >> Lalu Cari Microsoft Windows Common controls 6.0 (SP6) >> centang dan klik apply lalu ok"
   • Beberapa Label Untuk Memory Status

Diantaranya
- Total Physical Memory (Name =  "LabelName" Caption = "")
- Free Physical Memory (Name =  "LabelName" Caption = "")
- Used Memory  (Name =  "LabelName" Caption = "")
- Free Memory   (Name =  "LabelName" Caption = "")
- Total Page File (Name =  "LabelName" Caption = "")
- Free Page File  (Name =  "LabelName" Caption = "")
- Total Virtual Memory (Name =  "LabelName" Caption = "")
- Free Virtual Memory  (Name =  "LabelName" Caption = "")

  • Lalu Di Sisinya Sisipkan Lagi 8 Buah Label Tanpa Caption Dengan Name Label 1 sampai Label8


  • 2 Buah Check
  • Terakhir Buat Sebuah Menu 
   File (Name = "MnFile")
...Exit (Name = "MnExit")
   Action (Name = "MnAct")
...End Proccess Selected (Name = "MnTerminate)


'#######••Lalu Coding Ini Di Form••#######'



'Watch this area here--^ ...it contains all the form objects that supports events

Dim WithEvents SCANPROC As ClsScanProc
'Take note of the declaration above!!!

Private Declare Function LockWindowUpdate Lib "user32.dll" (ByVal hwndLock As Long) As Long

Dim m_sProcess  As String
Dim m_sTime     As Single
Dim FILEICON    As ClsGetIcon
'##################################################################################






Private Sub cmdrefresh_Click()
Call Check1_Click
End Sub

Private Sub Cmdterminate_Click()
PopupMenu MnAct
End Sub

Private Sub Cmdexplore_Click()
Shell "Explorer.exe " & Left(ListView1.SelectedItem.SubItems(1), _
Len(ListView1.SelectedItem.SubItems(1)) - Len(ListView1.SelectedItem)), _
vbNormalFocus
End Sub


Private Sub ListView1_MouseMove(Button As Integer, Shift As Integer, x As Single, Y As Single)
If Button = 2 Then PopupMenu mnMenu
End Sub






Private Sub MnExit_Click()
Unload Me
End Sub

Private Sub MnTerminate_Click()
If MsgBox("Yakin Untuk Membunuh Proses terpilih ini ??", vbExclamation + vbYesNoCancel + vbDefaultButton2, "Terminate Process") = vbYes Then
        If (SCANPROC.TerminateProcess(ListView1.SelectedItem.SubItems(2)) = True) Then
            Call Check1_Click
        End If
    End If
End Sub

Private Sub SCANPROC_CurrentModule(Process As String, ID As Long, Module As String, File As String)
'   Tips: You can perform checksum checks here indiviually for each file...
    Dim lsv As ListItem
   
    Set lsv = ListView1.ListItems.Add(, , Module)
   
    With lsv
        .ForeColor = RGB(0, 150, 0) ' Dark green
        .SubItems(1) = File
        .ListSubItems(1).ToolTipText = File
'        .Selected = True
'        .EnsureVisible
    End With
End Sub

Private Sub SCANPROC_CurrentProcess(Name As String, File As String, ID As Long, Modules As Long)
'   Tips: You can perform checksum checks here indiviually for each file...
    Dim p_HasImage As Boolean
   
    If (File <> "SYSTEM") Then
        On Error Resume Next
        ImageList1.ListImages(Name).Tag = ""   'Just to test if this item exists
       
        If (Err.Number <> 0) Then
            Err.Clear
            ImageList1.ListImages.Add , Name, FILEICON.Icon(File, SmallIcon)
            p_HasImage = (Err.Number = 0)
        Else
            p_HasImage = True
        End If
    End If
   
    Dim lsv As ListItem
   
    If (p_HasImage = True) Then
        Set lsv = ListView1.ListItems.Add(, "#" & Name & ID, Name, , Name)
    Else
        Set lsv = ListView1.ListItems.Add(, "#" & Name & ID, Name)
    End If
   
    With lsv
        .ForeColor = vbBlue
        .SubItems(1) = File
        .SubItems(2) = ID
        .SubItems(3) = Modules
        .ListSubItems(2).ForeColor = vbRed
        .ListSubItems(1).ToolTipText = File
'        .Selected = True
'        .EnsureVisible
    End With
   
    If (m_sProcess <> "#" & Name & ID) Then
        Modules = 0
    End If
End Sub

Private Sub SCANPROC_DoneScanning(TotalProcess As Long)
    Dim p_Elapsed As Single
    p_Elapsed = Timer - m_sTime
   
    LockWindowUpdate 0& ' Enable listview repaint
   
    'Debug.Print "Total Number of Process Detected: " & TotalProcess & vbNewLine & "Total Scan Time: " & p_Elapsed & vbNewLine
    NUMPROC = TotalProcess
End Sub

'##################################################################################

Private Sub ListView1_ItemClick(ByVal Item As MSComctlLib.ListItem)

    If (Check2.Value <> vbChecked) Then
        'PopupMenu mnEx 'If Button = 2 Then PopupMenu mnEx
        Exit Sub ' What for?
    End If
   
    Dim i As Long
    i = Item.Index
   
    If (m_sProcess = Item.Key) Then
        m_sProcess = ""
    Else
        m_sProcess = Item.Key
    End If
   
    Call Check1_Click
   
    On Error Resume Next
    ListView1.ListItems(i).Selected = True
    ListView1.SelectedItem.EnsureVisible

End Sub

Private Sub Check1_Click()
    ListView1.ListItems.Clear
   
    SCANPROC.SystemProcesses = (Check1.Value = vbChecked)
    SCANPROC.ProcessModules = (Check2.Value = vbChecked)
   
    m_sTime = Timer
   
    LockWindowUpdate ListView1.hWnd ' Prevent listview repaints
    SCANPROC.BeginScanning
End Sub

Private Sub Check2_Click()
    If (Check2.Value = vbChecked) Then
        Command2.Caption = "Refresh"
    Else
        Command2.Caption = "Refresh"
    End If
End Sub




Private Sub Form_KeyPress(KeyAscii As Integer)
    If (KeyAscii = vbKeyEscape) Then
        SCANPROC.CancelScanning
        Unload Me
    End If
End Sub

Private Sub Form_Load()
    Set SCANPROC = New ClsScanProc
    Set FILEICON = New ClsGetIcon
    Call Check1_Click
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Set SCANPROC = Nothing
    Set FILEICON = Nothing
End Sub



Private Sub Timer1_Timer()
    Dim mem As MEMORYSTATUS
    GlobalMemoryStatus mem
    Dim tot, free
    ModMem.getfreemem tot, free
    Label1.Caption = Round(mem.dwTotalPhys / 1024 / 1024, 2) & " MB"
    Label2.Caption = Round(mem.dwAvailPhys / 1024 / 1024, 2) & " MB"
    Label3.Caption = Round((tot - free) / 1024 / 1024, 2) & " MB Used [" & Round(((tot - free) / tot) * 100, 2) & "%]"
    Label8.Caption = Round(free / 1024 / 1024, 2) & " MB Free [" & Round((free / tot) * 100, 2) & "%]"
    Label4.Caption = Round(mem.dwTotalPageFile / 1024 / 1024, 2)
    Label5.Caption = Round(mem.dwAvailPageFile / 1024 / 1024, 2)
    Label6.Caption = Round(mem.dwTotalVirtual / 1024 / 1024, 2)
    Label7.Caption = Round(mem.dwAvailVirtual / 1024 / 1024, 2)
End Sub




'#######••Selesai Coding Form••#######






'######Sekarang Coding Di Module (ModMem)######
Option Explicit


Public Declare Sub GlobalMemoryStatus Lib "kernel32" (lpBuffer As MEMORYSTATUS)

Public Type MEMORYSTATUS
        dwLength As Long
        dwMemoryLoad As Long
        dwTotalPhys As Long
        dwAvailPhys As Long
        dwTotalPageFile As Long
        dwAvailPageFile As Long
        dwTotalVirtual As Long
        dwAvailVirtual As Long
End Type

Public Function getfreemem(ByRef Total As Variant, ByRef free As Variant)
'Returns total as totlaphysicalmem(in KB)
'Returns free as freephysicalmem(in KB)
Dim mem As MEMORYSTATUS
 GlobalMemoryStatus mem
free = mem.dwAvailPhys
Total = mem.dwTotalPhys
End Function

'######Selesai Disini  Coding ModMem######



Nah Sekarang Tinggal Sisipkan Code Berikut Di Class Module





'###### Coding ClassModule (clsGetIcon)
' Modified API Declaration
Private Declare Function lstrlen Lib "kernel32.dll" Alias "lstrlenA" (ByVal lpString As String) As Long
Private Declare Sub OleCreatePictureIndirect Lib "oleaut32.dll" (ByRef lpPictDesc As PictDesc, ByRef riid As Guid, ByVal fOwn As Long, ByRef lplpvObj As IPictureDisp)
Private Declare Function SHGetFileInfo Lib "shell32.dll" Alias "SHGetFileInfoA" (ByVal pszPath As String, ByVal dwFileAttributes As Long, ByRef psfi As SHFILEINFO, ByVal cbFileInfo As Long, ByVal uFlags As ESHGetFileInfoFlagConstants) As Long

' API Constants
Private Const ERRORAPI As Long = 0
Private Const MAX_PATH As Long = 260

' API Types
Private Type Guid
    Data1           As Long
    data2           As Integer
    Data3           As Integer
    Data4(0 To 7)   As Byte
End Type

Private Type PictDesc
    cbSizeofStruct  As Long
    picType         As Long
    hImage          As Long
    xExt            As Long
    yExt            As Long
End Type

Private Type SHFILEINFO
    hIcon           As Long ' : icon
    iIcon           As Long ' : icondex
    dwAttributes    As Long ' : SFGAO_ flags
    szDisplayName   As String * MAX_PATH ' : display name (or path)
    szTypeName      As String * 80 ' : type name
End Type

'User-Defined API Enum
Private Enum ESHGetFileInfoFlagConstants
    SHGFI_ATTRIBUTES = &H800        ' get file attributes
    SHGFI_DISPLAYNAME = &H200       ' get display name
    SHGFI_EXETYPE = &H2000          ' get exe type
    SHGFI_ICON = &H100              ' get icon handle and index
    SHGFI_LARGEICON = &H0           ' get file's large icon
    SHGFI_LINKOVERLAY = &H8000      ' add link overlay on the icon
    SHGFI_OPENICON = &H2            ' get file's open icon
    SHGFI_SELECTED = &H10000        ' blend icon with the system highlight color
    SHGFI_SHELLICONSIZE = &H4       ' get shell-sized icon
    SHGFI_SMALLICON = &H1           ' get file's small icon
    SHGFI_SYSICONINDEX = &H4000     ' get icon index from system image list
    SHGFI_TYPENAME = &H400          ' get file type description
    SHGFI_USEFILEATTRIBUTES = &H10  ' use dwFileAttributes parameter
End Enum

Public Enum EFileIconTypes
    LargeIcon = 0
    SmallIcon = 1
End Enum

Public Enum EFileExeTypes
    MSDosApp = 2        ' MS-DOS .EXE, .COM or .BAT file
    NonExecutable = 0   ' Nonexecutable file or an error condition
    Win32Console = 3    ' Win32 console application
    WindowsApp = 1      ' Windows application
End Enum

' Variable Declarations
Private m_bOpenState    As Boolean
Private m_bOverlay      As Boolean
Private m_bSelected     As Boolean
Private m_eIconType     As EFileIconTypes
Private m_lHandle       As Long
Private m_sFile         As String

' //-- Properties --//

Public Property Get DisplayName(Optional File) As String
'Returns the display name of the specified file.
    Dim p_Ret   As Long
    Dim p_SHFI  As SHFILEINFO
   
    If (IsMissing(File)) Then
        File = m_sFile
    End If
   
    p_Ret = SHGetFileInfo(CStr(File), 0&, p_SHFI, Len(p_SHFI), SHGFI_DISPLAYNAME)
   
    If (p_Ret <> ERRORAPI) Then
        DisplayName = p_SHFI.szDisplayName
        DisplayName = Left$(DisplayName, lstrlen(DisplayName))
    End If
End Property

Public Property Get ExeType(Optional File) As EFileExeTypes
'Returns the display name of the specified file.
    Dim p_Ret   As Long
    Dim p_SHFI  As SHFILEINFO
   
    If (IsMissing(File)) Then
        File = m_sFile
    End If
   
    p_Ret = SHGetFileInfo(CStr(File), 0&, p_SHFI, Len(p_SHFI), SHGFI_EXETYPE)
   
    If (p_Ret <> ERRORAPI) Then
        If (HiWord(p_Ret) > 0) Then ' NE 0x00004E45 or PE 0x00005045
            ExeType = WindowsApp
        Else
            Select Case LoWord(p_Ret)
                Case 23117 ' MZ 0x00004D5A
                    ExeType = MSDosApp
                Case 17744 ' PE 0x00005045
                    ExeType = Win32Console
            End Select
        End If
    End If
End Property

Public Property Get File() As String
'Returns/sets the complete file path to be used.
    File = m_sFile
End Property

Public Property Let File(Value As String)
    m_sFile = Value
End Property

Public Property Get Handle() As Long
'Returns/sets the icon handle to be used by the IconEx property.
    Handle = m_lHandle
End Property

Public Property Let Handle(Value As Long)
    m_lHandle = Value
End Property

Public Property Get IconType() As EFileIconTypes
'Returns/sets the type of icon to retrieve.
    IconType = m_eIconType
End Property

Public Property Let IconType(Value As EFileIconTypes)
    m_eIconType = Value
End Property

Public Property Get Icon(Optional File, Optional IconType) As IPictureDisp
'Returns the icon of the specified file.
    If (IsMissing(File)) Then
        File = m_sFile
    End If
   
    If (IsMissing(IconType)) Then
        IconType = m_eIconType
    End If
   
    Dim p_Flags As ESHGetFileInfoFlagConstants
    Dim p_hIcon As Long
    Dim p_Ret   As Long
    Dim p_SHFI  As SHFILEINFO
   
    If (m_eIconType = LargeIcon) Then
        p_Flags = SHGFI_ICON Or SHGFI_LARGEICON
    Else
        p_Flags = SHGFI_ICON Or SHGFI_SMALLICON
    End If
   
    If (m_bOverlay) Then
        p_Flags = p_Flags Or SHGFI_LINKOVERLAY
    End If
   
    If (m_bSelected) Then
        p_Flags = p_Flags Or SHGFI_SELECTED
    Else
        p_Flags = p_Flags And Not SHGFI_SELECTED
    End If
   
    If (m_bOpenState) Then
        p_Flags = p_Flags Or SHGFI_OPENICON
    Else
        p_Flags = p_Flags And Not SHGFI_OPENICON
    End If
   
    p_Ret = SHGetFileInfo(CStr(File), 0&, p_SHFI, Len(p_SHFI), p_Flags)
   
    If (p_Ret <> ERRORAPI) Then
        p_hIcon = p_SHFI.hIcon
       
        If (p_hIcon) Then
            Set Icon = IconEx(p_hIcon)
        End If
    End If
End Property

Public Property Get IconEx(Optional hIcon As Long) As IPictureDisp
'Returns the file's icon using the specified icon handle.
    If (hIcon = 0) Then
        hIcon = m_lHandle
       
        If (hIcon = 0) Then
            Exit Property
        End If
    End If
   
    Dim p_Picture   As IPictureDisp
    Dim p_PicDesc   As PictDesc
    Dim p_Guid      As Guid
   
    p_PicDesc.cbSizeofStruct = Len(p_PicDesc)
    p_PicDesc.picType = vbPicTypeIcon
    p_PicDesc.hImage = hIcon
   
    ' IPicture GUID {7BF80980-BF32-101A-8BBB-00AA00300CAB}
    With p_Guid
        .Data1 = &H7BF80980
        .data2 = &HBF32
        .Data3 = &H101A
        .Data4(0) = &H8B
        .Data4(1) = &HBB
        .Data4(2) = &H0
        .Data4(3) = &HAA
        .Data4(4) = &H0
        .Data4(5) = &H30
        .Data4(6) = &HC
        .Data4(7) = &HAB
    End With
    ' From vbAccelerator... (http://www.vbaccelerator.com)
   
    OleCreatePictureIndirect p_PicDesc, p_Guid, True, p_Picture
   
    Set IconEx = p_Picture
End Property

Public Property Get LinkOverlay() As Boolean
'Returns/sets a value to determine if a linkoverlay icon is displayed on the icon.
    LinkOverlay = m_bOverlay
End Property

Public Property Let LinkOverlay(Value As Boolean)
    m_bOverlay = Value
End Property

Public Property Get OpenState() As Boolean
'Returns/sets a value to determine if the icon will be in open state. (Ex. Folders)
    OpenState = m_bOpenState
End Property

Public Property Let OpenState(Value As Boolean)
    m_bOpenState = Value
End Property

Public Property Get Selected() As Boolean
'Returns/sets a value to determine if the icon is in selected state.
    Selected = m_bSelected
End Property

Public Property Let Selected(Value As Boolean)
    m_bSelected = Value
End Property

Public Property Get TypeName(Optional File) As String
'Returns the type name of the specified file.
    Dim p_Ret   As Long
    Dim p_SHFI  As SHFILEINFO
   
    If (IsMissing(File)) Then
        File = m_sFile
    End If
   
    p_Ret = SHGetFileInfo(CStr(File), 0&, p_SHFI, Len(p_SHFI), SHGFI_TYPENAME)
   
    If (p_Ret <> ERRORAPI) Then
        TypeName = p_SHFI.szTypeName
        TypeName = Left$(TypeName, lstrlen(TypeName))
    End If
End Property

' //-- Private properties --//

Private Property Get HiWord(DWord As Long) As Long
    HiWord = (DWord And &HFFFF0000) \ &H10000
End Property

Private Property Get LoWord(DWord As Long) As Long
    If (DWord And &H8000&) Then
        LoWord = DWord Or &HFFFF0000
    Else
        LoWord = DWord And &HFFFF&
    End If
End Property

' Created by Noel A. Dacara | Copyright © 2003-2005 Davao City, Philippines
'######Selesai Disini######






'######Coding (clsScanProc)######
' API Declarations
Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long
Private Declare Function CreateToolhelp32Snapshot Lib "kernel32.dll" (ByVal dwFlags As Long, ByVal th32ProcessID As Long) 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 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 FormatMessage Lib "kernel32.dll" Alias "FormatMessageA" (ByVal dwFlags As Long, ByRef lpSource As Any, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, ByRef Arguments As Long) As Long
Private Declare Function GetCurrentProcess Lib "kernel32.dll" () As Long
Private Declare Function GetModuleBaseName Lib "psapi.dll" Alias "GetModuleBaseNameA" (ByVal hProcess As Long, ByVal hModule As Long, ByVal lpBaseName As String, ByVal nSize 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 GetQueueStatus Lib "user32.dll" (ByVal fuFlags As Long) As Long
Private Declare Function GetVersionEx Lib "kernel32.dll" Alias "GetVersionExA" (ByRef lpVersionInformation As OSVERSIONINFO) As Long
Private Declare Function GetWindowsDirectory Lib "kernel32.dll" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Private Declare Function lstrlen Lib "kernel32.dll" Alias "lstrlenA" (ByVal lpString As String) 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 OpenProcessToken Lib "advapi32.dll" (ByVal ProcessHandle As Long, ByVal DesiredAccess As Long, ByRef TokenHandle As Long) As Long
Private Declare Function Process32First Lib "kernel32.dll" (ByVal hSnapshot As Long, ByRef lppe As PROCESSENTRY32) As Long
Private Declare Function Process32Next Lib "kernel32.dll" (ByVal hSnapshot As Long, ByRef lppe As PROCESSENTRY32) As Long

' Modified API Declaration
Private Declare Function AdjustTokenPrivileges Lib "advapi32.dll" (ByVal TokenHandle As Long, ByVal DisableAllPrivileges As Long, ByRef NewState As TOKEN_PRIVILEGES, ByVal BufferLength As Long, ByVal PreviousState As Long, ByVal ReturnLength As Long) As Long
Private Declare Function LookupPrivilegeValue Lib "advapi32.dll" Alias "LookupPrivilegeValueA" (ByVal lpSystemName As String, ByVal lpName As String, ByRef lpLuid As LUID) As Long
Private Declare Function TerminateProcess32 Lib "kernel32.dll" Alias "TerminateProcess" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long

' API Constants
Private Const ANYSIZE_ARRAY                 As Long = 1
Private Const FORMAT_MESSAGE_FROM_SYSTEM    As Long = &H1000
Private Const MAX_DESCRIPTION               As Long = 1024
Private Const MAX_MODULE_NAME32             As Long = 255
Private Const MAX_PATH                      As Long = 260
Private Const PROCESS_QUERY_INFORMATION     As Long = (&H400)
Private Const PROCESS_VM_READ               As Long = (&H10)
Private Const SE_DEBUG_NAME                 As String = "SeDebugPrivilege"
Private Const SE_PRIVILEGE_ENABLED          As Long = &H2
Private Const STANDARD_RIGHTS_REQUIRED      As Long = &HF0000
Private Const SYNCHRONIZE                   As Long = &H100000
Private Const TH32CS_SNAPPROCESS            As Long = &H2
Private Const TOKEN_ADJUST_PRIVILEGES       As Long = &H20
Private Const TOKEN_QUERY                   As Long = &H8
Private Const PROCESS_ALL_ACCESS            As Long = (STANDARD_RIGHTS_REQUIRED Or SYNCHRONIZE Or &HFFF)
Private Const VER_PLATFORM_WIN32_NT         As Long = 2

'GetQueueStatus Flag
Private Const QS_ALLEVENTS As Long = &HBF

' API Types
Private Type LARGE_INTEGER
    lowpart     As Long
    highpart    As Long
End Type

Private Type LUID
    lowpart     As Long
    highpart    As Long
End Type

Private Type LUID_AND_ATTRIBUTES
    pLuid       As LUID
    Attributes  As Long
End Type

Private Type OSVERSIONINFO
    dwOSVersionInfoSize As Long
    dwMajorVersion      As Long
    dwMinorVersion      As Long
    dwBuildNumber       As Long
    dwPlatformId        As Long
    szCSDVersion        As String * 128 ' Maintenance string for PSS usage
End Type

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 * MAX_PATH
End Type

Private Type TOKEN_PRIVILEGES
    PrivilegeCount              As Long
    Privileges(ANYSIZE_ARRAY)   As LUID_AND_ATTRIBUTES
End Type

' Variable Declarations
Private m_bCancel       As Boolean
Private m_bErrorOnFail  As Boolean
Private m_bOldMethod    As Boolean
Private m_bPaused       As Boolean
Private m_bProcModules  As Boolean
Private m_bScanning     As Boolean
Private m_bSystemProc   As Boolean
Private m_bTerminated   As Boolean
Private m_lNumProcess   As Long
Private m_lProcessID    As Long
Private m_lWinPlatform  As Long

' //-- Class Events --//

Public Event CurrentModule(Process As String, ID As Long, Module As String, File As String)
'Occurs everytime a process is scanned for modules.
Public Event CurrentProcess(Name As String, File As String, ID As Long, Modules As Long)
'Occurs everytime a process is scanned.
Public Event DoneScanning(TotalProcess As Long)
'Occures after scanning all processes.

#If False Then
    ' Trick to preserve casing of these variables when used in VB IDE
    Private Process, Module, File, Name, Path, ID, Modules, TotalProcess
#End If

' //-- Properties --//

Public Property Get ErrorOnFail() As Boolean
'Returns/sets whether to raise an error if process termination fails.
    ErrorOnFail = m_bErrorOnFail
End Property

Public Property Let ErrorOnFail(Value As Boolean)
    m_bErrorOnFail = Value
End Property

Public Property Get ForceOldMethod() As Boolean
'Force to use the older method of enumerating processes for newer Windows systems.
    ForceOldMethod = m_bOldMethod
End Property

Public Property Let ForceOldMethod(Value As Boolean)
    m_bOldMethod = Value
End Property

Public Property Get ProcessModules() As Boolean
'Scan for modules(dll,ocx,etc..) used by a process other than its main executable.
    ProcessModules = m_bProcModules
End Property

Public Property Let ProcessModules(Value As Boolean)
    m_bProcModules = Value
End Property

Public Property Get ProcessTerminated() As Boolean
'Returns the boolean result for a process terminated in the class event.
    ProcessTerminated = m_bTerminated
End Property

Public Property Get Scanning() As Boolean
'Returns True if class is currently on scanning state.
    Scanning = m_bScanning
End Property

Public Property Get SystemProcesses() As Boolean
'Returns/sets whether to include scanning for system processes.
    SystemProcesses = m_bSystemProc
End Property

Public Property Let SystemProcesses(Value As Boolean)
    m_bSystemProc = Value
End Property

Public Property Get TotalProcesses() As Integer
'Returns the current or the total number of processes scanned.
    TotalProcesses = m_lNumProcess
End Property

' //-- Procedures --//

Public Sub BeginScanning()
'Start scanning for running processes in the system.
    If (m_bPaused) Then
        ResumeScanning ' Resume scanning instead
        Exit Sub
    End If
   
    If (m_bScanning) Then
        Exit Sub ' avoid cascading scans
    End If
   
    m_bCancel = False
    m_lNumProcess = 0
   
    m_bScanning = True
    ScanForProcesses ' scan the system for running processes
    m_bScanning = False
   
    m_lProcessID = -1
    RaiseEvent DoneScanning(m_lNumProcess)
End Sub

Public Sub CancelScanning()
'Abort scanning for running processes.
    m_bCancel = True
    ResumeScanning ' Resume if scanning has been paused
End Sub

Public Sub PauseScanning()
'Temporarily stop scanning process.
    If (m_bScanning) Then
        m_bPaused = True
    End If
End Sub

Public Sub ResumeScanning()
'Resume paused scanning process.
    If (m_bPaused) Then
        m_bPaused = False
    End If
End Sub

Public Function TerminateProcess(Optional lProcessID As Long = -1) As Boolean
'Terminate a running process using the specified process ID.
    If (lProcessID = -1) Then
        lProcessID = m_lProcessID ' Get process ID of currently scanned process
       
        ' If process ID is not given, it will attempt to terminate the current process
        If (lProcessID = -1) Then
            Exit Function
        End If
    End If
   
    Dim p_lProcess      As Long
    Dim p_lToken        As Long
    Dim p_tPrivileges   As TOKEN_PRIVILEGES
   
    ' Windows NT/2000 requires special treatment to ensure that the
    ' calling process has enough privileges to perform the instruction.
   
    If (m_lWinPlatform = VER_PLATFORM_WIN32_NT) Then
        ' Open token of the defined process
        If (OpenProcessToken(GetCurrentProcess, TOKEN_ADJUST_PRIVILEGES Or TOKEN_QUERY, p_lToken) = 0) Then
            GoTo End_Function
        End If
       
        ' Get LUID used to locally represent the specified privilege name
        If (LookupPrivilegeValue("", SE_DEBUG_NAME, p_tPrivileges.Privileges(ANYSIZE_ARRAY).pLuid) = 0) Then
            GoTo End_Function
        End If
       
        p_tPrivileges.PrivilegeCount = 1
        p_tPrivileges.Privileges(ANYSIZE_ARRAY).Attributes = SE_PRIVILEGE_ENABLED
       
        ' Attempt to acquire debug privilege for the process
        If (AdjustTokenPrivileges(p_lToken, 0&, p_tPrivileges, 0&, 0&, 0&) = 0) Then
            GoTo End_Function
        End If
    End If
   
    ' Finally, open the defined process
    p_lProcess = OpenProcess(PROCESS_ALL_ACCESS, 0&, lProcessID)
   
    If (p_lProcess) Then
        ' Attempt to terminate the process
        TerminateProcess = (TerminateProcess32(p_lProcess, 0&) <> 0)
        CloseHandle p_lProcess
       
        If (Not TerminateProcess) Then
            If (m_bErrorOnFail) Then
                Err.Raise Err.LastDllError, , ErrorDescription(Err.LastDllError)
            End If
        End If
       
        If (GetQueueStatus(QS_ALLEVENTS)) Then ' check for events
            DoEvents
        End If
    End If
   
    If (m_lWinPlatform = VER_PLATFORM_WIN32_NT) Then
        ' Restore original privilege
        p_tPrivileges.Privileges(ANYSIZE_ARRAY).Attributes = 0
        AdjustTokenPrivileges p_lToken, 0&, p_tPrivileges, 0&, 0&, 0&
       
End_Function:
        If (p_lToken) Then
            CloseHandle p_lToken
        End If
    End If
End Function

' //-- Private Procedures --//

Private Sub DeepProcessScan(ID As Long, Name As String)
    If (m_bCancel Or m_lWinPlatform <> VER_PLATFORM_WIN32_NT) Then
        If (Not m_bCancel) Then
            m_lNumProcess = m_lNumProcess + 1
            RaiseEvent CurrentProcess(Name, "", ID, 1)
        End If
       
        Exit Sub ' Abort the whole scanning process
    End If
   
    Dim i                       As Long
    Dim p_lModuleCount          As Long
    Dim p_lModules(1 To 1024)   As Long
    Dim p_lNeeded               As Long
    Dim p_lProcess              As Long
    Dim p_lRet                  As Long
    Dim p_sBaseName             As String
    Dim p_sBuffer               As String
    Dim p_sProcessPath          As String
   
    p_lProcess = OpenProcess(PROCESS_QUERY_INFORMATION Or PROCESS_VM_READ, 0&, ID)
   
    If (p_lProcess) Then
        p_lRet = EnumProcessModules(p_lProcess, p_lModules(1), 1024 * 4, p_lNeeded)
       
        If (p_lRet) Then
            p_lModuleCount = p_lNeeded \ 4
           
            For i = 1 To p_lModuleCount
                If (GetQueueStatus(QS_ALLEVENTS)) Then ' check for events
                    DoEvents ' processes system events
                End If
               
                If (m_bPaused) Then
                    m_bScanning = False
                    While (m_bPaused)
                        DoEvents ' Don't execute next instructions until resumed
                    Wend
                    m_bScanning = True
                End If
               
                If (m_bCancel) Then
                    Exit For ' attempt to abort the whole scanning process
                End If
               
                p_sBuffer = String$(MAX_MODULE_NAME32, 0)
                p_lRet = GetModuleBaseName(p_lProcess, p_lModules(i), p_sBuffer, MAX_MODULE_NAME32)
               
                If (p_lRet > 0) Then
                    p_sBaseName = Left$(p_sBuffer, p_lRet)
                End If
               
                p_sBuffer = String$(MAX_MODULE_NAME32, 0)
                p_lRet = GetModuleFileNameEx(p_lProcess, p_lModules(i), p_sBuffer, MAX_MODULE_NAME32)
               
                If (p_lRet > 0) Then
                    p_sProcessPath = Left$(p_sBuffer, p_lRet)
                End If
               
                ValidatePath p_sProcessPath
               
                If (i = 1) Then
                    If (Len(p_sProcessPath) = 0) Then
                        ' Consider as a system process if file path is empty
                        p_sProcessPath = "SYSTEM"
                       
                        If (Not m_bSystemProc) Then
                            Exit For ' Excluding system processes
                        End If
                    End If
                   
                    m_lNumProcess = m_lNumProcess + 1
                    RaiseEvent CurrentProcess(p_sBaseName, p_sProcessPath, ID, p_lModuleCount)
                   
                    If (Not m_bProcModules) Or (p_lModuleCount = 0) Then
                        Exit For ' Dont scan preceding process modules
                    End If
                Else
                    RaiseEvent CurrentModule(Name, ID, p_sBaseName, p_sProcessPath)
                End If
            Next
           
            CloseHandle p_lProcess
            Exit Sub
        Else
            If (Len(Name) = 0) And (ID) Then
                Name = "System" ' Assume this is a system process
            End If
        End If
       
        CloseHandle p_lProcess
    End If
   
    If (m_bSystemProc = True) Then
        If (Len(Name) = 0) And (ID) Then
            Name = "[System Process]" ' a.k.a "System Idle Process"
        End If
       
        m_lNumProcess = m_lNumProcess + 1
        RaiseEvent CurrentProcess(Name, "SYSTEM", ID, 1)
    End If
End Sub

Private Function ErrorDescription(nError As Long) As String
    Dim p_lLen As Long
    Dim p_sBuffer As String * MAX_DESCRIPTION
   
    p_lLen = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, _
                           ByVal 0&, _
                           nError, _
                           0&, _
                           p_sBuffer, _
                           MAX_DESCRIPTION, _
                           0&)
    If (p_lLen > 0) Then
        ErrorDescription = Left$(p_sBuffer, p_lLen)
    End If
End Function

Private Sub ScanForProcesses()
    Dim p_eProcessEntry As PROCESSENTRY32
    Dim p_lNeeded       As Long
    Dim p_lProcess      As Long
    Dim p_lProcesses()  As Long
    Dim p_lProcessID    As Long
    Dim p_lSnapshot     As Long
    Dim p_sExeFile      As String
   
    ' Windows 2000/ME/XP or later
    If (m_lWinPlatform = VER_PLATFORM_WIN32_NT) And (Not m_bOldMethod) Then
        ReDim p_lProcesses(1 To 1024) As Long
       
        If (EnumProcesses(p_lProcesses(1), 1024 * 4, p_lNeeded)) Then
            p_lNeeded = p_lNeeded \ 4
           
            For p_lProcess = 1 To p_lNeeded
                If (m_bCancel) Then
                    Exit For
                End If
               
                DeepProcessScan p_lProcesses(p_lProcess), ""
            Next
           
            Exit Sub
        Else
            ' Raise an error
            Err.Raise Err.LastDllError, , ErrorDescription(Err.LastDllError)
            ' Then attempt to enumerate processes using the other way below
        End If
    End If
   
    ' Windows 95/98 (Old Method)
    p_lSnapshot = CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0&)
   
    If (p_lSnapshot) Then
        p_eProcessEntry.dwSize = Len(p_eProcessEntry)
        p_lProcess = Process32First(p_lSnapshot, p_eProcessEntry)
       
        Do While (p_lProcess) ' iterate through all processes
            If (GetQueueStatus(QS_ALLEVENTS)) Then ' check for events
                DoEvents ' processes system events
            End If
           
            If (m_bPaused) Then
                m_bScanning = False
                While (m_bPaused)
                    DoEvents ' Don't execute next instructions until resumed
                Wend
                m_bScanning = True
            End If
           
            If (m_bCancel) Then
                Exit Do ' abort the whole scanning process
            End If
           
            p_lProcessID = p_eProcessEntry.th32ProcessID
            m_lProcessID = p_lProcessID
           
            p_sExeFile = p_eProcessEntry.szExeFile
            p_sExeFile = Left$(p_sExeFile, lstrlen(p_sExeFile))
           
            ' We need to get process name from path, because process name
            ' from PROCESSENTRY32 type is not complete for long filenames.
            DeepProcessScan p_lProcessID, p_sExeFile
Next_Process:
            p_eProcessEntry.szExeFile = String$(MAX_PATH, 0)
            p_lProcess = Process32Next(p_lSnapshot, p_eProcessEntry)
        Loop
    End If
End Sub

Private Sub ValidatePath(ByRef Path As String)
     ' UNC File names
    If (InStr(1, Path, "\?\UNC\", vbTextCompare)) Then
        Path = Replace$(Path, "\?\UNC\", "", 1, 1)
    End If
   
    ' \\?\ tells Windows to turn off File parsing
    If (InStr(1, Path, "\??\", vbTextCompare)) Then
        Path = Replace$(Path, "\??\", "", 1, 1)
    End If
   
     ' Only the first instances will be replaced
    If (InStr(1, Path, "\SystemRoot\", vbTextCompare)) Then
        Path = Replace$(Path, "\SystemRoot\", WindowsDirectory, 1, 1)
    End If
End Sub

Private Function WindowsDirectory()
    Dim p_lLen      As Long
    Dim p_sBuffer   As String * MAX_PATH
   
    p_lLen = GetWindowsDirectory(p_sBuffer, MAX_PATH)
    If (p_lLen > 0) Then
        WindowsDirectory = Left$(p_sBuffer, p_lLen)
    End If
   
    If (WindowsDirectory Like "*\") Then
        ' Just do nothing
    Else
        WindowsDirectory = WindowsDirectory & "\"
    End If
End Function

Private Function WindowsPlatform() As Long
    Dim p_tOSInfo As OSVERSIONINFO
   
    p_tOSInfo.dwOSVersionInfoSize = Len(p_tOSInfo)
    GetVersionEx p_tOSInfo
    WindowsPlatform = p_tOSInfo.dwPlatformId
End Function

' //-- Class Procedures --//

Private Sub Class_Initialize()
    ' unless these properties are set, these would be their default values
    m_bSystemProc = False
    m_lProcessID = -1
    m_lWinPlatform = WindowsPlatform
End Sub

Private Sub Class_Terminate()
    If (m_bScanning Or m_bPaused) Then
        CancelScanning
    End If
End Sub

' Created by Noel A. Dacara | Copyright © 2003-2005 Davao City, Philippines

'######Selesai Disini######


Coba Jalankan Jika Berhasil Anda Sudah MEnjadi Programer
Previous
Next Post »
Thanks for your comment