frmtest.frm

Visual Basic实现抓取IP包数据包的控件及实例源代码.

                        And PackData(26) = TCPSeq(2) And PackData(27) = TCPSeq(3) Then Exit Sub  '通过TCP序列号，检测TCP的重发包
                    CatchX1.DataCopy TCPSeq(0), PackData(24), 4     '临时保存本数据包的TCP序列号
                    LblByte.Caption = PackIndx(1, RecNum)
                    RecNum = RecNum + 1
                    LblRecNum.Caption = RecNum
                    
                End If
            End If
        ElseIf (RIP = 0 Or RIP = a.sourceIP) And (LIP = 0 Or LIP = a.destIP) Then
            If (RPort = 0 Or RPort = TmpSPort) And (LPort = 0 Or LPort = TmpDPort) Then
                If (DRPort = 0 Or DRPort <> TmpSPort) And (DLPort = 0 Or DLPort <> TmpDPort) Then
                    '数据包的目的地址(DESTINATION)符合过滤条件
                    If RecNum > 0 Then
                        PackIndx(0, RecNum) = Timer
                        PackIndx(1, RecNum) = PackIndx(1, RecNum - 1) + PackLen
                        CatchX1.DataCopy PackD(PackIndx(1, RecNum - 1)), PackData(0), PackLen
                    Else
                        PackIndx(0, RecNum) = Timer
                        PackIndx(1, RecNum) = PackLen
                        CatchX1.DataCopy PackD(0), PackData(0), PackLen
                    End If
                    '检查是否为重复收到的数据包
                    If PackData(9) = ipproto_tcp And PackData(24) = TCPSeq(0) And PackData(25) = TCPSeq(1) _
                        And PackData(26) = TCPSeq(2) And PackData(27) = TCPSeq(3) Then Exit Sub  '通过TCP序列号，检测TCP的重发包
                    CatchX1.DataCopy TCPSeq(0), PackData(24), 4     '临时保存本数据包的TCP序列号
                    LblByte.Caption = PackIndx(1, RecNum)
                    RecNum = RecNum + 1
                    LblRecNum.Caption = RecNum
                End If
            End If
        End If
        
        
        
        
        
        
    End If

End Sub

Private Sub Command1_Click()
    Command1.Enabled = False
    Command2.Enabled = True
    List1.Clear
    Text0.Text = ""
    Text1.Text = ""
    Text2.Text = ""
    LblRecNum.Caption = 0
    RecNum = 0
    LIP = IPLong(TxtLIP.Text)
    RIP = IPLong(TxtRIP.Text)
    LPort = Val(TxtLPort.Text)
    RPort = Val(TxtRPort.Text)
    DLPort = Val(TxtDLPort.Text)
    DRPort = Val(TxtDRPort.Text)
    CatchX1.CatchIP = TxtLIP.Text
    CatchX1.Begin = True
End Sub

Private Sub Command2_Click()
    Command2.Enabled = False
    Command1.Enabled = True
    CatchX1.Begin = False
