mwinsock2.bas

在Windows下用WinSock API开发的示例

Public Declare Function sendto Lib "ws2_32.dll" (ByVal s As Long, ByRef buf As Byte, ByVal datalen As Long, ByVal Flags As Long, ByRef toaddr As sockaddr_in, ByVal tolen As Long) As Long
Public Declare Function recv Lib "ws2_32.dll" (ByVal s As Long, ByRef buf As Byte, ByVal datalen As Long, ByVal Flags As Long) As Long
Public Declare Function recvfrom Lib "ws2_32.dll" (ByVal s As Long, ByRef buf As Byte, ByVal datalen As Long, ByVal Flags As Long, ByRef fromaddr As sockaddr_in, ByRef fromlen As Long) As Long
'
Public Declare Function shutdown Lib "ws2_32.dll" (ByVal s As Long, ByVal how As Long) As Long
Public Declare Function closesocket Lib "ws2_32.dll" (ByVal s As Long) As Long
'
' I/O model functions.
Public Declare Function WSAAsyncSelect Lib "ws2_32.dll" (ByVal s As Long, ByVal hwnd As Long, ByVal wMsg As Integer, ByVal lEvent As Long) As Long
'
Public Declare Function WSACreateEvent Lib "ws2_32.dll" () As Long
Public Declare Function WSAEventSelect Lib "ws2_32.dll" (ByVal s As Long, ByVal hEventObject As Long, ByVal lNetworkEvents As Long) As Long
Public Declare Function WSAResetEvent Lib "ws2_32.dll" (ByVal hEvent As Long) As Long
Public Declare Function WSASetEvent Lib "ws2_32.dll" (ByVal hEvent As Long) As Long
Public Declare Function WSACloseEvent Lib "ws2_32.dll" (ByVal hEvent As Long) As Long
Public Declare Function WSAWaitForMultipleEvents Lib "ws2_32.dll" (ByVal cEvents As Long, ByRef lphEvents As Long, ByVal fWaitAll As Boolean, ByVal dwTimeout As Long, ByVal fAlertable As Boolean) As Long
Public Declare Function WSAEnumNetworkEvents Lib "ws2_32.dll" (ByVal s As Long, ByVal hEvent As Long, ByRef lpNetworkEvents As WSANETWORKEVENTS) As Long
'
' ICMP functions.
Public Declare Function IcmpCreateFile Lib "icmp.dll" () As Long
Public Declare Function IcmpCloseHandle Lib "icmp.dll" (ByVal HANDLE As Long) As Boolean
Public Declare Function IcmpSendEcho Lib "ICMP" (ByVal IcmpHandle As Long, ByVal DestAddress As Long, ByVal RequestData As String, ByVal RequestSize As Integer, RequestOptns As IP_OPTION_INFORMATION, ReplyBuffer As IP_ECHO_REPLY, ByVal ReplySize As Long, ByVal TimeOut As Long) As Boolean
'
' Other general Win32 APIs.
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
'
' ------------------------------------------------------------------------------
' Helper methods.
' ------------------------------------------------------------------------------
'
Public Function vbGetLastError(Optional lngErrorCode As Long = 0) As String
   '
