modprocessnetstat.bas

支持监控包括传输控制协议和 UDP 的所有的互联网传输协议。同时程序具有实时文件防修改监控功能

Attribute VB_Name = "modProcessNetStat"
'****************************************************************************
'人人为我，我为人人
'枕善居汉化收藏整理
'发布日期：2007/09/20
'描    述：界面清爽VB版高级专业防火墙 Ver 2.0.3
'网    站：http://www.Mndsoft.com/  (VB6源码博客)
'网    站：http://www.VbDnet.com/   (VB.NET源码博客,主要基于.NET2005)
'e-mail  ：[e-mail]
'e-mail  ：[e-mail]
'OICQ    ：88382850
'          如果您有新的好的代码别忘记给枕善居哦!
'****************************************************************************

Option Explicit
'For netstat
Private Const PROCESS_VM_READ               As Long = &H10
Private Const PROCESS_QUERY_INFORMATION     As Long = &H400
Private Const MIB_TCP_STATE_CLOSED          As Long = 1
Private Const MIB_TCP_STATE_LISTEN          As Long = 2
Private Const MIB_TCP_STATE_SYN_SENT        As Long = 3
Private Const MIB_TCP_STATE_SYN_RCVD        As Long = 4
Private Const MIB_TCP_STATE_ESTAB           As Long = 5
Private Const MIB_TCP_STATE_FIN_WAIT1       As Long = 6
Private Const MIB_TCP_STATE_FIN_WAIT2       As Long = 7
Private Const MIB_TCP_STATE_CLOSE_WAIT      As Long = 8
Private Const MIB_TCP_STATE_CLOSING         As Long = 9
Private Const MIB_TCP_STATE_LAST_ACK        As Long = 10
Private Const MIB_TCP_STATE_TIME_WAIT       As Long = 11
Private Const MIB_TCP_STATE_DELETE_TCB      As Long = 12
Private Type PMIB_UDPEXROW
    dwLocalAddr                                 As Long
    dwLocalPort                                 As Long
    dwProcessId                                 As Long
End Type
Private Type PMIB_TCPEXROW
    dwStats                                     As Long
    dwLocalAddr                                 As Long
    dwLocalPort                                 As Long
    dwRemoteAddr                                As Long
    dwRemotePort                                As Long
    dwProcessId                                 As Long
End Type
Public mheap                                As Long
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 Declare Function AllocateAndGetTcpExTableFromStack Lib "iphlpapi.dll" (ByRef pTcpTable As Any, _
                                                                               ByRef bOrder As Boolean, _
                                                                               ByVal heap As Long, _
                                                                               ByVal zero As Long, _
                                                                               ByVal flags As Long) As Long
