VB设计Win2000下截获IP数据包程序

　　 以下是在VB中截获WIN2000下TCP/IP包的源代码，在VB6.0,win2000下测试通过，需要注意的地方是，1.必须和本地的一块网卡,2.每次获取数据后必须有一段延时。3.数据取到之后放在Buff的数组中。4.把以下的代码放在一个模块中就可以了。

''-----------------------------代码开始-------------------------------------------------- Declare Function bind Lib "ws2_32.dll" (ByVal s As Long, addr As SOCK_ADDR, ByVal namelen As Long) As Long Declare Function closesocket Lib "ws2_32.dll" (ByVal s As Long) As Long Declare Function connect Lib "ws2_32.dll" (ByVal s As Long, name As SOCK_ADDR, ByVal namelen As Integer) As Long Declare Function inet_addr Lib "ws2_32.dll" (ByVal cp As String) As Long Declare Function htons Lib "ws2_32.dll" (ByVal hostshort As Integer) As Integer Declare Function recv Lib "ws2_32.dll" (ByVal s As Long, buffer As Any, ByVal length As Long, ByVal flags As Long) As Long Declare Function send Lib "ws2_32.dll" (ByVal s As Long, buffer As Any, ByVal length As Long, ByVal flags As Long) As Long Declare Function shutdown Lib "ws2_32.dll" (ByVal s As Long, ByVal how As Long) As Long Declare Function ioctlsocket Lib "ws2_32.dll" (ByVal s As Long, ByVal v As Long, ut As Long) As Long Declare Function socket Lib "ws2_32.dll" (ByVal af As Long, ByVal type_specification As Long, ByVal protocol As Long) As Long Declare Function WSACancelBlockingCall Lib "ws2_32.dll" () As Long Declare Function WSACleanup Lib "ws2_32.dll" () As Long Declare Function WSAGetLastError Lib "ws2_32.dll" () As Long Declare Function WSAStartup Lib "ws2_32.dll" (ByVal wVersionRequired As Integer, wsData As WSA_DATA) As Long Declare Function WSASocketA Lib "ws2_32.dll" (ByVal af As Long, ByVal type1 As Long, ByVal protocol As Long, lpProtocolInfo As Long, g As Long, ByVal dwFlags As Long) Declare Function WSAIoctl Lib "ws2_32.dll" (ByVal s As Long, ByVal dwIoControlCode As Long, lpvInBuffer As Long, ByVal cbInBuffer As Long, lpvOutBuffer As Long, ByVal cbOutBuffer As Long, lpcbBytesReturned As Long, lpOverlapped As Long, lpCompletionRoutine As Long) As Long Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal length As Long) Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Public Const WSADESCRIPTION_LEN = 256 Public Const WSASYS_STATUS_LEN = 128 Type WSA_DATA 　 wVersion As Integer 　 wHighVersion As Integer 　 strDescription(WSADESCRIPTION_LEN + 1) As Byte 　 strSystemStatus(WSASYS_STATUS_LEN + 1) As Byte 　 iMaxSockets As Integer 　 iMaxUdpDg As Integer 　 lpVendorInfo As Long End Type Type IN_ADDR 　 S_addr As Long End Type Type SOCK_ADDR 　 sin_family As Integer 　 sin_port As Integer 　 sin_addr As IN_ADDR 　 sin_zero(0 To 7) As Byte End Type Type IPHeader 　 lenver As Byte 　 tos As Byte 　 len As Integer 　 ident As Integer 　 flags As Integer 　 ttl As Byte 　 proto As Byte 　 checksum As Integer 　 sourceIP As Long 　 destIP As Long End Type Const AF_INET = 2 Const SOCK_RAW = 3 Const IPPROTO_IP = 0 Const IPPROTO_TCP = 6 Const IPPROTO_UDP = 17 Const MAX_PACK_LEN = 65535 Const SOCKET_ERROR = -1& Private mwsaData As WSA_DATA Private m_hSocket As Long Private msaLocalAddr As SOCK_ADDR Private msaRemoteAddr As SOCK_ADDR Sub Main() 　 Dim nResult As Long 　 nResult = WSAStartup(&H202, mwsaData) 　 If nResult <> WSANOERROR Then 　　 MsgBox "Error en WSAStartup" 　　 Exit Sub 　 End If 　 m_hSocket = socket(AF_INET, SOCK_RAW, IPPROTO_IP) 　 If (m_hSocket = INVALID_SOCKET) Then 　　 MsgBox "Error in socket" 　　 Exit Sub 　 End If 　 msaLocalAddr.sin_family = AF_INET 　 msaLocalAddr.sin_port = 0 　 msaLocalAddr.sin_addr.S_addr = inet_addr("192.168.1.125") ''这里需要你自己的网卡的IP地址 　 nResult = bind(m_hSocket, msaLocalAddr, Len(msaLocalAddr)) 　 If (nResult = SOCKET_ERROR) Then 　　 MsgBox "Error in bind" 　　 Exit Sub 　 End If 　 Dim InParamBuffer As Long 　 Dim BytesRet As Long 　 BytesRet = 0 　 InParamBuffer = 1 　 nResult = ioctlsocket(m_hSocket, &H98000001, 1) 　 If nResult <> 0 Then 　　 MsgBox "ioctlsocket" 　　 Exit Sub 　 End If 　 Dim strData As String 　 Dim nReceived As Long 　 ''截获来的数据放在BUFF里面 　 Dim Buff(0 To MAX_PACK_LEN) As Byte 　 Dim IPH As IPHeader 　 Do Until False ''这个例子里，一直获取 　 DoEvents 　 nResult = recv(m_hSocket, Buff(0), MAX_PACK_LEN, 0) 　 If nResult = SOCKET_ERROR Then 　　 MsgBox "Error in RecvData::recv" 　　 Exit Do 　 End If 　 CopyMemory IPH, Buff(0), Len(IPH) ''为了访问方便 　 Select Case IPH.proto 　　 Case IPPROTO_TCP 　　　 ''frmHookTcpip.Text1.SelText = HexIp2DotIp(IPH.sourceIP) 　　　 ''frmHookTcpip.Text1.SelText = " -----> " 　　　 ''frmHookTcpip.Text1.SelText = HexIp2DotIp(IPH.destIP) 　　　 ''frmHookTcpip.Text1.SelText = vbCrLf 　　　 Debug.Print HexIp2DotIp(IPH.sourceIP) & " -----> " & HexIp2DotIp(IPH.destIP) 　　　 End Select 　　 Loop 　 nResult = shutdown(m_hSocket, 2) 　 nResult = closesocket(m_hSocket) 　 nResult = WSACancelBlockingCall 　 nResult = WSACleanup End Sub Function HexIp2DotIp(ByVal ip As Long) As String 　 Dim s As String, p1 As String, p2 As String, p3 As String, p4 As String 　 s = Right("00000000" & Hex(ip), 8) 　 p1 = Val("&h" & Mid(s, 1, 2)) 　 p2 = Val("&h" & Mid(s, 3, 2)) 　 p3 = Val("&h" & Mid(s, 5, 2)) 　 p4 = Val("&h" & Mid(s, 7, 2)) 　 HexIp2DotIp = p4 & "." & p3 & "." & p2 & "." & p1 　 End Function ''-----------------------------代码结束--------------------------------------------------