Attribute VB_Name = "SocketModule"

Public Sockets As New Collection
Public usedcount%

Public Enum sockType
   sockClosed = 1
   sockListening = 2
   sockConnecting = 3
   sockConnected = 4
End Enum

Public Const FD_SETSIZE = 64
Public Const FIONBIO = &H80000000 Or 262144 Or 26112 Or 126

Public Const CSocketMsg = 2000

Public Type fd_set
   fd_count As Integer
   fd_array(FD_SETSIZE) As Integer
End Type

Public Type timeval
   tv_sec As Long
   tv_usec As Long
End Type

Public Type Inet_address
   Byte4 As String * 1
   Byte3 As String * 1
   Byte2 As String * 1
   Byte1 As String * 1
End Type

Public Type HostEnt
   h_name As Long
   h_aliases As Long
   h_addrtype As Integer
   h_length As Integer
   h_addr_list As Long
End Type
Public Const hostent_size = 16

Public Type servent
   s_name As Long
   s_aliases As Long
   s_port As Integer
   s_proto As Long
End Type
Public Const servent_size = 14

Public Type protoent
   p_name As Long
   p_aliases As Long
   p_proto As Integer
End Type
Public Const protoent_size = 10

Public Const IPPROTO_TCP = 6
Public Const IPPROTO_UDP = 17

Public Const INADDR_NONE = &HFFFF
Public Const INADDR_ANY = &H0

Public Type sockaddr
   sin_family As Integer
   sin_port As Integer
   sin_addr As Long
   sin_zero As String * 8
End Type
Public Type sockaddrbyte
   sin_family As Integer
   sin_port As Integer
   sin_addr1 As Byte
   sin_addr2 As Byte
   sin_addr3 As Byte
   sin_addr4 As Byte
   sin_zero As String * 8
End Type
Public Const sockaddr_size = 16

Public Const WSA_DESCRIPTIONLEN = 256
Public Const WSA_DescriptionSize = WSA_DESCRIPTIONLEN + 1

Public Const WSA_SYS_STATUS_LEN = 128
Public Const WSA_SysStatusSize = WSA_SYS_STATUS_LEN + 1

Public Const WSABASEERR = 10000
Public Const WSAEWOULDBLOCK = WSABASEERR + 35

Public Type WSADataType
   wVersion As Integer
   wHighVersion As Integer
   szDescription As String * WSA_DescriptionSize
   szSystemStatus As String * WSA_SysStatusSize
   iMaxSockets As Integer
   iMaxUdpDg As Integer
   lpVendorInfo As Long
End Type

Public Const INVALID_SOCKET = -1
Public Const SOCKET_ERROR = -1

Public Const SOCK_STREAM = 1
Public Const SOCK_DGRAM = 2

Public Const MAXGETHOSTSTRUCT = 1024

Public Const AF_INET = 2
Public Const PF_INET = 2

Public Type LingerType
   l_onoff As Integer
   l_linger As Integer
End Type

'---Windows System Functions
Public Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Sub MemCopy Lib "kernel32" Alias "RtlMoveMemory" (Dest As Any, Src As Any, ByVal cb&)
Public Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As Any) As Long

'---async notification constants
Public Const SOL_SOCKET = &HFFFF&
Public Const SO_LINGER = &H80&
Public Const FD_READ = &H1&
Public Const FD_WRITE = &H2&
Public Const FD_ACCEPT = &H8&
Public Const FD_CONNECT = &H10&
Public Const FD_CLOSE = &H20&