Dim i As Integer, DataLen As Long, TmpStr As String, TmpSPort As Long, TmpDPort As Long
    
    For i = 0 To RecNum - 1
        If i = 0 Then
            CatchX1.DataCopy TmpPack(0), PackD(0), CLng(PackIndx(1, 0))
        Else
            CatchX1.DataCopy TmpPack(0), PackD(PackIndx(1, i - 1)), CLng(PackIndx(1, i) - PackIndx(1, i - 1))
        
        End If
        
        TmpSPort = TmpPack(20) * 256& + TmpPack(21)
        TmpDPort = TmpPack(22) * 256& + TmpPack(23)
        CatchX1.GetIPHeader a, TmpPack
        If (LIP = 0 Or LIP = a.sourceIP) And (RIP = 0 Or RIP = a.destIP) Then
            If (LPort = 0 Or LPort = TmpSPort) And (RPort = 0 Or RPort = TmpDPort) Then
                If (DLPort = 0 Or DLPort <> TmpSPort) And (DRPort = 0 Or DRPort <> TmpDPort) Then
                    '源地址(SOUCE)符合过滤条件
                    If Option2 Then
                        DataLen = TmpPack(2) * 256& + TmpPack(3)
                    Else
                        DataLen = CatchX1.GetDataLen(TmpPack)
                    End If
                    Select Case TmpPack(9)
                    Case ipproto_tcp
                        Prot = "TCP  "
                    Case ipproto_udp
                        Prot = "UDP  "
                    Case ipproto_icmp
                        Prot = "ICMP "
                    Case Else
                        Prot = "OTHER"
                    End Select
                    TmpStr = Left(List1.ListCount + 1 & ")   ", 5)
                    TmpStr = TmpStr & Left(CatchX1.GetIpStr(a.sourceIP) & "(" & TmpSPort & ")" & Space(13), 23) & "→ "
                    TmpStr = TmpStr & Left(CatchX1.GetIpStr(a.destIP) & "(" & TmpDPort & ")" & Space(13), 23) & Prot & "  LEN=" & DataLen
                    List1.AddItem TmpStr
                    List1.ItemData(List1.NewIndex) = i
                End If
            End If
        ElseIf (RIP = 0 Or RIP = a.sourceIP) And (LIP = 0 Or LIP = a.destIP) Then
            If (RPort = 0 Or RPort = TmpSPort) And (LPort = 0 Or LPort = TmpDPort) Then
                If (DRPort = 0 Or DRPort <> TmpSPort) And (DLPort = 0 Or DLPort <> TmpDPort) Then
                    If Option2 Then
                        DataLen = TmpPack(2) * 256& + TmpPack(3)
                    Else
                        DataLen = CatchX1.GetDataLen(TmpPack)
                    End If
                    Select Case TmpPack(9)
                    Case ipproto_tcp
                        Prot = "TCP  "
                    Case ipproto_udp
                        Prot = "UDP  "
                    Case ipproto_icmp
                        Prot = "ICMP "
                    Case Else
                        Prot = "OTHER"
                    End Select
                    TmpStr = Left(List1.ListCount + 1 & ")   ", 5)
                    TmpStr = TmpStr & Left(CatchX1.GetIpStr(a.destIP) & "(" & TmpDPort & ")" & Space(13), 23) & "← "
                    TmpStr = TmpStr & Left(CatchX1.GetIpStr(a.sourceIP) & "(" & TmpSPort & ")" & Space(13), 23) & Prot & "  LEN=" & DataLen
                    List1.AddItem TmpStr
                    List1.ItemData(List1.NewIndex) = i
                End If
            End If
        End If
    Next i
    If RecNum > 0 Then List1.Selected(0) = True
End Sub

Private Sub Form_Load()
    CatchX1.Mode = 0
    TxtLIP.Text = CatchX1.LocalIP
    CatchX1.CatchIP = TxtLIP.Text
    LIP = IPLong(TxtLIP.Text)
'    Text1.Text = Text1.Text & CatchX1.CatchIP & vbCrLf
End Sub

Private Sub LblEdt_Click()
    LblEdt.BorderStyle = 1
    If List1.ListCount < 1 Then
        MnuCopy.Enabled = False
        MnuAll.Enabled = False
    Else
        MnuAll.Enabled = True
        If List1.ListIndex < 0 Then
            MnuCopy.Enabled = False
        Else
            MnuCopy.Enabled = True
        End If
    End If
    PopupMenu MnuEdit, , LblEdt.Left, LblEdt.Top + LblEdt.Height
    LblEdt.BorderStyle = 0
End Sub

Private Sub LblFile_Click()
    LblFile.BorderStyle = 1
    PopupMenu MnuFile, , LblFile.Left, LblFile.Top + LblFile.Height
    LblFile.BorderStyle = 0
End Sub

