使用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这个驱动程序。可以在网上比较容易得到，需要的朋友也可以跟我联系。以下包含了截获数据包的所有源代码，只要把下面的代码放到一个模块（.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 dwDesiredAccess 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

'----------------------源代码结束-----------------