Private Declare Function AllocateAndGetUdpExTableFromStack Lib "iphlpapi.dll" (ByRef pTcpTable As Any, _
                                                                               ByRef bOrder As Boolean, _
                                                                               ByVal heap As Long, _
                                                                               ByVal zero As Long, _
                                                                               ByVal flags As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (Destination As Any, _
                                                                         Source As Any, _
                                                                         ByVal Length As Long)
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long
Private Declare Function HeapFree Lib "kernel32" (ByVal hHeap As Long, _
                                                  ByVal dwFlags As Long, _
                                                  lpMem As Any) As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, _
                                                     ByVal bInheritHandle As Long, _
                                                     ByVal dwProcessId As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Public Declare Function GetProcessHeap Lib "kernel32.dll" () As Long
Private Declare Function GetModuleBaseName Lib "psapi.dll" Alias "GetModuleBaseNameA" (ByVal hProcess As Long, _
                                                                                       ByVal hModule As Long, _
                                                                                       ByVal lpFileName As String, _
                                                                                       ByVal nSize As Long) As Long
Private Declare Function EnumProcessModules Lib "psapi.dll" (ByVal hProcess As Long, _
                                                             lphModule As Long, _
                                                             ByVal cb As Long, _
                                                             lpcbNeeded As Long) As Long
Private Declare Function GetModuleFileNameExA Lib "psapi.dll" (ByVal hProcess As Long, _
                                                               ByVal hModule As Long, _
                                                               ByVal lpFileName As String, _
                                                               ByVal nSize As Long) As Long
Private Function GetIpString(ByVal Value As Long) As String
Dim table(3) As Byte
    CopyMemory table(0), Value, 4
    GetIpString = table(0) & "." & table(1) & "." & table(2) & "." & table(3)
End Function
Private Function GetPortNumber(ByVal Value As Long) As Long
    GetPortNumber = (Value / 256) + (Value Mod 256) * 256
End Function
Private Function GetProcessName(ByVal ProcessID As Long) As String
Dim strName  As String * 1024
Dim hProcess As Long
Dim cbNeeded As Long
Dim hMod     As Long
    Select Case ProcessID
    Case 0
        GetProcessName = "Proccess Inactive"
    Case 4
        GetProcessName = "System"
    Case Else
        GetProcessName = "Unknown"
    End Select
    hProcess = OpenProcess(PROCESS_QUERY_INFORMATION Or PROCESS_VM_READ, 0, ProcessID)
    If hProcess Then
        If EnumProcessModules(hProcess, hMod, Len(hMod), cbNeeded) Then
            GetModuleBaseName hProcess, hMod, strName, Len(strName)
            GetProcessName = Left$(strName, lstrlen(strName))
        End If
        CloseHandle hProcess
    End If
End Function
Private Function GetState(ByVal Value As Long) As String
    Select Case Value
    Case MIB_TCP_STATE_ESTAB
        GetState = "ESTABLISH"
    Case MIB_TCP_STATE_CLOSED
        GetState = "CLOSED"
    Case MIB_TCP_STATE_LISTEN
        GetState = "LISTEN"
    Case MIB_TCP_STATE_CLOSING
        GetState = "CLOSING"
    Case MIB_TCP_STATE_LAST_ACK
        GetState = "LAST_ACK"
    Case MIB_TCP_STATE_SYN_SENT
        GetState = "SYN_SENT"
    Case MIB_TCP_STATE_SYN_RCVD
        GetState = "SYN_RCVD"
    Case MIB_TCP_STATE_FIN_WAIT1
        GetState = "FIN_WAIT1"
    Case MIB_TCP_STATE_FIN_WAIT2
        GetState = "FIN_WAIT2"
    Case MIB_TCP_STATE_TIME_WAIT
        GetState = "TIME_WAIT"
    Case MIB_TCP_STATE_CLOSE_WAIT
        GetState = "CLOSE_WAIT"
    Case MIB_TCP_STATE_DELETE_TCB
        GetState = "DELETE_TCB"
    End Select
End Function
Public Sub OnRefresh()
Dim TcpExTable() As PMIB_TCPEXROW
Dim UdpExTable() As PMIB_UDPEXROW
Dim Pointer      As Long
Dim Number       As Long
Dim Size         As Long
Dim i            As Long
Dim tmp(9, 1000) As String
Dim flags        As Long
Dim result       As Boolean
    On Error Resume Next
' Check to see if connected to the internet
' (Don't Get Net Stats If not to keep system processes as low as possible.)
    result = InternetGetConnectedState(flags, 0)
    If result Then
' Connected to the Internet
    Else
' Not Connected to the Internet
' Clear User Stats
        With frmMain
            .lblIncoming = 0
            .lblOutgoing = 0
            .lblBlocked = 0
            .lvFirewall.ListItems.Clear
        End With
        Exit Sub
    End If
    On Error GoTo 0
    frmMain.lsvListView2.ListItems.Clear
    DoEvents
