vbwinsock.bas

功能强大的API

'/------------------Everything below this line should be copied to the Mouse_Up event------------------------/

'    Dim ListAddress As Long
'    Dim ListAddr As Long

     ' Copy Winsock structure to the VisualBasic structure

'    CopyMemory hostent_async.h_name, ByVal PointerToPointer, Len(hostent_async)

'    ListAddress = hostent_async.h_addr_list        ' Get the ListAddress of the Address List

'    CopyMemory ListAddr, ByVal ListAddress, 4      ' Copy Winsock structure to the VisualBasic structure
'    CopyMemory IPLong, ByVal ListAddr, 4           ' Get the first list entry from the Address List
'    CopyMemory Addr, ByVal ListAddr, 4

'    ReceiveWindow.Text = Trim$(CStr(Asc(IPLong.Byte4)) + "." + CStr(Asc(IPLong.Byte3)) _
        + "." + CStr(Asc(IPLong.Byte2)) + "." + CStr(Asc(IPLong.Byte1)))

'/------------------Everything above this line should be copied to the Mouse_Up event------------------------/

    ' After the procedure has been execute, the IP Address will be stored in ReceiveWindow.Text

    ' You may also wish to change the Visible property value of the ReceiveWindow TextBox to False.

    End If

End Function
Function vbWSAAsyncGetHostCNames(hWnd As Long, HostIP As String) As Integer

    Dim lIP As Long
    lIP = vbInet_Addr(HostIP)

    WSAAsyncGetHostByAddr hWnd, &H202, lIP, 4, AF_INET, hostent_async, Len(hostent_async)

