Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/ftpser1a/vbsock.bas

BASIC Source File | 1999-08-28 | 11.6 KB | 324 lines

Attribute VB_Name = "VBSOCK"
Option Explicit

Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Dest As Any, Src As Any, ByVal cb&)
Declare Function lstrlen Lib "kernel32" (ByVal lpString As Any) As Integer

Global DnsHost As String
Global MaxSockets As Integer
Global MaxUDP As Long
Global Description As String
Global Status As String


Function ConnectSocket(ByVal hWndtyp As Long, ByVal Host As String, ByVal Port As Integer) As Long
Dim SockreadBuffer As String, RetIpPort As String
Dim S As Long, Dummy As Long
'Dim NewSock As SockAddr
Dim SelectOps As Integer
    SockreadBuffer = ""
    SockAddr.sin_family = AF_INET
    SockAddr.sin_port = htons(Port)
    If Val(SockAddr.sin_zero) = INVALID_SOCKET Then
        ConnectSocket = INVALID_SOCKET
        Exit Function
    End If
    SockAddr.sin_addr = GetHostByNameAlias(Host)
    If SockAddr.sin_addr = INADDR_NONE Then
        ConnectSocket = INVALID_SOCKET
        Exit Function
    End If
    RetIpPort = GetAscIP(SockAddr.sin_addr) & ":" & ntohs(SockAddr.sin_port)
    Debug.Print RetIpPort
    S = Socket(PF_INET, SOCK_STREAM, IPPROTO_TCP)
    If S < 0 Then
        ConnectSocket = INVALID_SOCKET
        Exit Function
    End If
    'If SetSockLinger(S, 1, 0) = SOCKET_ERROR Then
    '    If S > 0 Then
    '       Dummy = closesocket(S)
    '    End If
    '    ConnectSocket = INVALID_SOCKET
    '    Exit Function
    'End If
    SelectOps = FD_CONNECT Or FD_READ Or FD_WRITE Or FD_CLOSE Or FD_ACCEPT
    If WSAAsyncSelect(S, hWndtyp, ByVal 5152, ByVal SelectOps) Then
        If S > 0 Then
            Dummy = closesocket(S)
        End If
        ConnectSocket = INVALID_SOCKET
        Exit Function
    End If
    If connect(S, SockAddr, SockAddr_Size) <> -1 Then
        If S > 0 Then
            Dummy = closesocket(S)
        End If
        ConnectSocket = INVALID_SOCKET
        Exit Function
    End If
    ConnectSocket = S
End Function

Function WSAGetSelectEvent(ByVal lParam As Long) As Long
    WSAGetSelectEvent = Int(lParam Mod 65536)
End Function

'Public Function WSAGetSelectEvent(ByVal lParam As Long) As Integer
'    If (lParam And &HFFFF&) > &H7FFF Then
'        WSAGetSelectEvent = (lParam And &HFFFF&) - &H10000
'    Else
'        WSAGetSelectEvent = lParam And &HFFFF&
'    End If
'End Function

Public Function WSAGetAsyncError(ByVal lParam As Long) As Long
    WSAGetAsyncError = (lParam And &HFFFF0000) \ &H10000
End Function

Function DNS_Lookup(ByVal dnsip As String) As String
  DnsHost = ""
  vbWSAStartup
  DoEvents
  DNS_Lookup = vbGetHostByAddress(dnsip)
  DoEvents
  vbWSACleanup
End Function

Function vbGetHostByAddress(ByVal sAddress As String) As String
  Dim lAddress As Long
  Dim PointerToMemoryLocation As Long
  Dim HostName As String
  Dim hostent As hostent
  lAddress = inet_addr(sAddress)
  PointerToMemoryLocation = gethostbyaddr(lAddress, 4, PF_INET)
  If PointerToMemoryLocation <> 0 Then
    CopyMemory hostent, ByVal PointerToMemoryLocation, Len(hostent)
    HostName = String(256, 0)
    CopyMemory ByVal HostName, ByVal hostent.h_name, 256
    If HostName = "" Then
      vbGetHostByAddress = "Unable to Resolve Address"
    Else
      vbGetHostByAddress = Left(HostName, InStr(HostName, Chr(0)) - 1)
    End If
  Else
    vbGetHostByAddress = "No DNS Entry"
  End If
End Function

Function LoByte(ByVal wParam As Integer)
  LoByte = wParam And &HFF&