'---SOCKET FUNCTIONS
Public Declare Function acceptsocket Lib "wsock32.dll" Alias "accept" (ByVal s As Long, addr As sockaddr, addrlen As Long) As Long
Public Declare Function bind Lib "wsock32.dll" (ByVal s As Long, addr As sockaddr, ByVal namelen As Long) As Long
Public Declare Function closesocket Lib "wsock32.dll" (ByVal s As Long) As Long
Public Declare Function connectsocket Lib "wsock32.dll" Alias "connect" (ByVal s As Long, addr As sockaddr, ByVal namelen As Long) As Long
Public Declare Function ioctlsocket Lib "wsock32.dll" (ByVal s As Long, ByVal cmd As Long, argp As Long) As Long
Public Declare Function getpeername Lib "wsock32.dll" (ByVal s As Long, sname As Any, namelen As Long) As Long
Public Declare Function getsockname Lib "wsock32.dll" (ByVal s As Long, sname As Any, namelen As Long) As Long
Public Declare Function getsockopt Lib "wsock32.dll" (ByVal s As Long, ByVal level As Long, ByVal optname As Long, optval As Any, optlen As Long) As Long
Public Declare Function setsockopt Lib "wsock32.dll" (ByVal s As Long, ByVal level As Long, ByVal optname As Long, optval As Any, ByVal optlen As Long) As Long
Public Declare Function htonl Lib "wsock32.dll" (ByVal hostlong As Long) As Long
Public Declare Function htons Lib "wsock32.dll" (ByVal hostshort As Long) As Integer
Public Declare Function inet_addr Lib "wsock32.dll" (ByVal cp As String) As Long
Public Declare Function inet_ntoa Lib "wsock32.dll" (ByVal inn As Long) As Long
Public Declare Function listensocket Lib "wsock32.dll" Alias "listen" (ByVal s As Long, ByVal backlog As Long) As Long
Public Declare Function ntohl Lib "wsock32.dll" (ByVal netlong As Long) As Long
Public Declare Function ntohs Lib "wsock32.dll" (ByVal netshort As Long) As Integer
Public Declare Function recv Lib "wsock32.dll" (ByVal s As Long, buf As Any, ByVal buflen As Long, ByVal flags As Long) As Long
Public Declare Function send Lib "wsock32.dll" (ByVal s As Long, buf As Any, ByVal buflen As Long, ByVal flags As Long) As Long
Public Declare Function socket Lib "wsock32.dll" (ByVal af As Long, ByVal s_type As Long, ByVal Protocol As Long) As Long
Public Declare Function gethostbyaddr Lib "wsock32.dll" (ByVal addr As String, ByVal addr_len As Long, ByVal addr_type As Long) As Long
Public Declare Function gethostbyname Lib "wsock32.dll" (ByVal host_name As String) As Long
Public Declare Function gethostname Lib "wsock32.dll" (ByVal host_name As String, ByVal namelen As Long) As Long
Public Declare Function getprotobynumber Lib "wsock32.dll" (ByVal proto As Integer) As Long
Public Declare Function getprotobyname Lib "wsock32.dll" (ByVal proto_name As String) As Long
Public Declare Function getservbyport Lib "wsock32.dll" (ByVal Port As Long, ByVal proto As String) As Long
Public Declare Function getservbyname Lib "wsock32.dll" (ByVal serv_name As String, ByVal proto As String) As Long

'---WINDOWS EXTENSIONS
Public Declare Function WSAStartup Lib "wsock32.dll" (ByVal wVR As Long, lpWSAD As WSADataType) As Long
Public Declare Function WSACleanup Lib "wsock32.dll" () As Long
Public Declare Sub WSASetLastError Lib "wsock32.dll" (ByVal iError As Long)
Public Declare Function WSAGetLastError Lib "wsock32.dll" () As Long
Public Declare Function WSAAsyncSelect Lib "wsock32.dll" (ByVal s As Long, ByVal hwnd As Long, ByVal wMsg As Long, ByVal lEvent As Long) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal wndrpcPrev As Long, ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Declare Sub RtlMoveMemory Lib "kernel32" (hpvDest As Any, ByVal hpvSource&, ByVal cbCopy&)

Public Const GWL_WNDPROC = (-4)

' ICMP
Public Type IP_OPTION_INFORMATION
   TTL As Byte                   ' Time to Live (used for traceroute)
   Tos As Byte                   ' Type of Service (usually 0)
   flags As Byte                 ' IP header Flags (usually 0)
   OptionsSize As Long           ' Size of Options data (usually 0, Max 40)
   OptionsData As String * 128   ' Options data buffer
End Type

Public Type IP_ECHO_REPLY
   Address(0 To 3) As Byte           ' Replying Address
   Status As Long                    ' Reply Status
   RoundTripTime As Long             ' Round Trip Time in milliseconds
   DataSize As Integer               ' reply data size
   Reserved As Integer               ' for system use
   data As Long                      ' pointer to echo data
   Options As IP_OPTION_INFORMATION  ' Reply Options
End Type

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