End Function
Sub vbWSAGetLastError()

    ' This subroutine gets the last winsock error and returns the results to the user

    Dim lReturn As Long
    Dim vbWinSockMsg As String

    Debug.Print "We are in the vbWSAGetLastError function"

    lReturn = WSAGetLastError()

    Debug.Print "The value returned by the WSAGetLastError subroutine is " & lReturn

    ' This subroutine handles user notifications when a Winsock Error occurs.

    Select Case lReturn

        Case 0
            Exit Sub
        Case WSAEINTR           ' 10004
            vbWinSockMsg = "The (blocking) call was canceled via WSACancelBlockingCall()."
        Case WSAEBADF           ' 10009
            vbWinSockMsg = "No additional information provided."
        Case WSAEACCES          ' 10013
            vbWinSockMsg = "The requested address is a broadcast address, but the appropriate flag was not set."
        Case WSAEFAULT          ' 10014
            vbWinSockMsg = "The length argument is not correct."
        Case WSAEINVAL          ' 10022
            vbWinSockMsg = "One of the specified parameters was invalid."
        Case WSAEMFILE          ' 10024
            vbWinSockMsg = "No more file descriptors are available."
        Case WSAEWOULDBLOCK     ' 10035
            vbWinSockMsg = "The asynchronous operation cannot be scheduled at this time due to resource or other constraints."
        Case WSAEINPROGRESS     ' 10036
            vbWinSockMsg = "A blocking operation is in progress."
        Case WSAEALREADY        ' 10037
            vbWinSockMsg = "The asynchronous routine being canceled has already completed."
        Case WSAENOTSOCK        ' 10038
            vbWinSockMsg = "The descriptor is a file, not a socket."
        Case WSAEDESTADDRREQ    ' 10039
            vbWinSockMsg = "A destination address is required."
        Case WSAEMSGSIZE        ' 10040
            vbWinSockMsg = "The datagram was too large to fit into the specified buffer and was truncated."
        Case WSAEPROTOTYPE      ' 10041
            vbWinSockMsg = "The specified protocol is the wrong type for this socket."
        Case WSAENOPROTOOPT     ' 10042
            vbWinSockMsg = "The option is unknown or unsupported."
        Case WSAEPROTONOSUPPORT ' 10043
            vbWinSockMsg = "The specified protocol is not supported."
        Case WSAESOCKTNOSUPPORT ' 10044
            vbWinSockMsg = "The specified socket type is not supported in this address family."
        Case WSAEOPNOTSUPP      ' 10045
            vbWinSockMsg = "The referenced socket is not a type that supports connection-oriented service."
        Case WSAEPFNOSUPPORT    ' 10046
            vbWinSockMsg = "No additional information is provided."
        Case WSAEPFNOSUPPORT    ' 10047
            vbWinSockMsg = "Addresses in the specified family cannot be used with this socket."
        Case WSAEADDRINUSE      ' 10048
            vbWinSockMsg = "The specified address is already in use."
        Case WSAEADDRNOTAVAIL   ' 10049
            vbWinSockMsg = "The specified address is not available from the local machine."
        Case WSAENETDOWN        ' 10050
            vbWinSockMsg = "The network subsystem has failed."
        Case WSAENETUNREACH     ' 10051
            vbWinSockMsg = "The network cannot be reached from this host at this time."
        Case WSAENETRESET       ' 10052
            vbWinSockMsg = "The connection must be reset because the connection was dropped."
        Case WSAECONNABORTED    ' 10053
            vbWinSockMsg = "The connection was aborted due to timeout or other failure."
        Case WSAECONNRESET      ' 10054
            vbWinSockMsg = "The connection was reset by the remote side."
        Case WSAENOBUFS         ' 10055
            vbWinSockMsg = "No/Insufficient buffer space is available."
        Case WSAEISCONN         ' 10056
            vbWinSockMsg = "The socket is already connected."
        Case WSAENOTCONN        ' 10057
            vbWinSockMsg = "The socket is not connected."
        Case WSAESHUTDOWN       ' 10058
            vbWinSockMsg = "The socket has been shutdown."
        Case WSAETOOMANYREFS    ' 10059
            vbWinSockMsg = "No additional information is provided."
        Case WSAETIMEDOUT       ' 10060
            vbWinSockMsg = "Attempt to connect timed out without establishing a connection."
        Case WSAECONNREFUSED    ' 10061
            vbWinSockMsg = "The attempt to connect was forcefully rejected."
        Case WSAELOOP           ' 10062
            vbWinSockMsg = "No additional information is provided."
        Case WSAENAMETOOLONG    ' 10063
            vbWinSockMsg = "No additional information is provided."
        Case WSAEHOSTDOWN       ' 10064
            vbWinSockMsg = "No additional information is provided."
        Case WSAEHOSTUNREACH    ' 10065
            vbWinSockMsg = "No additional information is provided."
        Case WSASYSNOTREADY     ' 10091
            vbWinSockMsg = "The Network subsystem is unusable."
        Case WSAVERNOTSUPPORTED ' 10092
            vbWinSockMsg = "The TCP/IP Stack on this system will not support this application."
        Case WSANOTINITIALISED  ' 10093
            vbWinSockMsg = "A successful WSAStartup() has not yet occurred."
        Case WSAHOST_NOT_FOUND  ' 11001
            vbWinSockMsg = "Host not found (Authoritative Answer)"
        Case WSATRY_AGAIN       ' 11002
            vbWinSockMsg = "Host not found or SERVERFAIL (Non-Authoritative Answer)"
        Case WSANO_RECOVERY     ' 11003
            vbWinSockMsg = "Non-Recoverable Error."
        Case WSANO_DATA         ' 11004
            vbWinSockMsg = "No data record for the requested host."
        Case Else               ' Any other Winsock Error
            vbWinSockMsg = "Winsock Has Returned Error #" + CStr(lReturn)

    End Select

    MsgBox vbWinSockMsg, vbOKOnly, "Winsock Error #" + CStr(lReturn)

End Sub
Sub vbWSACleanup()

    Dim iReturn As Integer
    Dim sMsg As String

    ' Subroutine to perform WSACleanup

    iReturn = WSACleanUp()

    If iReturn <> 0 Then       ' If WSock32 error, then tell me about it.
        sMsg = "WSock32 Error - " & Trim$(Str$(iReturn)) & " occurred in Cleanup"
        MsgBox sMsg, vbOKOnly, "Winsock Error"
        End
    End If

