Attribute VB_Name = "mod_WinSock2"
Option Explicit
Option Base 0

Private Declare Function gethostname Lib "wsock32.dll" (host_name As Any, ByVal namelen As Long) As Long
Private Declare Function WSAStartup Lib "ws2_32.dll" (ByVal wVR As Long, lpWSAD As WSAData) As Long
Public Declare Function WSTerminate Lib "ws2_32.dll" Alias "WSACleanup" () As Long
Private Declare Function ioctlsocket Lib "ws2_32.dll" (ByVal s As Long, ByVal cmd As Long, ByRef argp As Long) As Long
Private Declare Function htons Lib "ws2_32.dll" (ByVal hostshort As Integer) As Integer
Private Declare Function gethostbyname Lib "ws2_32.dll" (ByVal host_name As String) As Long
Private Declare Function inet_addr Lib "ws2_32.dll" (ByVal cp As String) As Long
Private Declare Function Socket Lib "ws2_32.dll" Alias "socket" (ByVal af As Long, ByVal s_type As Long, ByVal Protocol As Long) As Long
Private Declare Function closesocket Lib "ws2_32.dll" (ByVal hSocket As Long) As Long
Private Declare Function connect Lib "ws2_32.dll" (ByVal s As Long, ByRef name As sockaddr_in, ByVal namelen As Long) As Long
Private Declare Function recv Lib "ws2_32.dll" (ByVal hSocket As Long, ByRef buf As Any, ByVal buflen As Long, ByVal Flags As Long) As Long
Public Declare Function WSSend Lib "ws2_32.dll" Alias "send" (ByVal hSocket As Long, ByRef buf As Any, ByVal buflen As Long, ByVal Flags As Long) As Long
Private Declare Function WSACreateEvent Lib "ws2_32.dll" () As Long
Private Declare Function WSAResetEvent Lib "ws2_32.dll" (ByVal hEvent As Long) As Long
Private Declare Function WSASetEvent Lib "ws2_32.dll" (ByVal hEvent As Long) As Long
Private Declare Function WSAEventSelect Lib "ws2_32.dll" (ByVal hSocket As Long, ByVal hEventObject As Long, ByVal lNetworkEvents As Long) As Long
Private Declare Function WSAWaitForMultipleEvents Lib "ws2_32.dll" (ByVal cEvents As Long, ByVal ptrEventArray As Long, ByVal fWaitAll As Long, ByVal dwTimeout As Long, ByVal fAlertable As Long) As Long
Private Declare Function WSACloseEvent Lib "ws2_32.dll" (ByVal hEvent As Long) As Long

'ForServer:
Private Declare Function Bind Lib "ws2_32.dll" Alias "bind" (ByVal s As Long, ByRef name As sockaddr_in, ByRef namelen As Long) As Long
Private Declare Function Listen Lib "ws2_32.dll" Alias "listen" (ByVal s As Long, ByVal backlog As Long) As Long
Private Declare Function Accept Lib "ws2_32.dll" Alias "accept" (ByVal s As Long, addr As sockaddr_in, addrlen As Long) As Long

Private Declare Function LocalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal wBytes As Long) As Long
Private Declare Function LocalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Sub RtlMoveMemory Lib "kernel32" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)

Private Type WSAData
  WVersion As Integer
  WHighVersion As Integer
  szDescription As String * 257
  szSystemStatus As String * 129
  iMaxSockets As Integer
  iMaxUdpDg As Integer
  lpVendorInfo As Long
  End Type
Private Type sockaddr_in
  sin_family As Integer
  sin_port As Integer
  sin_addr As Long
  sin_zero As String * 8
  End Type

Public Function WSInit() As Boolean
  Dim WSAInfo As WSAData
  
  WSInit = (WSAStartup(&H101, WSAInfo) = 0&)
  End Function

Public Function WSConnect(ByVal Hostname As String, Optional ByVal Port As Long = 80&, Optional ByRef ptrhEventNew As Long) As Long

  Dim lngHostName As String
  Dim udtSockaddr As sockaddr_in
  Dim lngSocketHandle As Long
  Dim hEvent As Long

  If Not ptrhEventNew = 0& Then
    hEvent = WSACreateEvent
    If hEvent = 0& Then Exit Function
    End If

  lngSocketHandle = Socket(2&, 1&, 6&)  'inet / / TCP
  If lngSocketHandle > 0& Then
    lngHostName = inet_addr(Hostname)
    If Not lngHostName > 0& Then
      lngHostName = gethostbyname(Hostname)
      End If
    If lngHostName > 0& Then
      With udtSockaddr
        .sin_family = 2& 'inet
        .sin_addr = lngHostName
        .sin_port = htons(Port)   'Remember: Network byte order
        End With
      Call ioctlsocket(lngSocketHandle, &H8004667E, 0)
      If Not connect(lngSocketHandle, udtSockaddr, Len(udtSockaddr)) = -1 Then
        If Not ptrhEventNew = 0& Then
          If Not WSAEventSelect(lngSocketHandle, hEvent, 1&) = 0& Then
            Call WSClose(lngSocketHandle)
            GoTo Lbl1
            End If
          End If
        WSConnect = lngSocketHandle
        End If
      Call ioctlsocket(lngSocketHandle, &H8004667E, 1)
      End If
    End If

