使用VB截獲WIN98系列下的IP數據包

作者:jyu1221(天同)
QQ：19632995          
MSN：jyu1221@hotmail.com

        因廣大VB愛好者開發捕獲IP數據包的需要，我花了一個下午的工夫，終于把它整里出來了，由于時間關系，以下的數據分析部分寫的不是很詳細。以下代碼在WIN98+VB6.0上測試通過，主函數部分比較簡單，1。打開設備驅動程序，2。綁定網卡，3。設置捕獲數據，4。循環截獲IP包。
由于在WIN98下捕獲IP數據包，必須要使用VXD技術，它不像WIN2000（可以參照前二天寫的，“使用VB捕獲WIN2000下的IP數據包”），捕獲IP數據包不需要VXD文件，單單只要使用VB就可以了。因為編寫VXD的步驟比較麻煩，在以下的源代碼中，直接使用IPMAN中的VPACKET.VXD這個驅動程序?？梢栽诰W上比較容易得到，需要的朋友也可以跟我聯系。以下包含了截獲數據包的所有源代碼，只要把下面的代碼放到一個模塊（.BAS）文件中就可以了，里面信息截獲到以后，并沒有對數據做太多的處理，所有的數據都放在OutBuff數組中，只是簡單的分離出了以太網頭部m_EtherPacketHead，IP包頭部m_IPPacketHead，其中程序中只是簡單的輸出了源IP地址，目的IP地址，需要更進一不分析里面的內容，可以參照別的資料。在這里為了程序盡量的簡單，所以不過多的牽涉。進一步分析的內容可以添加到輸出內容的附近代碼就可以了。



'--------源代碼開始，放到.bas中即可以測試----------

Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAclearcase/" target="_blank" >ccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As Long, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function CreateEvent Lib "kernel32" Alias "CreateEventA" (ByVal lpEventAttributes As Long, ByVal bManualReset As Long, ByVal bInitialState As Long, ByVal lpName As String) As Long
Private Declare Function WaitForMultipleObjectsEx Lib "kernel32" (ByVal nCount As Long, lpHandles As Long, ByVal bWaitAll As Long, ByVal dwMilliseconds As Long, ByVal bAlertable As Long) As Long
Private Const INFINITE = &HFFFF

Private Const GENERIC_WRITE = &H40000000
Private Const GENERIC_READ = &H80000000
Private Const OPEN_EXISTING = 3
Private Const FILE_ATTRIBUTE_NORMAL = &H80
Private Const FILE_FLAG_OVERLAPPED = &H40000000
Private Const FILE_FLAG_DELETE_ON_CLOSE = &H4000000
Private Const ERROR_IO_INCOMPLETE = 996&
Private Const NDIS_PACKET_TYPE_DIRECTED = &H1
Private Const IOCTL_PROTOCOL_SET_OID = &H80000004

Private Const IOCTL_PROTOCOL_READ = &H80000010
Private Const OID_GEN_CURRENT_PACKET_FILTER = &H1010E

Private Const WAIT_FAILED = -1
Private Type OVERLAPPED
        Internal As Long
        InternalHigh As Long
        offset As Long
        OffsetHigh As Long
        hEvent As Long
End Type

Type EtherAddr
     AddrByte1  As Byte
     AddrByte2  As Byte
     AddrByte3  As Byte
     AddrByte4  As Byte
     AddrByte5  As Byte
     AddrByte6  As Byte
End Type

Type EtherPacketHead
    DestEther As EtherAddr
    SourEther As EtherAddr
    ServType  As Integer
End Type


Type IPAddr
        AddrByte(0 To 3) As Byte
End Type

Type IPPacketHead
    VerHLen As Byte
    Type1 As Byte
    TtlLen As Integer
    Id As Integer
    FlgOff As Integer
    TTL As Byte
    Proto As Byte
    ChkSum As Integer
    SourIP As IPAddr
    DestIP As IPAddr
End Type

Type PACKET_OID_DATA
    Oid As Long
    Length As Long
    data As Byte
End Type

