Leandro Ascierto

Este es un módulo para trabajar con los Socket de Windows, vendría a ser un reemplazo del WinSock.ocx, en este me he basado en el módulo de KPD-Team y lo reformé a mi gusto. Su uso creo, es muy sencillo y práctico, especialmente a la hora de trabajar con múltiples conexiones, si lo utilizan tal vez puedan encontrarse con algunas diferencias con respecto a la forma convencional de trabajo de como se utiliza con el WinSock.ocx.
A continuación voy a dejar dos ejemplos de uso, en el cual expliqué detalladamente, para su fácil entendimiento:
El primero trata de una conexión Cliente-Servidor de tipo Chat donde el Servidor puede escuchar en distintos puertos a la vez y aceptar varias conexiones al mismo tiempo, para la parte Cliente también puede realizar más de una conexión y en diferentes puertos a la vez.
El segundo se trata de una conexión Cliente-Servidor para Transferir Archivos.
Una cosa para resaltar, si es que lo van a usar, es que deben agregar manualmente las subrutinas comentadas en el final del módulo al formulario o módulo clase que llame a la función InitWinSock Me  del módulo WinSock32.
No lo he probado a full, pero creo que está funcionando perfectamente, cualquier inquietud, sugerencia o error pueden utilizar el sistema de comentarios.

Option Explicit

' --------------------------------------------------------------------
' Autor:     Leandro Ascierto
' WEB:       www.leandroascierto.com.ar
' Fecha:     09/07/2009
' Adaptado a mi gusto :)
' Basado en el módulo de KPD-Team  http://www.allapi.net/
'----------------------------------------------------------------------

Private Declare Function accept Lib "wsock32.dll" (ByVal s As Long, addr As SOCKADDR, addrlen As Long) As Long
Private Declare Function bind Lib "wsock32.dll" (ByVal s As Long, addr As SOCKADDR, ByVal namelen As Long) As Long
Private Declare Function closesocket Lib "wsock32.dll" (ByVal s As Long) As Long
Private Declare Function Connect Lib "wsock32.dll" Alias "connect" (ByVal s As Long, addr As SOCKADDR, ByVal namelen As Long) As Long
Private Declare Function htonl Lib "wsock32.dll" (ByVal hostlong As Long) As Long
Private Declare Function htons Lib "wsock32.dll" (ByVal hostshort As Long) As Integer
Private Declare Function inet_ntoa Lib "wsock32.dll" (ByVal inn As Long) As Long
Private Declare Function Listen Lib "wsock32.dll" Alias "listen" (ByVal s As Long, ByVal backlog As Long) As Long
Private Declare Function recv Lib "wsock32.dll" (ByVal s As Long, buf As Any, ByVal buflen As Long, ByVal Flags As Long) As Long
Private Declare Function Send Lib "wsock32.dll" Alias "send" (ByVal s As Long, buf As Any, ByVal buflen As Long, ByVal Flags As Long) As Long
Private Declare Function Socket Lib "wsock32.dll" Alias "socket" (ByVal af As Long, ByVal s_type As Long, ByVal protocol As Long) As Long
Private Declare Function gethostbyname Lib "wsock32.dll" (ByVal host_name As String) As Long
Private Declare Function gethostname Lib "wsock32.dll" (ByVal host_name As String, ByVal namelen As Long) As Long
Private Declare Function WSAStartup Lib "wsock32.dll" (ByVal wVR As Long, lpWSAD As WSADataType) As Long
Private Declare Function WSACleanup Lib "wsock32.dll" () As Long
Private Declare Function WSAIsBlocking Lib "wsock32.dll" () As Long
Private Declare Function WSACancelBlockingCall Lib "wsock32.dll" () As Long
Private Declare Function inet_addr Lib "wsock32.dll" (ByVal cp As String) As Long
Private Declare Function WSAAsyncSelect Lib "wsock32.dll" (ByVal s As Long, ByVal hWnd As Long, ByVal wMsg As Long, ByVal lEvent As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private 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
Private Declare Function DestroyWindow Lib "user32.dll" (ByVal hWnd As Long) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As Any) As Long
Private Declare Function GetTickCount Lib "kernel32.dll" () As Long
Private Declare Sub CopyMemoryIP Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)
Private Declare Sub MemCopy Lib "kernel32" Alias "RtlMoveMemory" (Dest As Any, Src As Any, ByVal cb As Long)
Private Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)

Private Type WSADataType
    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 HostEnt
    hName As Long
    hAliases As Long
    hAddrType As Integer
    hLen As Integer
    hAddrList As Long
End Type

Private Type SOCKADDR
    sin_family As Integer
    sin_port As Integer
    sin_addr As Long
    sin_zero As String * 8
End Type