End Function

Function HiByte(ByVal wParam As Integer)
  HiByte = wParam / &H100 And &HFF&
End Function

Sub vbWSAStartup()
  Dim iReturn As Integer
  Dim sHighByte As String
  Dim sLowByte As String
  Dim sMsg As String
  Dim i As Integer
  iReturn = WSAStartup(&H101, WSAdata)
   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)))
        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."
        End
    End If
    MaxSockets = WSAdata.iMaxSockets
    If MaxSockets < 0 Then
        MaxSockets = 65536 + MaxSockets
    End If
    MaxUDP = WSAdata.iMaxUdpDg
    If MaxUDP < 0 Then
        MaxUDP = 65536 + MaxUDP
    End If
    Description = WSAdata.szDescription
    Status = ""
    Status = WSAdata.szSystemStatus
End Sub

Sub vbWSACleanup()
  Dim iReturn As Long
  Dim sMsg As String
  iReturn = WSACleanup()
  If iReturn <> 0 Then
    sMsg = "WSock32 Error - " & Trim$(Str$(iReturn)) & " occurred in Cleanup"
    End
  End If
End Sub


'returns IP as long, in network byte order
Public Function GetHostByNameAlias(ByVal HostName$) As Long
    'Return IP address as a long, in network byte order
    Dim phe&
    Dim heDestHost As hostent
    Dim addrList&
    Dim retIP&
    retIP = inet_addr(HostName$)
    If retIP = INADDR_NONE Then
        phe = gethostbyname(HostName$)
        If phe <> 0 Then
            CopyMemory heDestHost, ByVal phe, Len(heDestHost)
            CopyMemory addrList, ByVal heDestHost.h_addr_list, 4
            CopyMemory retIP, ByVal addrList, heDestHost.h_length
        Else
            retIP = INADDR_NONE
        End If
    End If
    GetHostByNameAlias = retIP
End Function


Public Function GetAscIP(ByVal inn As Long) As String
  Dim nStr&
    Dim lpStr&
    Dim retString$
    retString = String(32, 0)
    lpStr = inet_ntoa(inn)
    If lpStr Then
        nStr = lstrlen(lpStr)
        If nStr > 32 Then nStr = 32
        CopyMemory ByVal retString, ByVal lpStr, nStr
        retString = Left(retString, nStr)
        GetAscIP = retString
    Else
        GetAscIP = "255.255.255.255"
    End If
End Function

Public Function SetSockLinger(ByVal SockNum As Long, ByVal OnOff As Integer, ByVal LingerTime As Integer) As Long
    Dim Linger As LingerType
    Linger.l_onoff = OnOff
    Linger.l_linger = LingerTime
    If setsockopt(SockNum, SOL_SOCKET, SO_LINGER, Linger, 4) Then
        Debug.Print "Error setting linger info: " & WSAGetLastError()
        SetSockLinger = SOCKET_ERROR
    Else
        If getsockopt(SockNum, SOL_SOCKET, SO_LINGER, Linger, 4) Then
            Debug.Print "Error getting linger info: " & WSAGetLastError()
            SetSockLinger = SOCKET_ERROR
        Else
            Debug.Print "Linger is on if nonzero: "; Linger.l_onoff
            Debug.Print "Linger time if linger is on: "; Linger.l_linger
        End If
    End If
End Function

Public Function ListenForConnect(ByVal Port&, ByVal HWndToMsg&) As Long
Dim S As Long, Dummy As Long
Dim SelectOps As Integer

    S = Socket(PF_INET, SOCK_STREAM, IPPROTO_TCP)
    If S < 0 Then
        ListenForConnect = INVALID_SOCKET
        Exit Function
    End If

    SockAddr.sin_family = AF_INET
    SockAddr.sin_port = htons(Port)
    If SockAddr.sin_port = INVALID_SOCKET Then
        ListenForConnect = INVALID_SOCKET
        Exit Function
    End If
    SockAddr.sin_addr = htonl(INADDR_ANY)
    If SockAddr.sin_addr = INADDR_NONE Then
        ListenForConnect = INVALID_SOCKET
        Exit Function
    End If

    If bind(S, SockAddr, SockAddr_Size) Then
        If S > 0 Then
            Dummy = closesocket(S)
        End If
        ListenForConnect = INVALID_SOCKET
        Exit Function
    End If

    If listen(S, 1) Then
        If S > 0 Then
            Dummy = closesocket(S)
        End If
        ListenForConnect = INVALID_SOCKET
        Exit Function
    End If

    SelectOps = FD_CONNECT Or FD_READ Or FD_WRITE Or FD_CLOSE Or FD_ACCEPT
    If WSAAsyncSelect(S, HWndToMsg, ByVal 5150, ByVal SelectOps) Then
        If S > 0 Then
            Dummy = closesocket(S)
        End If
        ListenForConnect = SOCKET_ERROR
        Exit Function
    End If
    ListenForConnect = S
