frmrcvall.frm

本文件包含三本经典的网络编程书籍 一本是英文的。并附有其中的所有实例源码。 本着来源于网络

    dwProtocol = IPPROTO_IP
    dwInterface = 0
    optIP.Value = True
    
    
    uiSourceAddr = 0
    uiDestAddr = 0
    usSourcePort = 0
    usDestPort = 0
    bFilter = False
    
    Timer1.Enabled = False
    cmdStart.Enabled = True
    cmdStop.Enabled = False
    
    sockAll = INVALID_SOCKET
    
    FillSzIgmpType
    FillSzProto
    
    If TCPIPStartup Then
    Else
        MsgBox "Windows Sockets not initialized. Error: " & Err.LastDllError
    End If
    '
    ' Create an event to use for detecting whether there is IP datagrams
    '  to be read.
    '
    hEvent = WSACreateEvent
    If hEvent = 0 Then
        MsgBox "Failed to create event. Error: " & Err.LastDllError
    End If
    PrintInterfaceList
End Sub

'
' Subroutine: PrintInterfaceList
'
' Description:
'    This routine gets all local IP interfaces. This is necessary because
'    to use the SIO_RCVALLxxx options, you must be bound to an explicit
'    local interface (that is, you cannot bind to INADDR_ANY).
'
Sub PrintInterfaceList()
    Dim s As Long
    Dim dwBytesRet As Long
    Dim ret As Long, i As Long
    Dim slist As SOCKET_ADDRESS_LIST
    Dim Buf As String
    Dim strResult As String
        
    Dim structAddr As sockaddr
    
    Buf = String(1024, 0)
    dwBytesRet = 0
      
    s = WSASocket(AF_INET, SOCK_STREAM, IPPROTO_IP, ByVal 0, 0, WSA_FLAG_OVERLAPPED)
    
    If s = INVALID_SOCKET Then
        MsgBox "WSASocket failed. Error: " & Err.LastDllError & ". App shuts down."
        Exit Sub
    End If
    '
    ' Use SIO_ADDRESS_LIST_QUERY to obtain the local IP interfaces.
    '
    ret = WSAIoctl(s, SIO_ADDRESS_LIST_QUERY, ByVal 0, 0, slist, 1024, dwBytesRet, ByVal 0, ByVal 0)
    
    If ret = SOCKET_ERROR Then
        MsgBox "SIO_ADDRESS_LIST_QUERY failed. Error: " & Err.LastDllError
        Exit Sub
    End If
    '
    ' Parse through the returned structures
    '
    strResult = "Bytes Returned: " & dwBytesRet & " bytes" & vbCrLf
    strResult = strResult & "      Addr Count: " & slist.iAddressCount & vbCrLf
    Debug.Print strResult
    For i = 0 To slist.iAddressCount - 1
        Dim strSockaddr As String
        Dim ptrAddr As Long
        strSockaddr = String(2560, 0)
        ptrAddr = slist.Address(i).lpSockaddr
        CopyMemory structAddr, ByVal ptrAddr, 16
        CopyMemory LocalIPList(i), structAddr, LenB(structAddr)
        lstrcpy1 strSockaddr, inet_ntoa(structAddr.sin_addr)
        strSockaddr = Trim(strSockaddr)
        strResult = "Addr [" & i & "]: " & strSockaddr
        List1.AddItem strResult
    Next i
    
    closesocket s
    
    List1.ListIndex = 0
End Sub

'
' Subroutine: Form_Unload
'
' Description:
'    Unload Winsock.
'
Private Sub Form_Unload(Cancel As Integer)
    TCPIPShutDown
End Sub

'
' Subroutine: List1_Click
'
' Description:
'    This routine is called when the user selects an IP interface.
'
Private Sub List1_Click()
    dwInterface = List1.ListIndex
    Debug.Print dwInterface
End Sub

'
' Subroutine: List1_LostFocus
'
' Description:
'    This routine is called when the IP interface list box loses focus.
'
Private Sub List1_LostFocus()
    dwInterface = List1.ListIndex
    Debug.Print dwInterface
End Sub

'
' Subroutine: optIGMP_Click
'
' Description:
'    This routine is called if the user selects the IGMP capture option.
'    It is possible to filter on all IP traffic, IGMP traffic only, or
'    multicast traffic only.
'
Private Sub optIGMP_Click()
    dwIoControlCode = SIO_RCVALL_IGMPMCAST
    dwProtocol = IPPROTO_IGMP
End Sub

'
' Subroutine: optIP_Click
'
' Description:
'    This routine is called if the user selects the IP capture option.
'    It is possible to filter on all IP traffic, IGMP traffic only, or
'    multicast traffic only.
'

Private Sub optIP_Click()
    dwIoControlCode = SIO_RCVALL
    dwProtocol = IPPROTO_IP
End Sub