Private Const WINSOCK_MESSAGE As Long = 1025
Private Const INADDR_NONE As Long = &HFFFF
Private Const INADDR_ANY As Long = &H0
Private Const IPPROTO_TCP As Long = 6
Private Const INVALID_SOCKET As Long = -1
Private Const SOCKET_ERROR As Long = -1
Private Const SOCK_STREAM As Long = 1
Private Const AF_INET As Long = 2
Private Const PF_INET As Long = 2
Private Const FD_READ As Long = &H1&
Private Const FD_WRITE As Long = &H2&
Private Const FD_OOB As Long = &H4&
Private Const FD_ACCEPT As Long = &H8&
Private Const FD_CONNECT As Long = &H10&
Private Const FD_CLOSE As Long = &H20&
Private Const GWL_WNDPROC As Long = (-4)

Private PrevProc As Long
Private bIsInit As Boolean
Private hWin As Long
Private m_ObjectHost As Object
Private TimeOut As Long

Public PortOpen  As Collection       ' Colección de los puertos abiertos, tiene como key el ID/Sesión de los puertos Abiertos.
Public PortSesion As Collection      ' Colección de los ID/Sesión de los puertos Abiertos.

Public Sockets As Collection         ' Colección de el ID/Sesión de las Conexiones establecidas.
Public IPAddresses As Collection     ' Colección de las IP de las Conexiones establecidas, tiene como key el ID/Sesión.
Public PortConection As Collection   ' Colección de los Puertos de las Conexiones establecidas, tiene como key el ID/Sesión.

Public CurrentSocketHandle As Long   ' ID de la última sesión activa.

' Esta función inicializa los Socket, debe hallarse al comienzo, y ObjectHost es el formulario o módulo clase que recibirá los Eventos/Mensajes
' En ese formulario o módulo clase deberán ir las líneas comentadas que se encuentran al final de este módulo.

Public Function InitWinSock(ObjectHost As Object) As Boolean
    Dim StartupData As WSADataType
    Set Sockets = New Collection
    Set IPAddresses = New Collection
    Set PortOpen = New Collection
    Set PortSesion = New Collection
    Set PortConection = New Collection

    Set m_ObjectHost = ObjectHost

    If Not bIsInit Then
        If Not WSAStartup(&H101, StartupData) Then
            bIsInit = True
            hWin = CreateWindowEx(0&, "STATIC", "SOCKET_WINDOW", 0&, 0&, 0&, 0&, 0&, 0&, 0&, App.hInstance, ByVal 0&)
            PrevProc = SetWindowLong(hWin, GWL_WNDPROC, AddressOf WindowProc)
        Else
            bIsInit = False
        End If
    End If

    InitWinSock = bIsInit

End Function

' Esta función es importante llamarla cuando se descarga el formulario, nunca cerrar el Visual Basic desde el Stop
' Sino no se ejecutara esta rutina, el IDE de Visual Basic se cerrará automáticamente dando lugar a no guardar los cambios.

Public Sub TerminateWinSock()

    Dim Ret As Long
    Dim Cnt As Long

    For Cnt = 1 To Sockets.Count
        WsClose Sockets.Item(1)
    Next

    For Cnt = 1 To PortSesion.Count
        closesocket PortSesion.Item(1)
        PortSesion.Remove (1)
        PortOpen.Remove (1)
    Next

    If WSAIsBlocking Then WSACancelBlockingCall

    Call WSACleanup

    bIsInit = False
    SetWindowLong hWin, GWL_WNDPROC, PrevProc
    DestroyWindow hWin

    Set Sockets = Nothing
    Set IPAddresses = Nothing
    Set PortConection = Nothing
    Set PortSesion = Nothing
    Set PortOpen = Nothing

End Sub

' Función para conectar, Host es la ip o el dsn a que se quiera conectar, y port el puerto.
' Si conecta la función retorna el ID de la sesión del Socket, de lo contrario 0.

Public Function WsConnect(ByVal Host As String, ByVal Port As Long) As Long

    Dim s As Long
    Dim Sockin As SOCKADDR

    Sockin.sin_family = AF_INET
    Sockin.sin_port = htons(Port)

    If Sockin.sin_port = INVALID_SOCKET Then Exit Function

    Sockin.sin_addr = GetHostByNameAlias(Host$)

    If Sockin.sin_addr = INADDR_NONE Then Exit Function

    s = Socket(PF_INET, SOCK_STREAM, IPPROTO_TCP)
    If s < 0 Then Exit Function

    If Connect(s, Sockin, 16) <> 0 Then
        If s Then closesocket s
        Exit Function
    End If

    If WSAAsyncSelect(s, hWin, ByVal WINSOCK_MESSAGE, ByVal FD_READ Or FD_WRITE Or FD_CONNECT Or FD_CLOSE) Then
        closesocket s
    Else
        IPAddresses.Add GetAscIp(Sockin.sin_addr), CStr(s)
        Sockets.Add s, CStr(s)
        PortConection.Add Port, CStr(s)
        CurrentSocketHandle = s
        WsConnect = s
    End If

