www.pudn.com > ownfirewall > vbsock.bas

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 
Global ServerSlot As Long 
Global ClientSlot As Long 
Global NewSrvSlot As Long 
Global NewCliSlot As Long 
Global Num_Users As Integer 
 
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 
    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) 
  If (lAddress <> &H100007F) Then 
    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 
        If (lAddress = 0) Then 
          vbGetHostByAddress = LCase(TrimNull(HostName)) 
        Else 
          vbGetHostByAddress = TrimNull(HostName) 
        End If 
      End If 
    Else 
      vbGetHostByAddress = sAddress 
    End If 
  Else 
    vbGetHostByAddress = "localhost" 
  End If 
End Function 
' 
'If (lAddress = 0) Or (lAddress = &H100007F) Then 
'  vbGetHostByAddress = LCase(TrimNull(HostName)) 
'Else 
 
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 As Long 
    Dim retString As String 
    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 Lingert As Linger 
Dim retf As Long 
Dim LingerSiz As Integer 
  LingerSiz = 4 
  Linger.l_onoff = OnOff 
  Linger.l_linger = LingerTime 
  retf = setsockopt(SockNum, SOL_SOCKET, SO_LINGER, Linger, LingerSiz) 
  If (retf = -1) Then 
    Debug.Print "Error setting linger info: " & WSAGetLastError() 
    SetSockLinger = SOCKET_ERROR 
  Else 
    retf = getsockopt(SockNum, SOL_SOCKET, SO_LINGER, Linger, LingerSiz) 
    If retf Then 
      Debug.Print "Error getting linger info: " & WSAGetLastError() 
      SetSockLinger = SOCKET_ERROR 
    End If 
  End If 
  Debug.Print "Linger is on if nonzero: "; Linger.l_onoff 
  Debug.Print "Linger time if linger is on: "; Linger.l_linger 
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 
Sub WSAErr() 
Dim lrtn As Long 
  lrtn = WSAGetLastError 
  Debug.Print GetWSAErrorString(lrtn) 
End Sub 
 
'GetPortName( localport, "tcp", PORTNAMELEN )) 
Function vbGetServByPort(ByVal iport As Long, ByRef proto As String) As String 
Dim lrtn As Long, x As Long 
Dim Name As String, aliases As String, prot As String 
Dim pA As Long 
  Name = String(128, Chr(0)) 
  aliases = String(128, Chr(0)) 
  prot = String(128, Chr(0)) 
  lrtn = getservbyport(iport, proto) 
  If (lrtn <> 0) Then 
    CopyMemory servent, ByVal lrtn, 128 
    CopyMemory pA, ByVal servent.s_aliases, 4 
    CopyMemory ByVal aliases, ByVal pA, 20 
    CopyMemory ByVal Name, ByVal servent.s_name, 16 
    CopyMemory ByVal prot, ByVal servent.s_proto, 16 
    x = ntohs(servent.s_port) 
  Else 
    x = ntohs(iport) 
    Name = CStr(x) 
  End If 
  vbGetServByPort = TrimNull(Name) 
End Function 
 
Function vbGetServByName(ByVal proto As String) As String 
Dim lrtn As Long, Bf As String 
Dim x As Integer, l2 As Long 
Dim Name As String, aliases As String, prot As String 
  Bf = String(128, Chr(0)) 
  Name = String(128, Chr(0)) 
  aliases = String(128, Chr(0)) 
  prot = String(128, Chr(0)) 
  lrtn = getservbyname(proto, ByVal Name) 
  CopyMemory servent, ByVal lrtn, Len(servent) 
  CopyMemory ByVal Bf, ByVal lrtn, 128 
  CopyMemory l2, ByVal servent.s_aliases, 4 
  CopyMemory ByVal aliases, ByVal l2, 10 
  CopyMemory ByVal Name, ByVal servent.s_name, 6 
  CopyMemory ByVal prot, ByVal servent.s_proto, 6 
  x = ntohs(servent.s_port) 
  vbGetServByName = Name 
End Function 
 
Function TrimNull(s As String) As String 
Dim x As Integer 
  x = InStr(s, Chr(0)) 
  If x > 0 Then 
    TrimNull = Left(s, x - 1) 
  Else 
    TrimNull = s 
  End If 
End Function