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" (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 send Lib "ws2_32.dll" (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 LocalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function LocalUnlock Lib "kernel32" (ByVal hMem 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

Private Type MySocketInfo
  hSocket As Long
  hEvent As Long
  End Type
Private Const MySocketInfoLen As Long = 8&

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&) As Long
  Dim lngHostName As String
  Dim udtSockaddr As sockaddr_in
  Dim xType1 As MySocketInfo
  Dim hMem As Long
  Dim hMem2 As Long

  hMem = LocalAlloc(2&, MySocketInfoLen)
  If Not hMem = 0& Then
    hMem2 = LocalLock(hMem)
    If Not hMem2 = 0& Then
      xType1.hEvent = WSACreateEvent
      If Not xType1.hEvent = 0& Then
        xType1.hSocket = socket(2&, 1&, 6&)   'inet / / TCP
        If xType1.hSocket > 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(xType1.hSocket, &H8004667E, 0&)
            If connect(xType1.hSocket, udtSockaddr, Len(udtSockaddr)) = 0& Then
              Call ioctlsocket(xType1.hSocket, &H8004667E, 1&)
              If WSAEventSelect(xType1.hSocket, xType1.hEvent, 1&) = 0& Then
                Call RtlMoveMemory(ByVal hMem2, xType1, MySocketInfoLen)
                Call LocalUnlock(hMem)
                WSConnect = hMem
                Exit Function
                End If
              End If
            End If
          Call closesocket(xType1.hSocket)
          End If
        Call WSACloseEvent(xType1.hEvent)
        End If
      Call LocalUnlock(hMem)
      End If
    Call LocalFree(hMem)
    End If
  End Function

Public Function WSSend(ByVal SocketInfo As Long, ByVal xData As String) As Boolean
  Dim xType1 As MySocketInfo
  Dim hMem2 As Long

  hMem2 = LocalLock(SocketInfo)
  If hMem2 Then
    Call RtlMoveMemory(xType1, ByVal hMem2, MySocketInfoLen)
    Call LocalUnlock(SocketInfo)
    
    WSSend = (send(xType1.hSocket, ByVal xData, Len(xData), 0&) = Len(xData))
    End If
  End Function

Public Function WSReceive(ByVal SocketInfo As Long, ByRef xData As String, Optional ByVal Timeout As Long = 5000&) As Boolean
  Dim xType1 As MySocketInfo
  Dim hMem2 As Long
  Dim xLong1 As Long
  Dim xChar1 As String
  Const Max_Buffer_Length As Long = 8192

  hMem2 = LocalLock(SocketInfo)
  If hMem2 Then
    Call RtlMoveMemory(xType1, ByVal hMem2, MySocketInfoLen)
    Call LocalUnlock(SocketInfo)
    
    
    hMem2 = LocalAlloc(0&, Max_Buffer_Length)
    If Not hMem2 = 0& Then
      Do
        If WSAWaitForMultipleEvents(1&, VarPtr(xType1.hEvent), 0&, Timeout, 0&) = 258& Then
          GoTo lbl1
          End If
        xLong1 = recv(xType1.hSocket, ByVal hMem2, Max_Buffer_Length, 0&)
        If xLong1 > 0& Then
          xChar1 = String(xLong1, vbNullChar)
          Call RtlMoveMemory(ByVal xChar1, ByVal hMem2, xLong1)
          xData = xData + xChar1
          WSReceive = True
          If Not xLong1 = Max_Buffer_Length Then Exit Do
          Else
          Exit Do
          End If
        Loop
      Call WSAResetEvent(xType1.hEvent)