'for TCP
    On Error Resume Next
    If AllocateAndGetTcpExTableFromStack(Pointer, True, mheap, 2, 2) = 0 Then
        CopyMemory Number, ByVal Pointer, 4
        If Number Then
            ReDim TcpExTable(Number - 1) As PMIB_TCPEXROW
            Size = Number * Len(TcpExTable(0))
            CopyMemory TcpExTable(0), ByVal Pointer + 4, Size
            For i = 0 To UBound(TcpExTable)
                tmp(0, i) = "TCP"
                tmp(1, i) = GetIpString(TcpExTable(i).dwLocalAddr)
                tmp(2, i) = GetPortNumber(TcpExTable(i).dwLocalPort)
                If GetIpString(TcpExTable(i).dwRemoteAddr) = "0.0.0.0" Then
                    tmp(3, i) = ""
                    tmp(4, i) = ""
                    tmp(5, i) = ""
                Else
                    With TcpExTable(i)
                        tmp(3, i) = GetIpString(.dwRemoteAddr)
                        tmp(4, i) = "" 'ResolveHostname(GetIpString(.dwRemoteAddr))
                        tmp(5, i) = GetPortNumber(.dwRemotePort)
                    End With 'TcpExTable(i)
                End If
                With TcpExTable(i)
                    tmp(6, i) = GetState(.dwStats)
                    tmp(7, i) = .dwProcessId
                    tmp(8, i) = GetProcessName(.dwProcessId)
                    tmp(9, i) = ProcessPathByPID(.dwProcessId)
                End With 'TcpExTable(i)
            Next i
        End If
        HeapFree mheap, 0, ByVal Pointer
        For i = 0 To UBound(TcpExTable)
            With frmMain.lsvListView2.ListItems.Add
                .Text = tmp(0, i)
                .SubItems(1) = tmp(1, i)
                .SubItems(2) = tmp(2, i)
                .SubItems(3) = tmp(3, i)
                .SubItems(4) = tmp(4, i)
                .SubItems(5) = tmp(5, i)
                .SubItems(6) = tmp(6, i)
                .SubItems(7) = tmp(7, i)
                .SubItems(8) = tmp(8, i)
                .SubItems(9) = tmp(9, i)
            End With
        Next i
    End If
'For UDP
    If AllocateAndGetUdpExTableFromStack(Pointer, True, mheap, 2, 2) = 0 Then
        CopyMemory Number, ByVal Pointer, 4
        If Number Then
            ReDim UdpExTable(Number - 1) As PMIB_UDPEXROW
            Size = Number * Len(UdpExTable(0))
            CopyMemory UdpExTable(0), ByVal Pointer + 4, Size
            For i = 0 To UBound(UdpExTable)
                tmp(0, i) = "UDP"
                tmp(1, i) = GetIpString(UdpExTable(i).dwLocalAddr)
                tmp(2, i) = GetPortNumber(UdpExTable(i).dwLocalPort)
                tmp(3, i) = ""
                tmp(4, i) = ""
                tmp(5, i) = ""
                tmp(6, i) = "LISTEN"
                With UdpExTable(i)
                    tmp(7, i) = .dwProcessId
                    tmp(8, i) = GetProcessName(.dwProcessId)
                    tmp(9, i) = ProcessPathByPID(.dwProcessId)
                End With 'UdpExTable(i)
            Next i
            For i = 0 To UBound(UdpExTable)
                With frmMain.lsvListView2.ListItems.Add
                    .Text = tmp(0, i)
                    .SubItems(1) = tmp(1, i)
                    .SubItems(2) = tmp(2, i)
                    .SubItems(3) = tmp(3, i)
                    .SubItems(4) = tmp(4, i)
                    .SubItems(5) = tmp(5, i)
                    .SubItems(6) = tmp(6, i)
                    .SubItems(7) = tmp(7, i)
                    .SubItems(8) = tmp(8, i)
                    .SubItems(9) = tmp(9, i)
                End With
            Next i
        End If
        HeapFree mheap, 0, ByVal Pointer
    End If
    DoEvents
    On Error GoTo 0
End Sub
Private Function ProcessPathByPID(PID As Long) As String
Dim cbNeeded           As Long
Dim Modules(1 To 2000) As Long
Dim Ret                As Long
Dim ModuleName         As String
Dim nSize              As Long
Dim hProcess           As Long
    hProcess = OpenProcess(PROCESS_QUERY_INFORMATION Or PROCESS_VM_READ, 0, PID)
    If hProcess <> 0 Then
        Ret = EnumProcessModules(hProcess, Modules(1), 20000, cbNeeded)
        If Ret <> 0 Then
            ModuleName = Space$(260)
            nSize = 5000
            Ret = GetModuleFileNameExA(hProcess, Modules(1), ModuleName, nSize)
            ProcessPathByPID = Left$(ModuleName, Ret)
        End If
    End If
    Ret = CloseHandle(hProcess)
    If LenB(ProcessPathByPID) = 0 Then
        ProcessPathByPID = "SYSTEM"
    End If
End Function