Public Const WS_OVERLAPPED = &H0&
Public Const WS_MINIMIZEBOX = &H20000
Public Const WS_MAXIMIZEBOX = &H10000
Public Const WS_SYSMENU = &H80000
Public Const WS_THICKFRAME = &H40000
Public Const WS_CAPTION = &HC00000                  '  WS_BORDER Or WS_DLGFRAME
Public Const WS_VISIBLE = &H10000000
Public Const WS_OVERLAPPEDWINDOW = (WS_OVERLAPPED Or WS_CAPTION Or WS_SYSMENU Or WS_THICKFRAME Or WS_MINIMIZEBOX Or WS_MAXIMIZEBOX)

Public Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
Public Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Public Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Public Const WM_TIMER = &H113

'OpenSSL
Public Declare Function ssl_init_client Lib "OpenSSL.dll" (ByVal socket&, ByVal cafile$) As Long
Public Declare Function ssl_init_server Lib "OpenSSL.dll" (ByVal socket&, ByVal cert$, ByVal key$) As Long
Public Declare Sub ssl_getcipher Lib "OpenSSL.dll" (ByVal handle&, ByVal data$, ByVal length&)
Public Declare Sub ssl_getsubject Lib "OpenSSL.dll" (ByVal handle&, ByVal data$, ByVal length&)
Public Declare Sub ssl_getissuer Lib "OpenSSL.dll" (ByVal handle&, ByVal data$, ByVal length&)
Public Declare Function ssl_send Lib "OpenSSL.dll" (ByVal handle&, data As Any, ByVal length&) As Long
Public Declare Function ssl_recv Lib "OpenSSL.dll" (ByVal handle&, data As Any, ByVal length&) As Long
Public Declare Sub ssl_cleanup Lib "OpenSSL.dll" (ByVal handle&)
Public Declare Function ssl_getverify Lib "OpenSSL.dll" (ByVal handle&) As Long

Public Const X509_V_OK = 0
Public Const X509_V_ERR_ILLEGAL = 1
Public Const X509_V_ERR_UNABLE_TO_GET_ISSUER_CERT = 2
Public Const X509_V_ERR_UNABLE_TO_GET_CRL = 3
Public Const X509_V_ERR_UNABLE_TO_DECRYPT_CERT_SIGNATURE = 4
Public Const X509_V_ERR_UNABLE_TO_DECRYPT_CRL_SIGNATURE = 5
Public Const X509_V_ERR_UNABLE_TO_DECODE_ISSUER_PUBLIC_KEY = 6
Public Const X509_V_ERR_CERT_SIGNATURE_FAILURE = 7
Public Const X509_V_ERR_CRL_SIGNATURE_FAILURE = 8
Public Const X509_V_ERR_CERT_NOT_YET_VALID = 9
Public Const X509_V_ERR_CERT_HAS_EXPIRED = 10
Public Const X509_V_ERR_CRL_NOT_YET_VALID = 11
Public Const X509_V_ERR_CRL_HAS_EXPIRED = 12
Public Const X509_V_ERR_ERROR_IN_CERT_NOT_BEFORE_FIELD = 13
Public Const X509_V_ERR_ERROR_IN_CERT_NOT_AFTER_FIELD = 14
Public Const X509_V_ERR_ERROR_IN_CRL_LAST_UPDATE_FIELD = 15
Public Const X509_V_ERR_ERROR_IN_CRL_NEXT_UPDATE_FIELD = 16
Public Const X509_V_ERR_OUT_OF_MEM = 17
Public Const X509_V_ERR_DEPTH_ZERO_SELF_SIGNED_CERT = 18
Public Const X509_V_ERR_SELF_SIGNED_CERT_IN_CHAIN = 19
Public Const X509_V_ERR_UNABLE_TO_GET_ISSUER_CERT_LOCALLY = 20
Public Const X509_V_ERR_UNABLE_TO_VERIFY_LEAF_SIGNATURE = 21
Public Const X509_V_ERR_CERT_CHAIN_TOO_LONG = 22
Public Const X509_V_ERR_CERT_REVOKED = 23
Public Const X509_V_ERR_INVALID_CA = 24
Public Const X509_V_ERR_PATH_LENGTH_EXCEEDED = 25
Public Const X509_V_ERR_INVALID_PURPOSE = 26
Public Const X509_V_ERR_CERT_UNTRUSTED = 27
Public Const X509_V_ERR_CERT_REJECTED = 28
Public Const X509_V_ERR_APPLICATION_VERIFICATION = 50