Private Sub List1_Click()
Dim i As Long, k As Long, n As Long, line As Integer, HZ0 As Boolean
    Text1.Text = ""
    n = List1.ItemData(List1.ListIndex)
    If n = 0 Then
        k = 0
    Else
        k = PackIndx(1, n - 1)
    End If
    CatchX1.DataCopy TmpPack(0), PackD(k), PackIndx(1, n) - k
    k = PackIndx(1, n) - k
    If Option1.Value Then CatchX1.GetData TmpPack, TmpPack, k
    DataStr0 = "0000"
    DataStr1 = ""
    DataStr2 = DataStr1
    HZ0 = True
    For i = 0 To k - 1
        DataStr1 = DataStr1 & Right("0" & Hex(TmpPack(i)), 2) & " "
        If Option3.Value Then
            If TmpPack(i) < 32 Or TmpPack(i) >= 127 Then
                DataStr2 = DataStr2 & "."
            Else
                DataStr2 = DataStr2 & Chr(TmpPack(i))
            End If
        Else
            If TmpPack(i) < 32 Or (TmpPack(i) >= 127 And TmpPack(i) <= 160) Then
                DataStr2 = DataStr2 & "."
            ElseIf TmpPack(i) < 127 Then
                DataStr2 = DataStr2 & Chr(TmpPack(i))
            ElseIf i < k - 1 And TmpPack(i + 1) > 160 Then
                If HZ0 Then
                    DataStr2 = DataStr2 & Chr(TmpPack(i) * 256& + TmpPack(i + 1) - 65536)
                    HZ0 = False
                Else
                    If (i Mod 16) = 0 Then DataStr2 = DataStr2 & " "
                    HZ0 = True
                End If
            Else
                If HZ0 Then
                    DataStr2 = DataStr2 & "."
                Else
                    If (i Mod 16) = 0 Then DataStr2 = DataStr2 & " "
                    HZ0 = True
                End If
            End If
            
        End If
        If (i Mod 16) = 15 Then
            DataStr0 = DataStr0 & vbCrLf & Right("000" & Hex(i + 1), 4)
            DataStr1 = DataStr1 & vbCrLf
            DataStr2 = DataStr2 & vbCrLf
        End If
    Next i
    VScroll1.Min = 20
    VScroll1.Max = k \ 16 + 1
    VScroll1.Value = VScroll1.Min
    VScroll1_Change

End Sub


Private Function IPLong(IPStr As String) As Long
Dim i0 As Integer, i1 As Integer, b(3) As Byte, d As Double
    On Error GoTo IPEmp
    i0 = 1
    i1 = InStr(i0, IPStr, ".")
    b(0) = Mid(IPStr, i0, i1 - i0)
    i0 = i1 + 1
    i1 = InStr(i0, IPStr, ".")
    b(1) = Mid(IPStr, i0, i1 - i0)
    i0 = i1 + 1
    i1 = InStr(i0, IPStr, ".")
    b(2) = Mid(IPStr, i0, i1 - i0)
    i0 = i1 + 1
    b(3) = Mid(IPStr, i0)
    d = b(3) * 16777216# + b(2) * 65536# + b(1) * 256# + b(0)
    If b(3) > 127 Then
        IPLong = d - 4294967296#
    Else
        IPLong = d
    End If
    Exit Function
IPEmp:
    IPLong = 0
End Function

Private Sub MnuAll_Click()
Dim i As Long, k As Long
    k = List1.ListIndex
    For i = 0 To List1.ListCount - 1
        List1.Selected(i) = True
    Next i
    List1.ListIndex = k
End Sub

Private Sub MnuCopy_Click()
Dim i As Long, j As Long, k As Long, n As Long, TmpStr As String, TmpStr1 As String
    Clipboard.Clear   ' 清除剪贴板。
    TmpStr = ""
    For i = 0 To List1.ListCount - 1
        If List1.Selected(i) Then
           TmpStr = TmpStr & List1.List(i) & vbCrLf
            n = List1.ItemData(i)
            If n = 0 Then
                k = 0
            Else
                k = PackIndx(1, n - 1)
            End If
            CatchX1.DataCopy TmpPack(0), PackD(k), PackIndx(1, n) - k
            k = PackIndx(1, n) - k
            If Option1.Value Then CatchX1.GetData TmpPack, TmpPack, k
            
            For j = 0 To k - 1
                TmpStr = TmpStr & Right("0" & Hex(TmpPack(j)), 2) & " "
                If (j Mod 16) = 15 Then
                    TmpStr = TmpStr & vbCrLf
                End If
            Next j
            If Right(TmpStr, 1) <> vbLf Then TmpStr = TmpStr & vbCrLf
        End If
    Next i
    Clipboard.SetText TmpStr   ' 将正文放置在剪贴板上。

End Sub