Private Declare Function DeviceIoControlAsString Lib "kernel32" Alias "DeviceIoControl" (ByVal hDevice As Long, ByVal dwIoControlCode As Long, ByVal lpInBuffer As String, ByVal nInBufferSize As Long, ByVal lpOutBuffer As String, ByVal nOutBufferSize As Long, lpBytesReturned As Long, lpOverlapped As OVERLAPPED) As Long
Private Declare Function DeviceIoControl Lib "kernel32" (ByVal hDevice As Long, ByVal dwIoControlCode As Long, lpInBuffer As Any, ByVal nInBufferSize As Long, lpOutBuffer As Any, ByVal nOutBufferSize As Long, lpBytesReturned As Long, lpOverlapped As OVERLAPPED) As Long
Private Declare Function GetOverlappedResult Lib "kernel32" (ByVal hFile As Long, lpOverlapped As OVERLAPPED, lpNumberOfBytesTransferred As Long, ByVal bWait As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Sub ZeroMemory Lib "kernel32" Alias "RtlZeroMemory" (ByVal dest As Long, ByVal numbytes As Long)


Private Declare Function GetLastError Lib "kernel32" () As Long


Const ETHER_PROTO_IP = &H8
Const IP_PROTO_TCP = &H6

Const ETHER_HEAD_LEN = 14
Const IP_HEAD_BYTE_LEN = 20
Dim bFirst As Boolean
Const SYSERR = -1
Const BUFFER_SIZE = 16384
Const nREAD = 1

Type PacketTable
    hEvent As Long
    Active As Boolean
    Overlap As OVERLAPPED
    Size As Long
    Buffer(BUFFER_SIZE) As Byte
    Length  As Long
    Type As Integer
End Type

Const RECV_MAX = 32

Dim RecvTab(RECV_MAX) As PacketTable
Dim EventTab(RECV_MAX) As Long


Dim InBuff(1514) As Byte
Dim OutBuff(1514) As Byte



Function Bind(hVxD As Long, inBuffer As String) As Boolean

    Dim hEvent   As Long
    Dim cbRet    As Long
    Dim ovlp  As OVERLAPPED
    
    Dim result As Long
    Dim cbIn As Long
    cbIn = 5
    
    hEvent = CreateEvent(0, 1, 0, vbNullString)
    If hEvent = 0 Then
        Bind = False
        MsgBox "err bind"
        Exit Function
     End If

    ovlp.hEvent = hEvent

'((0x8000) << 16) | ((0) << 14) | ((7) << 2) | (0))
Const IOCTL_PROTOCOL_BIND = &H8000001C
    result = DeviceIoControlAsString(hVxD, _
                             IOCTL_PROTOCOL_BIND, _
                            ByVal inBuffer, _
                             cbIn, _
                             ByVal inBuffer, _
                             cbIn, _
                             cbRet, _
                             ovlp)

    If (result = 0) Then
        Call GetOverlappedResult(hVxD, ovlp, cbRet, True)
    End If
    
    Call CloseHandle(hEvent)
    Bind = True
End Function


Function QueryPacket(ByVal hVxD As Long, ByVal ioctl As Long, ByVal cbIn As Long, ByVal cbOut As Long) As Long
    Dim hEvent  As Long
    Dim cbRet As Long
    Dim ovlp  As OVERLAPPED
    Dim result As Long
   
    hEvent = CreateEvent(0, 1, 0, vbNullString)
    If hEvent = 0 Then
        QueryPacket = False
        MsgBox "err bind"
        Exit Function
     End If
   
   ovlp.Internal = 0
   ovlp.InternalHigh = 0
   ovlp.offset = 0
   ovlp.OffsetHigh = 0
   ovlp.hEvent = hEvent
    
'    ioc = &H80000018
    result = DeviceIoControl(hVxD, ioctl, InBuff(0), cbIn, InBuff(0), cbOut, cbRet, ovlp)
    If result = 0 Then
        If (GetLastError() = ERROR_IO_PENDING) Then
             MsgBox "Ok0"
        Else
            Call CloseHandle(hEvent)
            Exit Function
        End If
        If (0 = GetOverlappedResult(hVxD, ovlp, cbRet, 0)) Then
            If (GetLastError() = ERROR_IO_INCOMPLETE) Then
                MsgBox "ok2"
            Else
                Call CloseHandle(hEvent)
                Exit Function
            End If
        End If
        
        result = GetOverlappedResult(hVxD, ovlp, cbRet, 1)
    End If

    QueryPacket = cbRet
End Function



Function QueryOid(hVxD As Long, ulOid As Long, ulLength As Long) As Long
    Dim cbIn  As Long
    cbIn = 14 + ulLength
    Dim cbRet As Long
    Dim OidData As PACKET_OID_DATA
    OidData.Oid = ulOid
    OidData.Length = ulLength
    OidData.data = 0
    
    Dim ioctl As Long
    Const OID_802_3_PERMANENT_ADDRESS = &H1010101
    Const IOCTL_PROTOCOL_QUERY_OID = &H80000000
    Const IOCTL_PROTOCOL_STATISTICS = &H80000008
    
    If ulOid >= OID_802_3_PERMANENT_ADDRESS Then
        ioctl = IOCTL_PROTOCOL_QUERY_OID
    Else
        ioctl = IOCTL_PROTOCOL_STATISTICS
    End If
    
    Call CopyMemory(InBuff(0), OidData, cbIn)
    cbRet = QueryPacket(hVxD, ioctl, cbIn, cbIn)
    
    QueryOid = cbRet
End Function


Function GetHardEtherAddr(ByVal hVxD As Long, petheraddr As EtherAddr) As Boolean
    Dim nret As Long
    Const OID_802_3_CURRENT_ADDRESS = &H1010102
    nret = QueryOid(hVxD, OID_802_3_CURRENT_ADDRESS, 6)
    If (nret > 0) Then
        Call CopyMemory(petheraddr, InBuff(8), 6)
        GetHardEtherAddr = True
    Else
        GetHardEtherAddr = False
    End If
    
End Function


Function SetOid(ByVal hVxD As Long, ByVal ulOid As Long, ByVal ulLength As Long, ByVal data As Long) As Long
    Dim cbIn  As Long
    Dim cbRet As Long
    Dim OidData As PACKET_OID_DATA
    Dim ioctl As Long
    
    cbIn = 32
    
    If (ulOid = OID_GEN_CURRENT_PACKET_FILTER) Then ioctl = IOCTL_PROTOCOL_SET_OID
    
    
    OidData.Oid = ulOid
    OidData.Length = ulLength
    OidData.data = 1
    CopyMemory InBuff(0), OidData, cbIn
    
    cbRet = QueryPacket(hVxD, ioctl, cbIn, cbIn)
    SetOid = 0
End Function


Function GetPacket(ByVal hVxD As Long, ByVal ioctl As Long, ByVal cbIn As Long, ByVal cbOut As Long) As Long
    Dim hEvent  As Long
    Dim cbRet    As Long
    Dim ovlp As OVERLAPPED
    Dim result As Long
    hEvent = CreateEvent(0, 1, 0, vbNullString)
    If hEvent = 0 Then
        GetPacket = 0
        Exit Function
    End If
    
    ovlp.hEvent = hEvent
    
    result = DeviceIoControl(hVxD, ioctl, InBuff(0), cbIn, OutBuff(0), cbOut, cbRet, ovlp)
    If (result = 0) Then Call GetOverlappedResult(hVxD, ovlp, cbRet, True)

    GetPacket = cbRet
End Function


Function RecvPacket(ByVal hVxD As Long, ByVal pbuf As Variant) As Long
    Dim hEvent As Long
    Dim I As Long, J As Long, K As Long
    Dim len1 As Long

    If (bFirst) Then
        For I = 0 To RECV_MAX - 1
            hEvent = CreateEvent(0, 1, 0, vbNullString)
            If (hEvent = 0) Then
                MsgBox "ERROR"
                RecvPacket = SYSERR
                Exit Function
            End If
            RecvTab(I).hEvent = hEvent
            RecvTab(I).Size = BUFFER_SIZE
            RecvTab(I).Active = True
            RecvTab(I).Type = nREAD
            EventTab(I) = hEvent
            Call RecvStart(hVxD, RecvTab(I))
        Next
        bFirst = False
    End If
    
    I = WaitForMultipleObjectsEx(RECV_MAX, EventTab(0), 0, INFINITE, 0)
    If (I = WAIT_FAILED) Then
        MsgBox "error WaitForMultipleObjectsEx"
        RecvPacket = SYSERR
        Exit Function
    End If
    For J = 0 To RECV_MAX - 1
        If (EventTab(I) = RecvTab(J).hEvent) Then Exit For
    Next
    K = J
    If (RecvTab(K).Type = nREAD And RecvTab(K).Active = True) Then
        Call GetOverlappedResult(hVxD, RecvTab(K).Overlap, RecvTab(K).Length, 0)
        If (RecvTab(K).Length > BUFFER_SIZE) Then RecvTab(K).Length = BUFFER_SIZE
        Call CopyMemory(OutBuff(0), RecvTab(K).Buffer(0), RecvTab(K).Length)
        len1 = RecvTab(K).Length
        Call CloseHandle(RecvTab(K).hEvent)
        For J = I + 1 To RECV_MAX - 1
            EventTab(I) = EventTab(J)
            I = I + 1
        Next
        hEvent = CreateEvent(0, 1, 0, vbNullString)
        If (hEvent = 0) Then
            MsgBox "ERROR CREATEEVENT"
            RecvPacket = SYSERR
            Exit Function
        End If
        RecvTab(K).hEvent = hEvent
        'memset(RecvTab[k].Buffer,0,BUFFER_SIZE);
        RecvTab(K).Size = BUFFER_SIZE
        RecvTab(K).Active = True
        RecvTab(K).Type = nREAD
        EventTab(RECV_MAX - 1) = hEvent
        Call RecvStart(hVxD, RecvTab(K))
        RecvPacket = len1
        Exit Function
    Else
        RecvPacket = SYSERR
    End If
End Function


Function RecvStart(ByVal hVxD As Long, packtab As PacketTable) As Long
    Dim result As Long
    packtab.Overlap.Internal = 0
    packtab.Overlap.InternalHigh = 0
    packtab.Overlap.offset = 0
    packtab.Overlap.OffsetHigh = 0
    packtab.Overlap.hEvent = packtab.hEvent

    result = DeviceIoControl(hVxD, _
                           IOCTL_PROTOCOL_READ, _
                           packtab.Buffer(0), _
                           packtab.Size, _
                           packtab.Buffer(0), _
                           packtab.Size, _
                           packtab.Length, _
                           packtab.Overlap)

    If (result <> 0) Then
        RecvStart = SYSERR
    Else
        RecvStart = 0
    End If
End Function


Sub Main()
bFirst = True
Dim hVxD As Long
Dim m_EtherPacketHead As EtherPacketHead
Dim m_IPPacketHead As IPPacketHead

Dim m_EtherAddr As EtherAddr
    hVxD = CreateFile("\\.\VPACKET.VXD", _
                      GENERIC_READ Or GENERIC_WRITE, _
                      0, _
                      0, _
                      OPEN_EXISTING, _
                      FILE_ATTRIBUTE_NORMAL Or _
                      FILE_FLAG_OVERLAPPED Or _
                      FILE_FLAG_DELETE_ON_CLOSE, _
                      0)
Bind hVxD, "0001"
Call GetHardEtherAddr(hVxD, m_EtherAddr)
SetOid hVxD, OID_GEN_CURRENT_PACKET_FILTER, 4, NDIS_PACKET_TYPE_DIRECTED
Do Until False
     DoEvents
     'result = GetPacket(hVxD, IOCTL_PROTOCOL_READ, 1514, 1514)
     result = RecvPacket(hVxD, OutBuff)
     If result = 0 Then Exit Do
     If result <> SYSERR Then
        Call CopyMemory(m_EtherPacketHead, OutBuff(0), ETHER_HEAD_LEN)
        If m_EtherPacketHead.ServType = ETHER_PROTO_IP Then
            Call CopyMemory(m_IPPacketHead, OutBuff(ETHER_HEAD_LEN), IP_HEAD_BYTE_LEN)
            If m_IPPacketHead.Proto = IP_PROTO_TCP Then
                Debug.Print "SourIP:", m_IPPacketHead.SourIP.AddrByte(0) & "." & m_IPPacketHead.SourIP.AddrByte(1) & "." & m_IPPacketHead.SourIP.AddrByte(2) & "." & m_IPPacketHead.SourIP.AddrByte(3)
                Debug.Print "DestIP:", m_IPPacketHead.DestIP.AddrByte(0) & "." & m_IPPacketHead.DestIP.AddrByte(1) & "." & m_IPPacketHead.DestIP.AddrByte(2) & "." & m_IPPacketHead.DestIP.AddrByte(3)
            End If
        End If
     End If
Loop
Call CloseHandle(hVxD)
End Sub

'----------------------源代碼結束-----------------

原文轉自：http://www.anti-gravitydesign.com