Dim lngNum As Long
Dim strRet As String
   '
   ' Return a useful description of the last winsock error.
   If (lngErrorCode) Then
      lngNum = lngErrorCode
   Else
      lngNum = WSAGetLastError()
   End If
   '
   Select Case lngNum
      '
      ' Winsock errors.
      Case WSAEINTR
         strRet = "interrupted function call"
      Case WSAEACCES
         strRet = "permission denied"
      Case WSAEFAULT
         strRet = "invalid address"
      Case WSAEINVAL
         strRet = "invalid argument"
      Case WSAEMFILE
         strRet = "too many files open"
      Case WSAEWOULDBLOCK
         strRet = "function call would block"
      Case WSAEINPROGRESS
         strRet = "blocking call already in progress"
      Case WSAEALREADY
         strRet = "operation already in progress"
      Case WSAENOTSOCK
         strRet = "not a valid socket descriptor"
      Case WSAEDESTADDRREQ
         strRet = "destination address required"
      Case WSAEMSGSIZE
         strRet = "message is too long"
      Case WSAEPROTOTYPE
         strRet = "protocol wrong type for socket"
      Case WSAENOPROTOOPT
         strRet = "bad protocol option"
      Case WSAEPROTONOSUPPORT
         strRet = "protocol not supported"
      Case WSAESOCKTNOSUPPORT
         strRet = "socket type not supported"
      Case WSAEOPNOTSUPP
         strRet = "operation not supported"
      Case WSAEPFNOSUPPORT
         strRet = "protocol family not supported"
      Case WSAEAFNOSUPPORT
         strRet = "address family not supported by protocol"
      Case WSAEADDRINUSE
         strRet = "address in use"
      Case WSAEADDRNOTAVAIL
         strRet = "address is not available"
      Case WSAENETDOWN
         strRet = "network is down"
      Case WSAENETUNREACH
         strRet = "network is unreachable"
      Case WSAENETRESET
         strRet = "network dropped connection on reset"
      Case WSAECONNABORTED
         strRet = "software caused connection abort"
      Case WSAECONNRESET
         strRet = "connection reset by peer"
      Case WSAENOBUFS
         strRet = "no buffer space available"
      Case WSAEISCONN
         strRet = "socket is already connected"
      Case WSAENOTCONN
         strRet = "socket is not connected"
      Case WSAESHUTDOWN
         strRet = "cannot send after shutdown"
      Case WSAETOOMANYREFS
         strRet = "too many socket references"
      Case WSAETIMEDOUT
         strRet = "request timed out"
      Case WSAECONNREFUSED
         strRet = "connection refused"
      Case WSAENAMETOOLONG
         strRet = "name is too long"
      Case WSAEHOSTDOWN
         strRet = "host is down"
      Case WSAEHOSTUNREACH
         strRet = "host is unreachable"
      Case WSAEPROCLIM
         strRet = "too many processes"
      Case WSASYSNOTREADY
         strRet = "network sub-system is unavailable"
      Case WSAVERNOTSUPPORTED
         strRet = "requested version not supported"
      Case WSANOTINITIALISED
         strRet = "winsock is not loaded - call WSAStartup"
      Case WSAHOST_NOT_FOUND
         strRet = "host not found"
      '
      Case Else
         strRet = "unknown error"
      '
   End Select
   '
   vbGetLastError = strRet
   '
End Function
'
Public Function vbInetAddr(ByVal strIPAddress As String) As Long
   '
   ' Convert a dotted IP address into a network byte integer.
   vbInetAddr = inet_addr(strIPAddress)
   '
End Function
'
Public Function vbInetNtoa(ByVal lngIPAddress As Long) As String
   '
Dim lpString   As Long
Dim strBuffer  As String
   '
   ' Return a dotted 4 octet address from a 32bit network byte integer.
   lpString = inet_ntoa(lngIPAddress)
   If (lpString) Then
      '
      ' Prepare a buffer, copy the IP into it, then trim and return.
      strBuffer = String$(16, 0)
      Call CopyMemory(ByVal strBuffer, ByVal lpString, Len(strBuffer))
      vbInetNtoa = Mid$(strBuffer, 1, InStr(1, strBuffer, Chr$(0)) - 1)
      '
   End If
   '
End Function
'
Public Function vbHostNameFromIP(ByVal strIPAddress As String) As String
   '