Public Function GetAscIp(ByVal inn As Long) As String

On Error Resume Next
Dim lpStr&
Dim nStr&
Dim retString$

retString = String(32, 0)
lpStr = inet_ntoa(inn)
If lpStr = 0 Then
   GetAscIp = ""
   Exit Function
End If
nStr = lstrlen(lpStr)
If nStr > 32 Then nStr = 32
MemCopy ByVal retString, ByVal lpStr, nStr
retString = Left(retString, nStr)
GetAscIp = retString
If Err Then GetAscIp = ""

End Function

Public Function GetHostByNameAlias(ByVal hostname$) As Long

On Error Resume Next
'Return IP address as a long, in network byte order

Dim phe&    ' pointer to host information entry
Dim heDestHost As HostEnt 'hostent structure
Dim addrList&
Dim retIP&
'first check to see if what we have been passed is a valid IP
retIP = inet_addr(hostname)
If retIP = INADDR_NONE Then
   'it wasn't an IP, so do a DNS lookup
   phe = gethostbyname(hostname)
   If phe <> 0 Then
      'Pointer is non-null, so copy in hostent structure
      MemCopy heDestHost, ByVal phe, hostent_size
      'Now get first pointer in address list
      MemCopy addrList, ByVal heDestHost.h_addr_list, 4
      MemCopy retIP, ByVal addrList, heDestHost.h_length
   Else
      'its not a valid address
      retIP = INADDR_NONE
   End If
End If
GetHostByNameAlias = Trim$(retIP)
If Err Then GetHostByNameAlias = INADDR_NONE

End Function

Public Function GetHostByAddress(ByVal addr As Long) As String

On Error Resume Next
Dim phe&, ret&
Dim heDestHost As HostEnt
Dim hostname$
phe = gethostbyaddr(addr, 4, PF_INET)
If phe <> 0 Then
   MemCopy heDestHost, ByVal phe, hostent_size
   hostname = String(256, 0)
   MemCopy ByVal hostname, ByVal heDestHost.h_name, 256
   GetHostByAddress = Left(hostname, InStr(hostname, Chr(0)) - 1)
Else
   GetHostByAddress = ""
End If
If Err Then GetHostByAddress = ""

End Function

Public Function AddrToIP(ByVal AddrOrIP$) As String

AddrToIP$ = GetAscIp(GetHostByNameAlias(AddrOrIP$))

End Function

Public Function IpToAddr(ByVal AddrOrIP$) As String

On Error Resume Next
IpToAddr = GetHostByAddress(GetHostByNameAlias(AddrOrIP$))
If Err Then IpToAddr = ""

End Function

Public Function DNSLookup(ByVal Address As String) As String

If inet_addr(Address) <> INADDR_NONE Then
   DNSLookup = IpToAddr(Address)
ElseIf gethostbyname(Address) <> 0 Then
   DNSLookup = AddrToIP(Address)
End If

End Function

Public Function GetLocalHostName() As String

Dim dummy&, LocalName$, s$

GetLocalHostName = ""
On Error Resume Next
LocalName = ""
s = String(256, 0)
dummy = gethostname(s, 256)
If dummy = 0 Then
   s = Left(s, InStr(s, Chr(0)) - 1)
   If Len(s) > 0 Then
      GetLocalHostName = Trim$(s)
   End If
End If

End Function

Public Function LongIP(ByVal IPAddress As String) As String

On Error GoTo longipError
Dim nStr&
Dim retString$
Dim lpStr&
Dim inn&
If InStr(IPAddress, ".") = 0 Then
   If Val(IPAddress) > 2147483647 Then
      inn = Val(IPAddress) - 4294967296#
   Else
      inn = Val(IPAddress)
   End If
   inn = ntohl(inn)
   retString = String(32, 0)
   lpStr = inet_ntoa(inn)
   If lpStr = 0 Then
      LongIP = "0.0.0.0"
      Exit Function
   End If
   nStr = lstrlen(lpStr)
   If nStr > 32 Then nStr = 32
   MemCopy ByVal retString, ByVal lpStr, nStr
   retString = Left(retString, nStr)
   LongIP = retString
   Exit Function
longipError:
   LongIP = ""
   Exit Function
   Resume