End Function

Function GetWSAErrorString(ByVal errnum As Long) As String
    On Error Resume Next
    Select Case errnum
        Case 10004: GetWSAErrorString = "Interrupted system call."
        Case 10009: GetWSAErrorString = "Bad file number."
        Case 10013: GetWSAErrorString = "Permission Denied."
        Case 10014: GetWSAErrorString = "Bad Address."
        Case 10022: GetWSAErrorString = "Invalid Argument."
        Case 10024: GetWSAErrorString = "Too many open files."
        Case 10035: GetWSAErrorString = "Operation would block."
        Case 10036: GetWSAErrorString = "Operation now in progress."
        Case 10037: GetWSAErrorString = "Operation already in progress."
        Case 10038: GetWSAErrorString = "Socket operation on nonsocket."
        Case 10039: GetWSAErrorString = "Destination address required."
        Case 10040: GetWSAErrorString = "Message too long."
        Case 10041: GetWSAErrorString = "Protocol wrong type for socket."
        Case 10042: GetWSAErrorString = "Protocol not available."
        Case 10043: GetWSAErrorString = "Protocol not supported."
        Case 10044: GetWSAErrorString = "Socket type not supported."
        Case 10045: GetWSAErrorString = "Operation not supported on socket."
        Case 10046: GetWSAErrorString = "Protocol family not supported."
        Case 10047: GetWSAErrorString = "Address family not supported by protocol family."
        Case 10048: GetWSAErrorString = "Address already in use."
        Case 10049: GetWSAErrorString = "Can't assign requested address."
        Case 10050: GetWSAErrorString = "Network is down."
        Case 10051: GetWSAErrorString = "Network is unreachable."
        Case 10052: GetWSAErrorString = "Network dropped connection."
        Case 10053: GetWSAErrorString = "Software caused connection abort."
        Case 10054: GetWSAErrorString = "Connection reset by peer."
        Case 10055: GetWSAErrorString = "No buffer space available."
        Case 10056: GetWSAErrorString = "Socket is already connected."
        Case 10057: GetWSAErrorString = "Socket is not connected."
        Case 10058: GetWSAErrorString = "Can't send after socket shutdown."
        Case 10059: GetWSAErrorString = "Too many references: can't splice."
        Case 10060: GetWSAErrorString = "Connection timed out."
        Case 10061: GetWSAErrorString = "Connection refused."
        Case 10062: GetWSAErrorString = "Too many levels of symbolic links."
        Case 10063: GetWSAErrorString = "File name too long."
        Case 10064: GetWSAErrorString = "Host is down."
        Case 10065: GetWSAErrorString = "No route to host."
        Case 10066: GetWSAErrorString = "Directory not empty."
        Case 10067: GetWSAErrorString = "Too many processes."
        Case 10068: GetWSAErrorString = "Too many users."
        Case 10069: GetWSAErrorString = "Disk quota exceeded."
        Case 10070: GetWSAErrorString = "Stale NFS file handle."
        Case 10071: GetWSAErrorString = "Too many levels of remote in path."
        Case 10091: GetWSAErrorString = "Network subsystem is unusable."
        Case 10092: GetWSAErrorString = "Winsock DLL cannot support this application."
        Case 10093: GetWSAErrorString = "Winsock not initialized."
        Case 10101: GetWSAErrorString = "Disconnect."
        Case 11001: GetWSAErrorString = "Host not found."
        Case 11002: GetWSAErrorString = "Nonauthoritative host not found."
        Case 11003: GetWSAErrorString = "Nonrecoverable error."
        Case 11004: GetWSAErrorString = "Valid name, no data record of requested type."
        Case Else:  GetWSAErrorString = "Unknown Error..."
    End Select
End Function