Lbl1:
  If Not ptrhEventNew = 0& Then
    If WSConnect = 0& Then
      Call WSACloseEvent(hEvent)
      hEvent = 0&
      End If
    Call RtlMoveMemory(ByVal ptrhEventNew, ByVal VarPtr(hEvent), 4&)
    End If
  End Function

Public Function WSReceive(ByVal hSocket As Long, ByRef xData As String, Optional ByVal hEvent As Long = 0&, Optional ByVal Timeout As Long = 5000&) As Boolean
  Const Max_Buffer_Length As Long = 8192
  Dim xLong1 As Long
  Dim xLong2 As Long
  Dim xChar1 As String

  xLong1 = LocalAlloc(0&, Max_Buffer_Length)
  If Not xLong1 = 0& Then
    Do
      If Not hEvent = 0& Then
        If WSAWaitForMultipleEvents(1&, VarPtr(hEvent), 0&, Timeout, 0&) = 258& Then
          Exit Do
          End If
        End If
      xLong2 = recv(hSocket, ByVal xLong1, Max_Buffer_Length, 0&)
      If xLong2 > 0& Then
        xChar1 = String(xLong2, vbNullChar)
        Call RtlMoveMemory(ByVal xChar1, ByVal xLong1, xLong2)
        xData = xData + xChar1
        WSReceive = True
        If Not xLong2 = Max_Buffer_Length Then Exit Do
        Else
        Exit Do
        End If
      Loop
    Call LocalFree(xLong1)
    End If
  If Not hEvent = 0& Then
    Call WSAResetEvent(hEvent)
    End If
  End Function

Public Function WSGetLocalName() As String
  WSGetLocalName = String(17&, vbNullChar) '15 max + 0char+x
  If gethostname(ByVal WSGetLocalName, 16&) = 0& Then
    WSGetLocalName = Left(WSGetLocalName, InStr(WSGetLocalName, vbNullChar) - 1&)
    If Len(WSGetLocalName) = 0& Then WSGetLocalName = "localhost"
    Else
    WSGetLocalName = "localhost"
    End If
  End Function

Public Function WSCreateServer(ByRef hEvent As Long, ByVal Port As Long, Optional ByVal Address As String = "127.0.0.1") As Long
  Dim xType1 As sockaddr_in

  hEvent = WSACreateEvent
  If Not hEvent = 0& Then
    WSCreateServer = Socket(2&, 1&, 6&)
    If WSCreateServer > 0& Then
      With xType1
        .sin_addr = inet_addr(Address)
        .sin_family = 2&
        .sin_port = htons(Port)
        End With
      If Bind(WSCreateServer, xType1, Len(xType1)) = 0& Then
        If WSAEventSelect(WSCreateServer, hEvent, 8&) = 0& Then
          If Listen(WSCreateServer, &H7FFFFFFF) = 0& Then
            Exit Function
            End If
          End If
        End If
      Call WSClose(WSCreateServer)
      End If
    Call WSACloseEvent(hEvent)
    End If
  hEvent = 0&
  WSCreateServer = 0&
  End Function

Public Function WSGetNewConnection(ByVal hSocket As Long, ByVal hEvent As Long, Optional ByRef ptrhEventNew As Long, Optional ByRef RemoteIP As String, Optional ByRef RemotePort As Long) As Long ', ByVal hEventNew As Long
  Dim hEventNew As Long
  Dim xType1 As sockaddr_in

  If Not WSAWaitForMultipleEvents(1, VarPtr(hEvent), 0&, 0&, 0&) = 258& Then
    If ptrhEventNew = 0& Then
      hEventNew = 1&
      Else
      hEventNew = WSACreateEvent
      End If
    WSGetNewConnection = Accept(hSocket, xType1, Len(xType1))
    If WSGetNewConnection > 0& Then
      Call ioctlsocket(WSGetNewConnection, &H8004667E, 1&)
      If Not ptrhEventNew = 0& Then
        If Not WSAEventSelect(WSGetNewConnection, hEventNew, 1&) = 0& Then
          GoTo Lbl1
          End If
        End If
      Call WSAResetEvent(hEvent)
      RemoteIP = CStr(xType1.sin_addr And &HFF&) + "." + CStr((xType1.sin_addr And &HFF00&) \ &H100&) + "." + CStr((xType1.sin_addr And &HFF0000) \ &H10000) + "." + CStr((&H100& + (&HFF000000 And &HFF000000) \ &H1000000) Mod &H100&)
      RemotePort = htons(xType1.sin_port)
      GoTo DoneEx
Lbl1:
      Call WSClose(WSGetNewConnection)
      End If
    If Not ptrhEventNew = 0& Then
      Call WSACloseEvent(hEventNew)
      hEventNew = 0&
      End If
    WSGetNewConnection = 0&
    End If
DoneEx:
  If Not ptrhEventNew = 0& Then
    Call RtlMoveMemory(ByVal ptrhEventNew, ByVal VarPtr(hEventNew), 4&)
    End If
  End Function

Public Sub WSClose(ByVal hSocket As Long, Optional ByVal hEvent As Long)
  If Not hEvent = 0& Then
    Call WSACloseEvent(hEvent)
    End If
  Call closesocket(hSocket)
  End Sub