End Function

' Función para poner a la escucha en determinado puerto.
' Si no ocurre ningún error y el puerto está disponible, la función retorna el ID de la sesión del Socket, de lo contrario 0.

Public Function WsListenInPort(ByVal Port As Long) As Long

    Dim s As Long
    Dim Sockin As SOCKADDR

    Sockin.sin_family = AF_INET
    Sockin.sin_port = htons(Port)

    If Sockin.sin_port = INVALID_SOCKET Then Exit Function

    Sockin.sin_addr = htonl(INADDR_ANY)

    If Sockin.sin_addr = INADDR_NONE Then Exit Function

    s = Socket(PF_INET, SOCK_STREAM, 0)
    If s < 0 Then Exit Function     If bind(s, Sockin, 16) Then         closesocket s         Exit Function     End If     If WSAAsyncSelect(s, hWin, ByVal WINSOCK_MESSAGE, ByVal FD_READ Or FD_WRITE Or FD_CLOSE Or FD_ACCEPT) Then         closesocket s         Exit Function     End If     If Listen(s, 1) Then         closesocket s     Else         WsListenInPort = s         PortOpen.Add Port, CStr(s)         PortSesion.Add s, CStr(s)     End If End Function ' Esta función Cierra un puerto previamente abierto, si se afirma ForceCloseConection, cerrará todas las conexiones establecidas en ese puerto ' de lo contrario, las conexiones que ya estaban establecidas permanecen y pueden seguir enviando mensajes, pero no se podrá hacer una nueva conexión a ese puerto ' si todo sale bien la funcion retorna True. Public Function WsClosePort(ByVal Port As Long, Optional ForceCloseConection As Boolean) As Boolean     On Error GoTo ErrOut     Dim s As Long     Dim Cnt As Long     For Cnt = 1 To PortOpen.Count         If PortOpen(Cnt) = Port Then             s = PortSesion(Cnt)             Exit For         End If     Next     If s = 0 Then Exit Function     closesocket s     PortSesion.Remove CStr(s)     PortOpen.Remove CStr(s)     If ForceCloseConection Then         For Cnt = Sockets.Count To 1 Step -1             If PortConection(Cnt) = Port Then                 WsClose Sockets(Cnt)             End If         Next     End If     WsClosePort = True     Exit Function ErrOut:     WsClosePort = False End Function ' Esta función envía datos al servidor, el primer parámetro es el ID de la sesión, la cual la podemos obtener de Sockets(index) ' o con CurrentSocketHandle que es el último ID de sesión activa. ' El segundo parámetro la data a enviar. ' Si el mensaje se envió con éxito la función devuelve True Public Function SendData(Socket As Long, Data As Variant) As Boolean     Dim Ret As Long     Dim TheMsg() As Byte, sTemp$     TheMsg = ""     Select Case VarType(Data)         Case 8209   'byte array             sTemp = Data             TheMsg = sTemp         Case 8      'String             sTemp = StrConv(Data, vbFromUnicode)         Case Else             sTemp = CStr(Data)             sTemp = StrConv(Data, vbFromUnicode)     End Select     TheMsg = sTemp     If UBound(TheMsg) > -1 Then
        Ret = Send(Socket, TheMsg(0), (UBound(TheMsg) - LBound(TheMsg) + 1), 0)

        If Ret = SOCKET_ERROR Then
            TimeOut = GetTickCount + 5000
            Do While Ret = SOCKET_ERROR
                Ret = Send(Socket, TheMsg(0), (UBound(TheMsg) - LBound(TheMsg) + 1), 0)
                DoEvents
                Sleep 10
                If TimeOut < GetTickCount Then Exit Do
            Loop
        End If
        SendData = Ret <> SOCKET_ERROR
    End If

End Function

' Esta función cierra la conexión indicada mediante el ID de sesión que se pase como parámetro
' el ID lo obtenemos de Sockets(index) o con CurrentSocketHandle que es el último ID de sesión activa.
' si todo sale bien la función retorna True.

Public Function WsClose(ByVal s As Long) As Boolean
On Local Error Resume Next
    WsClose = closesocket(s)
    IPAddresses.Remove CStr(s)
    Sockets.Remove CStr(s)
    PortConection.Remove CStr(s)
End Function