Private Sub MnuOpen_Click()
Dim OpenFile As OPENFILENAME
Dim lReturn As Long, FileName As String
Dim Fnum As Integer
Dim i As Long

    OpenFile.lStructSize = Len(OpenFile)
    OpenFile.hwndOwner = Me.hWnd
    OpenFile.hInstance = App.hInstance
    OpenFile.lpstrFilter = "数据包文件 (*.hex)" & Chr(0) & "*.HEX" & Chr(0)
    OpenFile.lpstrDefExt = "hex"
    OpenFile.nFilterIndex = 1
    OpenFile.lpstrFile = String(257, Chr(0))
    OpenFile.nMaxFile = Len(OpenFile.lpstrFile) - 1
    OpenFile.lpstrFileTitle = OpenFile.lpstrFile
    OpenFile.nMaxFileTitle = OpenFile.nMaxFile
    OpenFile.lpstrInitialDir = App.Path
    OpenFile.lpstrTitle = "选择打开数据包文件"
    OpenFile.flags = 0
    lReturn = GetOpenFileName(OpenFile)
    If lReturn <> 0 Then
        FileName = Left(Trim(OpenFile.lpstrFile), InStr(1, Trim(OpenFile.lpstrFile), Chr(0)) - 1)
        On Error GoTo NoFile
        If FileLen(FileName) > 0 Then
            Fnum = FreeFile
            Open FileName For Binary As #Fnum
            Get #Fnum, , RecNum
        
            For i = 0 To RecNum - 1
                Get #Fnum, , PackIndx(1, i)
            Next i
            For i = 0 To PackIndx(1, RecNum - 1) - 1
                Get #Fnum, , PackD(i)
            Next i
            Close Fnum
        Else
            MsgBox "数据包文件：" & FileName & "无数据！"
        End If
    End If
    Command2_Click
    Exit Sub
NoFile:
    MsgBox "数据包文件：" & FileName & "不存在、或读数据出错！"
End Sub

Private Sub MnuSave_Click()
Dim OpenFile As OPENFILENAME
Dim lReturn As Long, FileName As String
Dim Fnum As Integer
Dim i As Long

    If RecNum > 0 Then
        OpenFile.lStructSize = Len(OpenFile)
        OpenFile.hwndOwner = Me.hWnd
        OpenFile.hInstance = App.hInstance
        OpenFile.lpstrFilter = "数据包文件 (*.hex)" & Chr(0) & "*.HEX" & Chr(0)
        OpenFile.lpstrDefExt = "hex"
        OpenFile.nFilterIndex = 1
        OpenFile.lpstrFile = String(257, 0)
        OpenFile.nMaxFile = Len(OpenFile.lpstrFile) - 1
        OpenFile.lpstrFileTitle = OpenFile.lpstrFile
        OpenFile.nMaxFileTitle = OpenFile.nMaxFile
        OpenFile.lpstrInitialDir = App.Path
        OpenFile.lpstrTitle = "选择保存数据包文件"
        OpenFile.flags = 0
        lReturn = GetOpenFileName(OpenFile)
        If lReturn <> 0 Then
'        MsgBox "The user Chose " & Trim(OpenFile.lpstrFile)
            FileName = Left(Trim(OpenFile.lpstrFile), InStr(1, Trim(OpenFile.lpstrFile), Chr(0)) - 1)
            Fnum = FreeFile
            Open FileName For Binary As #Fnum
            Put #Fnum, , RecNum
            For i = 0 To RecNum - 1
                Put #Fnum, , PackIndx(1, i)
            Next i
            For i = 0 To PackIndx(1, RecNum - 1) - 1
                Put #Fnum, , PackD(i)
            Next i
            Close Fnum
        End If
    
    End If
End Sub

Private Sub MnuExit_Click()
    End
End Sub

Private Sub Option3_Click()
    List1_Click
End Sub

Private Sub Option4_Click()
    List1_Click
End Sub

Private Sub VScroll1_Change()
    If VScroll1.Value < VScroll1.Min Then
        Text0.Text = DataStr0
        Text1.Text = DataStr1
        Text2.Text = DataStr2
    Else
        Text0.Text = Mid(DataStr0, (VScroll1.Value - VScroll1.Min) * 6 + 1)
        Text1.Text = Mid(DataStr1, (VScroll1.Value - VScroll1.Min) * 50 + 1)
        Text2.Text = Mid(DataStr2, (VScroll1.Value - VScroll1.Min) * 18 + 1)
End If
End Sub