Else
   inn = inet_addr(IPAddress)
   inn = htonl(inn)
   If inn < 0 Then
      LongIP = CVar(inn + 4294967296#)
   Else
      LongIP = CVar(inn)
   End If
End If

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 Integer

WSAGetAsyncError = (lParam And &HFFFF0000) \ &H10000

End Function

Public Function GetWSAErrorString(ByVal errnum&) As String

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 Initized."
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:
End Select

End Function

Public Function SetSockLinger(ByVal SockNum&, ByVal onoff%, ByVal LingerTime%) 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 "; IIf(Linger.l_onoff, "on", "off")
      If Linger.l_onoff Then Debug.Print "Linger time:"; Linger.l_linger
   End If
End If

End Function

Public Function GetPeerHostByAddr(socket As Long) As String

Dim Sock As sockaddrbyte
Call getpeername(socket, Sock, sockaddr_size)
GetPeerHostByAddr = Sock.sin_addr1 & "." & Sock.sin_addr2 & "." & Sock.sin_addr3 & "." & Sock.sin_addr4

End Function

Public Function GetPeerHostByName(socket As Long) As String

Dim Sock As sockaddr
Call getpeername(socket, Sock, sockaddr_size)
GetPeerHostByName = GetHostByAddress(Sock.sin_addr)

End Function

Public Function GetPeerPort(socket As Long) As Long

Dim Sock As sockaddr
Call getpeername(socket, Sock, sockaddr_size)
p% = ntohs(Sock.sin_port)
If p% < 0 Then GetPeerPort = p% + 65536 Else GetPeerPort = p%

End Function

Public Function GetProtocol(Protocol)

Dim peDestProt As protoent
Dim ppe As Long
If TypeName(Protocol) = "String" Then
   ppe = getprotobyname(Protocol)
   If ppe = 0 Then
      GetProtocol = -1
      Exit Function
   End If
   MemCopy peDestProt, ByVal ppe, protoent_size
   GetProtocol = peDestProt.p_proto
End If
If IsNumeric(Protocol) Then
   ppe = getprotobynumber(CInt(Protocol))
   If ppe = 0 Then
      GetProtocol = -1
      Exit Function
   End If
   MemCopy peDestProt, ByVal ppe, protoent_size
   Dim strProto As String
   strProto = String$(256, 0)
   MemCopy ByVal strProto, ByVal peDestProt.p_name, 256
   strProto = Left$(strProto, InStr(strProto, Chr$(0)) - 1)
   GetProtocol = strProto
End If

End Function

Public Function GetService(Service, Protocol)

Dim seDestServ As servent
Dim pse As Long
If IsNumeric(Protocol) Then Protocol = GetProtocol(CInt(Protocol))
If TypeName(Service) = "String" Then
   pse = getservbyname(Service, Protocol)
   If pse = 0 Then
      GetService = -1
      Exit Function
   End If
   MemCopy seDestServ, ByVal pse, servent_size
   GetService = ntohs(seDestServ.s_port)
End If
If IsNumeric(Service) Then
   pse = getservbyport(htons(CLng(Service)), Protocol)
   If pse = 0 Then
      GetService = -1
      Exit Function
   End If
   MemCopy seDestServ, ByVal pse, servent_size
   Dim strService As String
   strService = String$(256, 0)
   MemCopy ByVal strService, ByVal seDestServ.s_name, 256
   strService = Left$(strService, InStr(strService, Chr$(0)) - 1)
   GetService = strService
End If

End Function

Public Function GetLocalHost(socket As Long) As String

Dim Sock As sockaddr
Call getsockname(socket, Sock, sockaddr_size)
GetLocalHost = GetHostByAddress(Sock.sin_addr)

End Function

Public Function GetLocalPort(socket As Long) As Integer

Dim Sock As sockaddr
Call getsockname(socket, Sock, sockaddr_size)
GetLocalPort = ntohs(Sock.sin_port)

End Function

Public Function PingHost(host As String)

Dim ICMPHandle As Long

' Get IP Address
If inet_addr(host) = INADDR_NONE Then
   host = DNSLookup(host)
   If host = "" Then Exit Function
End If
ICMPHandle = IcmpCreateFile()
If ICMPHandle = 0 Then Exit Function ' Error
Dim IPOption As IP_OPTION_INFORMATION
IPOption.TTL = "255"
Dim buf As String
buf = String$(32, 0) ' Intialize Buffer
Dim IPReply As IP_ECHO_REPLY
If IcmpSendEcho(ICMPHandle, GetHostByNameAlias(host), buf, 32, IPOption, IPReply, Len(IPReply) + 8, 2700) = False Then PingHost = "Request Timed Out"
If PingHost = "" Then PingHost = GetICMPError$(CInt(IPReply.Status))
If PingHost = "" Then PingHost = IPReply.RoundTripTime
Call IcmpCloseHandle(ICMPHandle)

End Function

Public Function TraceRt(host As String)

Dim ICMPHandle As Long

' Get IP Address
If inet_addr(host) = INADDR_NONE Then
   host = DNSLookup(host)
   If host = "" Then Exit Function
End If
ICMPHandle = IcmpCreateFile()
If ICMPHandle = 0 Then Exit Function ' Error
Dim IPOption As IP_OPTION_INFORMATION
Dim buf As String
Dim IPReply As IP_ECHO_REPLY
Dim HopAddress As String
Dim HopCounter As Integer
For IPOption.TTL = 2 To 30
   buf = String$(32, 0)
   If IcmpSendEcho(ICMPHandle, GetHostByNameAlias(host), buf, 32, IPOption, IPReply, Len(IPReply) + 8, 2700) = False Then
      GoTo EndEcho
   End If
   If HopCounter = 0 Then TraceRt = "Hop #0" Else TraceRt = TraceRt & vbCrLf & "Hop #" & HopCounter
   HopAddress = CStr(IPReply.Address(0)) & "." & CStr(IPReply.Address(1)) & "." & CStr(IPReply.Address(2)) & "." & CStr(IPReply.Address(3))
   TraceRt = TraceRt & "  " & HopAddress
   If HopAddress = host Then Exit For
   HopCounter = HopCounter + 1
EndEcho:
   If IPOption.TTL = 30 Then TraceRt = TraceRt & vbCrLf & "Trace Route to Long."
   DoEvents
Next IPOption.TTL

End Function

Public Function GetICMPError(Error As Integer) As String

Select Case Error
Case 11001: GetICMPError = "Buffer too Small"
Case 11002: GetICMPError = "Destination Network Not Reachable"
Case 11003: GetICMPError = "Destination Host Not Reachable"
Case 11004: GetICMPError = "Destination Protocol Not Reachable"
Case 11005: GetICMPError = "Destination Port Not Reachable"
Case 11006: GetICMPError = "No Resources Available"
Case 11007: GetICMPError = "Bad Option"
Case 11008: GetICMPError = "Hardware Error"
Case 11009: GetICMPError = "Packet too Big"
Case 11010: GetICMPError = "Request Timed Out"
Case 11011: GetICMPError = "Bad Request"
Case 11012: GetICMPError = "Bad Route"
Case 11013: GetICMPError = "TTL Expired in Transit"
Case 11014: GetICMPError = "TTL Expired Reassembly"
Case 11015: GetICMPError = "Parameter Problem"
Case 11016: GetICMPError = "Source Quench"
Case 11017: GetICMPError = "Option too Big"
Case 11018: GetICMPError = "Bad Destination"
Case 11019: GetICMPError = "Address Deleted"
Case 11020: GetICMPError = "Spec MTU Change"
Case 11021: GetICMPError = "MTU Change"
Case 11022: GetICMPError = "Unload"
Case 11050: GetICMPError = "General Failure"
End Select

End Function

Public Sub ClearSockAddr(sa As sockaddr)

MemCopy sa, ByVal String$(sockaddr_size, Chr$(0)), sockaddr_size

End Sub

Public Function SetWindowProc(hwnd&, Func&) As Long

If Func& Then
   SetWindowProc = SetWindowLong(hwnd&, GWL_WNDPROC, Func&)
Else
   SetWindowProc = SetWindowLong(hwnd&, GWL_WNDPROC, AddressOf WindowProc)
End If

End Function

Public Function HostByAddr$(ByVal addr$)
Dim host As HostEnt

a$ = Chr$(Val(parse$(addr$, ".")))
a$ = a$ + Chr$(Val(parse$(addr$, ".")))
a$ = a$ + Chr$(Val(parse$(addr$, ".")))
a$ = a$ + Chr$(Val(addr$))

hostent_addr& = gethostbyaddr(a$, Len(a$), 2)
If hostent_addr& = 0 Then HostByAddr$ = "": Exit Function

RtlMoveMemory host, hostent_addr&, LenB(host)

Dim c As String * 5
a$ = "": n% = 0
Do
   RtlMoveMemory ByVal c, host.h_name + n%, 1
   If Left$(c, 1) = Chr$(0) Then Exit Do
   a$ = a$ + Left$(c, 1): n% = n% + 1
Loop

HostByAddr$ = a$
End Function

Public Function HostByName$(na$, Optional adapter% = 0)
Dim host As HostEnt
Dim temp_ip_address() As Byte

hostent_addr& = gethostbyname(na$)
If hostent_addr& = 0 Then HostByName$ = "": Exit Function

RtlMoveMemory host, hostent_addr&, LenB(host)

For i% = 0 To adapter% 'Wenn schon eher ein Eintrag 0 ist, dann ist Adapter-Wert zu groß!
   RtlMoveMemory hostip_addr&, host.h_addr_list + 4 * i%, 4
   If hostip_addr& = 0 Then HostByName$ = "": Exit Function
Next

ReDim temp_ip_address(1 To host.h_length)
RtlMoveMemory temp_ip_address(1), hostip_addr&, host.h_length

ip_address$ = ""
For i = 1 To host.h_length
    ip_address$ = ip_address$ & temp_ip_address(i) & "."
Next
ip_address$ = Left$(ip_address$, Len(ip_address$) - 1)

HostByName$ = ip_address$
End Function

Private Function parse$(ByRef a$, ByVal s$)
If InStr(a$, s$) Then
   parse$ = Left$(a$, InStr(a$, s$) - 1): a$ = Mid$(a$, InStr(a$, s$) + Len(s$))
Else
   parse$ = a$: a$ = ""
End If
End Function

Public Function WindowProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

On Error GoTo WindowProcError

Dim WSAEvent As Long, WSAError As Long
WSAEvent = WSAGetSelectEvent(lParam)
WSAError = WSAGetAsyncError(lParam)
'Debug.Print "Message"; uMsg; ";"; wParam; ","; WSAEvent; ","; WSAError

If wParam = 0 Then Exit Function

Dim buflen As Long
Dim s As CSocket
Set s = Nothing
For n% = 1 To Sockets.Count
   If Sockets(n%).SocketHandle = wParam Then Set s = Sockets(n%)
Next
If s Is Nothing Then Exit Function

If uMsg = WM_TIMER Then
   KillTimer hwnd, wParam
   If s.State = sockConnecting Then s.WindowProc 0, "Timeout"
   Exit Function
ElseIf uMsg <> CSocketMsg Then
   If s.WindowProcOld Then WindowProc = CallWindowProc(s.WindowProcOld, hwnd, uMsg, wParam, ByVal lParam)
   Exit Function
End If

'Debug.Print "Socket"; wParam; ":"; WSAEvent '1=read 2=write 8=accecpt 16=connect 32=close
Select Case WSAEvent ' DeterMine Event
Case FD_CLOSE ' Socket Close
   s.WindowProc WSAEvent, 0
Case FD_CONNECT
   If WSAError = 0 Then ' No Error, Connected
      s.WindowProc WSAEvent, 0
   Else ' Error, Not Connected
      s.WindowProc 0, GetWSAErrorString$(WSAError&)
   End If
Case FD_ACCEPT
   s.WindowProc WSAEvent, 0
Case FD_READ
   Const Block = 2000
   'nur NT benötigt diese Schleife (Fehler?)
   'in Win9x geht's auch ohne, aber die Schleife stört nicht
   Do
      ReDim buf(0 To Block - 1) As Byte
      If s.SSLHandle = 0 Then
         buflen = recv(wParam, buf(0), Block, 0)
      Else
         buflen = ssl_recv(s.SSLHandle, buf(0), Block)
      End If
      'Debug.Print "..."; buflen
      If buflen <= 0 Then Exit Do
      If buflen < Block Then ReDim Preserve buf(0 To buflen - 1)
      s.WindowProc WSAEvent, buf
   Loop
Case FD_WRITE
   s.WindowProc WSAEvent, 0
End Select

WindowProcExit:
Exit Function

WindowProcError:
Debug.Print "WindowProcError> "; Error$(Err)
Resume WindowProcExit

End Function