Dim udtHost       As hostent
Dim lngIPAddress  As Long
Dim lngPointer    As Long
Dim strBuffer     As String
   '
   ' Resolve a dotted IP address into a hostname.
   '
   ' First, convert the string IP to a long IP.
   lngIPAddress = vbInetAddr(strIPAddress)
   If (lngIPAddress = INADDR_NONE) Then Exit Function
   '
   ' Now call gethostbyaddr to retrieve the hostent structure.
   lngPointer = gethostbyaddr(lngIPAddress, 4, AF_INET)
   If (lngPointer) Then
      '
      ' Copy the hostent structure out of the pointer.
      Call CopyMemory(udtHost, ByVal lngPointer, LenB(udtHost))
      '
      ' Prepare a string buffer and copy the hostname into it from the
      ' hostent.h_name field.
      strBuffer = String$(1024, 0)
      Call CopyMemory(ByVal strBuffer, ByVal udtHost.h_name, Len(strBuffer))
      '
      ' Trim the null characters off, and return the buffer.
      vbHostNameFromIP = Mid$(strBuffer, 1, InStr(1, strBuffer, Chr$(0)) - 1)
      '
   End If
   '
End Function
'
Public Function vbIPFromHostName(ByVal strHostName As String) As String
   '
Dim udtHost                As hostent
Dim lngIPAddress           As Long
Dim lngPointer             As Long
Dim bytIPAddress(0 To 3)   As Byte
Dim strBuffer              As String
Dim i                      As Long
   '
   ' Resolve a hostname into a dotted IP address.
   '
   ' Firstly, check if the hostname is already an IP.
   lngIPAddress = vbInetAddr(strHostName)
   If (lngIPAddress <> INADDR_NONE) Then
      '
      ' If it's already an IP, just return it.
      vbIPFromHostName = strHostName
      Exit Function
      '
   End If
   '
   ' It's not an IP, so we'll have to resolve it. Call gethostbyname().
   lngPointer = gethostbyname(strHostName)
   If (lngPointer) Then
      '
      ' Copy the hostent structure to local memory.
      Call CopyMemory(udtHost, ByVal lngPointer, LenB(udtHost))
      '
      ' h_addr_list contains a pointer to a long. So, firstly, copy out the
      ' pointer.
      Call CopyMemory(lngPointer, ByVal udtHost.h_addr_list, udtHost.h_length)
      '
      ' Copy the IP address into a four byte array, so we can build a
      ' dotted IP string from it.
      Call CopyMemory(bytIPAddress(0), ByVal lngPointer, udtHost.h_length)
      '
      ' Build and return the IP string.
      For i = 0 To 3
         strBuffer = strBuffer & CStr(bytIPAddress(i)) & "."
      Next i
      vbIPFromHostName = Mid$(strBuffer, 1, Len(strBuffer) - 1)
      '
   End If
   '
End Function
'
Public Function vbIsHostAlive(ByVal strHostAddress As String, _
                              ByVal lngWaitMilliseconds As Long) As Long
   '
Dim hEcho            As Long
Dim strIPAddress     As String
Dim lngIPAddress     As Long
Dim udtEchoRequest   As IP_OPTION_INFORMATION
Dim udtEchoReply     As IP_ECHO_REPLY
   '
   ' Ping the host to see if it's alive. Return the time.
   '
   ' Create an ICMP echo handle.
   hEcho = IcmpCreateFile()
   If (hEcho) Then
      '
      ' Convert the hostname (or IP address) into a long IP.
      strIPAddress = vbIPFromHostName(strHostAddress)
      lngIPAddress = vbInetAddr(strIPAddress)
      If (lngIPAddress <> INADDR_NONE) Then
         '
         ' Setup the echo options header.
         udtEchoRequest.TTL = 255
         '
         ' Send the echo.
         Call IcmpSendEcho(hEcho, _
                           lngIPAddress, _
                           vbNullString, _
                           0, _
                           udtEchoRequest, _
                           udtEchoReply, _
                           LenB(udtEchoReply), _
                           lngWaitMilliseconds)
         '
         ' Return the time it took. If the host is not alive, this will be 0.
         vbIsHostAlive = udtEchoReply.RoundTripTime
         '
      End If
      '
      ' Release the ICMP echo resources.
      Call IcmpCloseHandle(hEcho)
      '
   End If
   '
End Function
'