'
' Subroutine: optMC_Click
'
' Description:
'    This routine is called if the user selects the multicast capture option.
'    It is possible to filter on all IP traffic, IGMP traffic only, or
'    multicast traffic only.
'

Private Sub optMC_Click()
    dwIoControlCode = SIO_RCVALL_MCAST
    dwProtocol = IPPROTO_IGMP
End Sub

'
' Subroutine: Timer1_Timer
'
' Description:
'    This routine is the timer callback routine. This is triggered whenever
'    the timer expires. It uses WSAEventSelect to check for data to be read.
'    If this is the first call to the timer handler, the raw socket is first
'    created and the appropriate SIO_RCVALLxx ioctl is set.
'
Private Sub Timer1_Timer()
    'We could just create a socket and do blocking read in loop
    'but in VB we don't want to block, so here is the timer hack
    If sockAll = INVALID_SOCKET Then
        sockAll = WSASocket(AF_INET, SOCK_RAW, dwProtocol, ByVal 0, 0, WSA_FLAG_OVERLAPPED)
        If sockAll = INVALID_SOCKET Then
            MsgBox "WSASocket failed. Error: " & Err.LastDllError
            Exit Sub
        End If
        LocalIPList(dwInterface).sin_family = AF_INET
        LocalIPList(dwInterface).sin_port = htons(0)
        '
        ' Have to bind to an explicit IP interface
        '
        dwRet = bind(sockAll, LocalIPList(dwInterface), LenB(LocalIPList(dwInterface)))
        If dwRet = SOCKET_ERROR Then
            MsgBox "bind failed. Error: " & Err.LastDllError
            Exit Sub
        End If
        
        optval = 1
        '
        ' Set the SIO_RCVALLxxx ioctl
        '
        dwRet = WSAIoctl(sockAll, dwIoControlCode, optval, LenB(optval), ByVal 0, 0, dwBytesRet, ByVal 0, 0)
        If dwRet = SOCKET_ERROR Then
            MsgBox "dwIoControlControl failed. Error: " & Err.LastDllError
            Exit Sub
        End If
    End If
    
    ' receive data
    dwRc = WSAEventSelect(sockAll, hEvent, FD_READ)
    If (dwRc = SOCKET_ERROR) Then
        MsgBox "Failed to select event. Error: " & Err.LastDllError
        Exit Sub
    End If
        
    dwRc = WSAWaitForMultipleEvents(1, hEvent, False, 0, False)
       
    Select Case dwRc
    Case WSA_WAIT_TIMEOUT
        Debug.Print "Recv timed out"
        
    Case WSA_WAIT_EVENT_0
        Dim NetworkEvents As WSANETWORKEVENTS
        NetworkEvents.lNetWorkEvents = 0
        dwRet = WSAEnumNetworkEvents(sockAll, hEvent, NetworkEvents)
        If (dwRet = SOCKET_ERROR) Then
            MsgBox "WSAEnumNetworkEvents failed to select event. Error: " & Err.LastDllError
        Else
                        
            'We are only interested in recv
            If (FD_READ And NetworkEvents.lNetWorkEvents) Then
                dwRc = recv(sockAll, RetMsg(0), 65535, 0)
                If dwRc = SOCKET_ERROR Then
                    MsgBox "Couldn't recieve data from remote Socket. Error: " & Err.LastDllError
                Else
                    Debug.Print "recv " & dwRc
                    DecodeIPHeader RetMsg, uiSourceAddr, usSourcePort, uiDestAddr, usDestPort
                End If
            End If
        End If
    
    Case WSA_WAIT_FAILED
        MsgBox "WSAWaitForMultipleEvents failed. Error: " & Err.LastDllError
    Case Else
        MsgBox "Unexpected WSAWaitForMultipleEvents return. Error: " & Err.LastDllError
    End Select
    
    dwRc = WSAEventSelect(sockAll, hEvent, 0)
    If (dwRc = SOCKET_ERROR) Then
        MsgBox "Failed to select event. Error: " & Err.LastDllError
        Exit Sub
    End If

End Sub

'
' Subroutine: txtUiDestAddr_Change
'
' Description:
'    This function sets a flag indicating that a filter has been set.
'
Private Sub txtUiDestAddr_Change()
    bFilter = True
End Sub

'
' Subroutine: txtUiSourceAddr_Change
'
' Description:
'    This function sets a flag indicating that a filter has been set.
'
Private Sub txtuiSourceAddr_Change()
    bFilter = True
End Sub

'
' Subroutine: txtusDestPort_Change
'
' Description:
'    This function sets a flag indicating that a filter has been set.
'
Private Sub txtusDestPort_Change()
    bFilter = True
End Sub

'
' Subroutine: txtusSourcePort_Change
'
' Description:
'    This function sets a flag indicating that a filter has been set.
'
Private Sub txtusSourcePort_Change()
    bFilter = True
End Sub