' Función que retorna la IP Local.
Public Function GetLocalIp() As String

    Dim sHostName As String * 256
    Dim lpHost As Long
    Dim Host As HostEnt
    Dim dwIPAddr As Long
    Dim tmpIPAddr() As Byte
    Dim i As Integer
    Dim sIPAddr As String

    lpHost = gethostbyname(sHostName)

    CopyMemoryIP Host, lpHost, Len(Host)
    CopyMemoryIP dwIPAddr, Host.hAddrList, 4
    ReDim tmpIPAddr(1 To Host.hLen)
    CopyMemoryIP tmpIPAddr(1), dwIPAddr, Host.hLen
    For i = 1 To Host.hLen
        sIPAddr = sIPAddr & tmpIPAddr(i) & "."
    Next
    GetLocalIp = Mid$(sIPAddr, 1, Len(sIPAddr) - 1)

End Function

' Función que retorna el Nombre de Host Local.

Public Function LocalHostName() As String
    Dim sHostName As String * 256
    If gethostname(sHostName, 256) <> INVALID_SOCKET Then
        LocalHostName = Trim$(sHostName)
    End If
End Function

' Función Privada del módulo.
Private Function WindowProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

On Local Error Resume Next

    If uMsg = WINSOCK_MESSAGE Then

        Dim mIP As String
        Dim mPuerto As String

        CurrentSocketHandle = wParam

        Select Case lParam

            Case FD_ACCEPT
                Dim s As Long, tempAddr As SOCKADDR
                s = accept(wParam, tempAddr, Len(tempAddr))

                mIP = GetAscIp(tempAddr.sin_addr)
                mPuerto = PortOpen(CStr(wParam))

                IPAddresses.Add mIP, CStr(s)
                Sockets.Add s, CStr(s)
                PortConection.Add mPuerto, CStr(s)

                Call m_ObjectHost.Socket_Conect(s, mIP, mPuerto)

            Case FD_CONNECT
                'Debug.Print "FD_CONNECT"

            Case FD_WRITE
                'Debug.Print "FD_WRITE"

            Case FD_READ
                Dim sTemp As String, lRet As Long, szBuf As String

                Do
                    szBuf = String(1024, 0)
                    lRet = recv(wParam, ByVal szBuf, Len(szBuf), 0)
                    If lRet > 0 Then sTemp = sTemp + Left$(szBuf, lRet)
                Loop Until lRet  0 Then
                    mIP = IPAddresses(CStr(wParam))
                    mPuerto = PortConection(CStr(wParam))
                    Call m_ObjectHost.Socket_DataArrival(wParam, mIP, mPuerto, sTemp)
                End If

            Case Else 'FD_CLOSE
                mPuerto = PortConection(CStr(wParam))
                mIP = IPAddresses(CStr(wParam))
                WsClose wParam
                Call m_ObjectHost.Socket_Close(wParam, mIP, mPuerto)

        End Select

    Else
        WindowProc = CallWindowProc(PrevProc, hWnd, uMsg, wParam, lParam)
    End If

End Function

' Función Privada del módulo.
Private Function GetHostByNameAlias(ByVal HostName As String) As Long

    On Error Resume Next
    Err.Clear

    Dim heDestHost As HostEnt
    Dim addrList As Long
    Dim retIP As Long
    Dim phe As Long

    retIP = inet_addr(HostName)

    If retIP = INADDR_NONE Then
        phe = gethostbyname(HostName)
        If phe <> 0 Then
            MemCopy heDestHost, ByVal phe, 16
            MemCopy addrList, ByVal heDestHost.hAddrList, 4
            MemCopy retIP, ByVal addrList, heDestHost.hLen
        Else
            retIP = INADDR_NONE
        End If
    End If

    GetHostByNameAlias = retIP

    If Err Then GetHostByNameAlias = INADDR_NONE
End Function

'Funcion Privada del módulo
Private 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 = "255.255.255.255"
        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 = "255.255.255.255"
End Function

'*=====================ATENCION=====ATENCION======ATENCION=======================*
'*===============================================================================*
'*===============================================================================*
'ESTAS LINEAS DEBEN IR EN EL FORMULARIO O MODULO CLASE DONDE RECIBIRAN LOS EVENTOS
'*===============================================================================*
'*===============================================================================*
'_________________________________________________________________________________________________

'Public Sub Socket_Conect(ID As Long, IP As String, Puerto As String)
'End Sub
'_________________________________________________________________________________________________

'Public Sub Socket_DataArrival(ID As Long, IP As String, Puerto As String, Data As String)
'End Sub
'_________________________________________________________________________________________________

'Public Sub Socket_Close(ID As Long, IP As String, Puerto As String)
'End Sub
'_________________________________________________________________________________________________

Ejemplo: Cliente – Servidor (Chat)

Ejemplo: Cliente – Servidor (Transferencia de archivos)