End Sub
Sub vbWSAStartup()

    ' Subroutine to Initialize WSock32
    
    Dim iReturn As Integer
    Dim sHighByte As String
    Dim sLowByte As String
    Dim sMsg As String
    Dim i As Integer

    ' &H101 is asking for a minimum version of Winsock 1.1


    iReturn = WSAStartup(&H101, WSAData)

    If iReturn <> 0 Then    ' If WSock32 error, then tell me about it
        MsgBox "WSock32.dll is not responding!", vbOKOnly, "Winsock Error"
    End If

    If LoByte(WSAData.wVersion) < WS_VERSION_MAJOR Or _
    (LoByte(WSAData.wVersion) = WS_VERSION_MAJOR _
    And HiByte(WSAData.wVersion) < WS_VERSION_MINOR) Then
        sHighByte = Trim(Str(HiByte(WSAData.wVersion)))
        sLowByte = Trim(Str(LoByte(WSAData.wVersion)))
        sMsg = "WinSock Version " & sLowByte & "." & sHighByte
        sMsg = sMsg & " is not supported "
        MsgBox sMsg, vbOKOnly, "WinSock Error"
        End
    End If

    If WSAData.iMaxSockets < MIN_SOCKETS_REQD Then
        sMsg = "This application requires a minimum of "
        sMsg = sMsg & Trim$(Str$(MIN_SOCKETS_REQD)) & " supported sockets."
        MsgBox sMsg, vbOKOnly, "WinSock Error"
        End
    End If

    MaxSockets = WSAData.iMaxSockets

    '  WSAdata.iMaxSockets is an unsigned short, so we have to convert it to a signed long

    If MaxSockets < 0 Then
        MaxSockets = 65536 + MaxSockets
    End If

    MaxUDP = WSAData.iMaxUdpDg

    If MaxUDP < 0 Then
        MaxUDP = 65536 + MaxUDP
    End If

    '  Process the Winsock Description information

    Description = ""

    For i = 0 To WSADESCRIPTION_LEN
        If WSAData.szDescription(i) = 0 Then Exit For
        Description = Description + Chr$(WSAData.szDescription(i))
    Next i

    '  Process the Winsock Status information

    Status = ""

    For i = 1 To WSASYS_STATUS_LEN
        If WSAData.szSystemStatus(i) = 0 Then
            Exit For
        End If
        Status = Status + Chr$(WSAData.szSystemStatus(i))
    Next i

End Sub
Function LoByte(ByVal wParam As Integer)

    ' This is used to get the LoByte value for the Winsock Version during vbWSAStartup

    LoByte = wParam And &HFF&

End Function
Function vbGetHostByAddress(ByVal sAddress As String) As String
   '此函数的功能是将给定的IP地址转换为用户名

    Dim lAddress As Long
    Dim PointerToMemoryLocation As Long
    Dim HostName As String
    Dim hostent As hostent

    ' Make the function call to winsock inet_addr passing it the IP Address which has been
    ' converted to a long

    lAddress = inet_addr(sAddress)

    ' Get the Pointer Location that Points to the Memory Location where
    ' the Host's Name is stored.

    PointerToMemoryLocation = gethostbyaddr(lAddress, 4, PF_INET)

    If PointerToMemoryLocation <> 0 Then

        ' Copy the contents of the Memory Location to the hostent UDT
        CopyMemory hostent, ByVal PointerToMemoryLocation, Len(hostent)

        ' Create the HostName variable with 256 zeroes.  This makes it so that we can
        ' clip off all of the NULL characters.

        HostName = String(256, 0)

        ' Copy the Contents of the hostent.h_name element of the hostent UDT to the
        ' variable HostName.

        CopyMemory ByVal HostName, ByVal hostent.h_name, 256

        ' Trim the data received from the Memory Location and return the trimmed string
        ' back to the Calling Procedure.

        If HostName = "" Then vbGetHostByAddress = "Unable to Resolve Address"
        
        vbGetHostByAddress = Left(HostName, InStr(HostName, Chr(0)) - 1)

    Else    ' There is no Pointer To A Memory Location, therefore, there isn't a name

        'vbWSAGetLastError

        vbGetHostByAddress = "No DNS Entry"

    End If

End Function
Function HiByte(ByVal wParam As Integer)
'      HiByte = wParam \ &H100 And &HFF& 此语句在VB5中编译后会发生零做除数的错误
       HiByte = wParam / &H100 And &HFF& '此语句可以在VB5中正常运行

End Function
Function vbResolveHost(Host As String) As Long
    '我对此函数进行了修改,使之可以对IP地址和用户名自动识别
    Dim lAddress As Long

    lAddress = vbInet_Addr(Host)

    If lAddress = -1 Then
        '参数Host不是一个IP地址,是用户名,假如此用户名非法,则会发生
        'SOCKET_ERROR
         vbResolveHost = inet_addr(vbGetHostByName(Host))
    Else
          vbResolveHost = lAddress
    End If

End Function