lbl1:
      Call LocalFree(hMem2)
      End If
    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(ByVal Port As Long, Optional ByVal Address As String = "127.0.0.1") As Long
  Dim xType1 As MySocketInfo
  Dim xType2 As sockaddr_in
  Dim hMem As Long
  Dim hMem2 As Long

  hMem = LocalAlloc(2&, MySocketInfoLen)
  If Not hMem = 0& Then
    hMem2 = LocalLock(hMem)
    If Not hMem2 = 0& Then
      xType1.hEvent = WSACreateEvent
      If Not xType1.hEvent = 0& Then
        xType1.hSocket = socket(2&, 1&, 6&)
        If xType1.hSocket > 0& Then
          With xType2
            .sin_addr = inet_addr(Address)
            .sin_family = 2&
            .sin_port = htons(Port)
            End With
          If Bind(xType1.hSocket, xType2, Len(xType2)) = 0& Then
            If WSAEventSelect(xType1.hSocket, xType1.hEvent, 8&) = 0& Then
              If Listen(xType1.hSocket, &H7FFFFFFF) = 0& Then
                Call RtlMoveMemory(ByVal hMem2, xType1, MySocketInfoLen)
                Call LocalUnlock(hMem)
                WSCreateServer = hMem
                Exit Function
                End If
              End If
            End If
          Call WSClose(xType1.hSocket)
          End If
        Call WSACloseEvent(xType1.hEvent)
        End If
      Call LocalUnlock(hMem)
      End If
    Call LocalFree(hMem)
    End If
  End Function

Public Function WSGetNewConnection(ByVal SocketInfo As Long, Optional ByRef RemoteIP As String, Optional ByRef RemotePort As Long) As Long ', ByVal hEventNew As Long
  Dim xType1 As MySocketInfo
  Dim xType2 As MySocketInfo
  Dim xType3 As sockaddr_in
  Dim hMem As Long
  Dim hMem2 As Long

'Stop
  hMem2 = LocalLock(SocketInfo)
  If Not hMem2 = 0& Then
    Call RtlMoveMemory(xType1, ByVal hMem2, MySocketInfoLen)
    Call LocalUnlock(SocketInfo)
    
    hMem = LocalAlloc(2&, MySocketInfoLen)
    If Not hMem = 0& Then
      hMem2 = LocalLock(hMem)
      If Not hMem2 = 0& Then
        If Not WSAWaitForMultipleEvents(1, VarPtr(xType1.hEvent), 0&, 0&, 0&) = 258& Then
          xType2.hEvent = WSACreateEvent
          If Not xType2.hEvent = 0& Then
            xType2.hSocket = Accept(xType1.hSocket, xType3, Len(xType3))
            If xType2.hSocket > 0& Then
              Call ioctlsocket(xType2.hSocket, &H8004667E, 1&)
              If WSAEventSelect(xType2.hSocket, xType2.hEvent, 1&) = 0& Then
                RemoteIP = CStr(xType3.sin_addr And &HFF&) + "." + CStr((xType3.sin_addr And &HFF00&) \ &H100&) + "." + CStr((xType3.sin_addr And &HFF0000) \ &H10000) + "." + CStr((&H100& + (&HFF000000 And &HFF000000) \ &H1000000) Mod &H100&)
                RemotePort = htons(xType3.sin_port)
                Call WSAResetEvent(xType1.hEvent)
                Call RtlMoveMemory(ByVal hMem2, xType2, MySocketInfoLen)
                Call LocalUnlock(hMem)
                WSGetNewConnection = hMem
                Exit Function
                End If
              Call closesocket(xType2.hSocket)
              End If
            Call WSACloseEvent(xType2.hEvent)
            End If
          Call WSAResetEvent(xType1.hEvent)
          End If
        Call LocalUnlock(hMem)
        End If
      Call LocalFree(hMem)
      End If
    End If
  End Function

Public Sub WSClose(ByVal SocketInfo As Long)
  Dim xType1 As MySocketInfo
  Dim hMem2 As Long
  
  hMem2 = LocalLock(SocketInfo)
  If Not hMem2 = 0& Then
    Call RtlMoveMemory(xType1, ByVal hMem2, MySocketInfoLen)
    LocalUnlock SocketInfo
    LocalFree SocketInfo
    Call WSACloseEvent(xType1.hEvent)
    Call closesocket(xType1.hSocket)
    End If
  End Sub

