webnank

Webnank - Mungkin sudah terlalu basi membuat postingan tentang mig33 (yang sekarang berubah nama menjadi MigMe) karena user nya sendiri sudah kebanyakan berhenti (mungkin termasuk saya juga).
Makanya di blog ini pun saya tidak pernah membuat postingan yang berkaitan dengan MigMe , sangat berbeda dengan blog saya yang dulu http://mig33kertasemaya.blogspot.com (sudah saya tutup) yang postinganya 90% tentang Mig33.
Tapi berhubung ada yang meminta saya untuk membuat postingan ini, maka kali ini saya akan membahas tentang bagaimana sih cara membuat aplikasi MigMe itu, nah jika kita membicarakan aplikasi MigMe tentunya yang paling awal itu kita harus bisa membuat Login nya terlebih dahulu, untuk itu maka sekarang kita akan belajar membuat login MigMe.
Disini saya menggunakan Microsoft Visual Basic 6.0 dalam pembuatanya, jika belum tau apa itu Microsoft Visual Basic 6.0 (VB6) dan ingin mendownloadnya juga, kalian bisa baca di link ini Mengenal Visual Basic 6.0 dan Komponenya
Jika kalian sudah ada, dan buatlah project baru

Setelah open maka akan tampil project kosong, lalu silahkan kalian klik Project > References

Dan yang perlu kalian tandai disini adalah
Microsoft Internet Controls
Microsoft Scripting Runtime
Windows Script Host Object Model
lalu klik Ok

Setelah itu masukan 2 TextBox dan 2 CommondButton ke dalam Form

Lihatlah ke pojok kanan layar kalian, disitu ada Properties, nah silahkan kalian ubah properties dari komponen yang sudah kalian masukan, dengan cara klik komponen yang mau di ubah

Ubahlah seperti di bawah ini
Text1
Name = Username
Text = (kosongkan saja)

Text2
Name = Password
Text (kosongkan saja)
PasswordChar = *

Command1
Name = CmdLogin
Caption = Login

Command2
Name = CmdLogout
Caption = Logout

Sekarang coba lihat di pojok kanan atas, silahkan klik kanan pada Project > Add > Class Module

Maka akan mucul kolom kode yang masih kosong, maka paste kan coding di bawah ini

Option Explicit

'==============================================================================
'API FUNCTIONS
'==============================================================================

Private Declare Function api_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 api_GlobalLock Lib "kernel32" Alias "GlobalLock" (ByVal hMem As Long) As Long
Private Declare Function api_GlobalUnlock Lib "kernel32" Alias "GlobalUnlock" (ByVal hMem As Long) As Long
Private Declare Function api_htons Lib "ws2_32.dll" Alias "htons" (ByVal hostshort As Integer) As Integer
Private Declare Function api_ntohs Lib "ws2_32.dll" Alias "ntohs" (ByVal netshort As Integer) As Integer
Private Declare Function api_connect Lib "ws2_32.dll" Alias "connect" (ByVal s As Long, ByRef name As sockaddr_in, ByVal namelen As Long) As Long
Private Declare Function api_gethostname Lib "ws2_32.dll" Alias "gethostname" (ByVal host_name As String, ByVal namelen As Long) As Long
Private Declare Function api_gethostbyname Lib "ws2_32.dll" Alias "gethostbyname" (ByVal host_name As String) As Long
Private Declare Function api_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 api_getsockname Lib "ws2_32.dll" Alias "getsockname" (ByVal s As Long, ByRef name As sockaddr_in, ByRef namelen As Long) As Long
Private Declare Function api_getpeername Lib "ws2_32.dll" Alias "getpeername" (ByVal s As Long, ByRef name As sockaddr_in, ByRef namelen As Long) As Long
Private Declare Function api_inet_addr Lib "ws2_32.dll" Alias "inet_addr" (ByVal cp As String) As Long
Private Declare Function api_send Lib "ws2_32.dll" Alias "send" (ByVal s As Long, ByRef buf As Any, ByVal buflen As Long, ByVal flags As Long) As Long
Private Declare Function api_sendto Lib "ws2_32.dll" Alias "sendto" (ByVal s As Long, ByRef buf As Any, ByVal buflen As Long, ByVal flags As Long, ByRef toaddr As sockaddr_in, ByVal tolen As Long) As Long
Private Declare Function api_getsockopt Lib "ws2_32.dll" Alias "getsockopt" (ByVal s As Long, ByVal level As Long, ByVal optname As Long, optval As Any, optlen As Long) As Long
Private Declare Function api_setsockopt Lib "ws2_32.dll" Alias "setsockopt" (ByVal s As Long, ByVal level As Long, ByVal optname As Long, optval As Any, ByVal optlen As Long) As Long
Private Declare Function api_recv Lib "ws2_32.dll" Alias "recv" (ByVal s As Long, ByRef buf As Any, ByVal buflen As Long, ByVal flags As Long) As Long
Private Declare Function api_recvfrom Lib "ws2_32.dll" Alias "recvfrom" (ByVal s As Long, ByRef buf As Any, ByVal buflen As Long, ByVal flags As Long, ByRef from As sockaddr_in, ByRef fromlen As Long) As Long
Private Declare Function api_WSACancelAsyncRequest Lib "ws2_32.dll" Alias "WSACancelAsyncRequest" (ByVal hAsyncTaskHandle As Long) As Long
Private Declare Function api_listen Lib "ws2_32.dll" Alias "listen" (ByVal s As Long, ByVal backlog As Long) As Long
Private Declare Function api_accept Lib "ws2_32.dll" Alias "accept" (ByVal s As Long, ByRef addr As sockaddr_in, ByRef addrlen As Long) As Long
Private Declare Function api_inet_ntoa Lib "ws2_32.dll" Alias "inet_ntoa" (ByVal inn As Long) As Long
Private Declare Function api_ioctlsocket Lib "ws2_32.dll" Alias "ioctlsocket" (ByVal s As Long, ByVal cmd As Long, ByRef argp As Long) As Long
Private Declare Function api_closesocket Lib "ws2_32.dll" Alias "closesocket" (ByVal s As Long) As Long
'Private Declare Function api_gethostbyaddr Lib "ws2_32.dll" Alias "gethostbyaddr" (addr As Long, ByVal addr_len As Long, ByVal addr_type As Long) As Long

'==============================================================================
'CONSTANTS
'==============================================================================
Public Enum SockState
    sckClosed = 0
    sckOpen
    sckListening
    sckConnectionPending
    sckResolvingHost
    sckHostResolved
    sckConnecting
    sckConnected
    sckClosing
    sckError
End Enum

Private Const SOMAXCONN As Long = 5

Public Enum ProtocolConstants
    sckTCPProtocol = 0
    sckUDPProtocol = 1
End Enum

Private Const MSG_PEEK  As Long = &H2

'==============================================================================
'EVENTS
'==============================================================================

Public Event CloseSck(ByVal Index As Variant)
Public Event Connect(ByVal Index As Variant)
Public Event ConnectionRequest(ByVal Index As Variant, ByVal requestID As Long)
Public Event DataArrival(ByVal Index As Variant, ByVal bytesTotal As Long)
Public Event Error(ByVal Index As Variant, ByVal Number As Integer, Description As String, ByVal sCode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
Public Event SendComplete(ByVal Index As Variant)
Public Event SendProgress(ByVal Index As Variant, ByVal bytesSent As Long, ByVal bytesRemaining As Long)

'==============================================================================
'MEMBER VARIABLES
'==============================================================================

Private Type typSocket
    lngSocketHandle           As Long                 'socket handle
    enmState                  As SockState            'socket state
    strTag                    As String               'tag
    strRemoteHost             As String               'remote host
    lngRemotePort             As Long                 'remote port
    strRemoteHostIP           As String               'remote host ip
    lngLocalPort              As Long                 'local port
    lngLocalPortBind          As Long                 'temporary local port
    strLocalIP                As String               'local IP
    enmProtocol               As ProtocolConstants    'protocol used (TCP / UDP)
    lngMemoryPointer          As Long                 'memory pointer used as buffer when resolving host
    lngMemoryHandle           As Long                 'buffer memory handle
    strSendBuffer             As String               'local incoming buffer
    strRecvBuffer             As String               'local outgoing buffer
    lngSendBufferLen          As Long                 'winsock buffer size for sends
    lngRecvBufferLen          As Long                 'winsock buffer size for receives
    colWaitingResolutions     As Collection           'hosts waiting to be resolved by the system ("R" & async handle - destination)
    varUserIndex              As Variant              'user index, set by user (long or string)
End Type

Private m_colString_Index           As Collection   '(index: "I" & string index, item: socket index)
Private m_colUserIndex_Index        As Collection   '(index: "I" & user index, item: socket index)
Private m_colSockHandle_Index       As Collection   '(index: "S" & socket handle, item: socket index)
Private m_colWaitingResolutionsS    As Collection   '(index: "R" & async handle, item: socket index)

Private m_Socket() As typSocket 'socket array
Private m_EmptyIndex() As Long  'socket array empty indexes

Private m_blnAcceptClass As Boolean 'if True then this is an Accept socket class

'  ****  WARNING WARNING WARNING WARNING ******
'This sub MUST be the first on the class. DO NOT attempt
'to change it's location or the code will CRASH.
'This sub receives system messages from our WndProc.
Public Sub WndProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long)
On Error Resume Next
Select Case uMsg
Case RESOLVE_MESSAGE
    
    PostResolution wParam, ModSocketPlus.HiWord(lParam)
    
Case SOCKET_MESSAGE
    
    PostSocket wParam, LoWord(lParam), ModSocketPlus.HiWord(lParam)
    
End Select
End Sub

Private Sub Class_Initialize()

Set m_colSockHandle_Index = New Collection
Set m_colUserIndex_Index = New Collection
Set m_colString_Index = New Collection
Set m_colWaitingResolutionsS = New Collection

ReDim m_Socket(0) As typSocket
ReDim m_EmptyIndex(0) As Long

'initiate processes and winsock service
ModSocketPlus.InitiateProcesses
End Sub

Private Sub Class_Terminate()
Dim lngIndex As Long

'clean hostname resolution system
For lngIndex = 1 To UBound(m_Socket)
    CleanResolutionSystem lngIndex
Next

'destroy socket if it exists
If Not m_blnAcceptClass Then
    For lngIndex = 1 To UBound(m_Socket)
        DestroySocket lngIndex
    Next
End If

Erase m_Socket
Erase m_EmptyIndex

'clean processes and finish winsock service
ModSocketPlus.FinalizeProcesses

Set m_colSockHandle_Index = Nothing
Set m_colUserIndex_Index = Nothing
Set m_colString_Index = Nothing
Set m_colWaitingResolutionsS = Nothing

End Sub

'==============================================================================
'PROPERTIES
'==============================================================================

Public Property Get RemotePort(Index As Variant) As Long
RemotePort = m_Socket(GetSocketIndex(Index)).lngRemotePort
End Property

Public Property Let RemotePort(Index As Variant, ByVal lngPort As Long)
With m_Socket(GetSocketIndex(Index))
    If .enmProtocol = sckTCPProtocol And .enmState <> sckClosed Then
        Err.Raise sckInvalidOp, "CSocketPlus.RemotePort", "Invalid operation at current state"
    End If

If lngPort < 0 Or lngPort > 65535 Then
        Err.Raise sckInvalidArg, "CSocketPlus.RemotePort", "The argument passed to a function was not in the correct format or in the specified range."
    Else
    .lngRemotePort = lngPort
    End If
End With
End Property

Public Property Get RemoteHost(Index As Variant) As String
RemoteHost = m_Socket(GetSocketIndex(Index)).strRemoteHost
End Property

Public Property Let RemoteHost(Index As Variant, ByVal strHost As String)
With m_Socket(GetSocketIndex(Index))
    If .enmProtocol = sckTCPProtocol And .enmState <> sckClosed Then
        Err.Raise sckInvalidOp, "CSocketPlus.RemoteHost", "Invalid operation at current state"
    End If

.strRemoteHost = strHost
End With
End Property

Public Property Get RemoteHostIP(Index As Variant) As String
RemoteHostIP = m_Socket(GetSocketIndex(Index)).strRemoteHostIP
End Property

Public Property Get LocalPort(Index As Variant) As Long
With m_Socket(GetSocketIndex(Index))
    If .lngLocalPortBind = 0 Then
        LocalPort = .lngLocalPort
    Else
        LocalPort = .lngLocalPortBind
    End If
End With
End Property

Public Property Let LocalPort(Index As Variant, ByVal lngPort As Long)
With m_Socket(GetSocketIndex(Index))
    If .enmState <> sckClosed Then
        Err.Raise sckInvalidOp, "CSocketPlus.LocalPort", "Invalid operation at current state"
    End If
    If lngPort < 0 Or lngPort > 65535 Then
        Err.Raise sckInvalidArg, "CSocketPlus.LocalPort", "The argument passed to a function was not in the correct format or in the specified range."
    Else
        .lngLocalPort = lngPort
    End If
End With
End Property

Public Property Get State(Index As Variant) As SockState
State = m_Socket(GetSocketIndex(Index)).enmState
End Property

Public Property Get LocalHostName() As String
LocalHostName = GetLocalHostName
End Property

Public Property Get LocalIP(Index As Variant) As String
With m_Socket(GetSocketIndex(Index))
    If .enmState = sckConnected Then
        LocalIP = .strLocalIP
    Else
        LocalIP = GetLocalIP
    End If
End With
End Property

Public Property Get BytesReceived(Index As Variant) As Long
Dim lngIndex As Long
lngIndex = GetSocketIndex(Index)

If m_Socket(lngIndex).enmProtocol = sckTCPProtocol Then
    BytesReceived = Len(m_Socket(lngIndex).strRecvBuffer)
Else
    BytesReceived = GetBufferLenUDP(lngIndex)
End If

End Property

Public Property Get SocketHandle(Index As Variant) As Long
SocketHandle = m_Socket(GetSocketIndex(Index)).lngSocketHandle
End Property

Public Property Get Tag(Index As Variant) As String
Tag = m_Socket(GetSocketIndex(Index)).strTag
End Property

Public Property Let Tag(Index As Variant, ByVal strTag As String)
m_Socket(GetSocketIndex(Index)).strTag = strTag
End Property

Public Property Get Protocol(Index As Variant) As ProtocolConstants
Protocol = m_Socket(GetSocketIndex(Index)).enmProtocol
End Property

Public Property Let Protocol(Index As Variant, ByVal enmProtocol As ProtocolConstants)
With m_Socket(GetSocketIndex(Index))
    If .enmState <> sckClosed Then
        Err.Raise sckInvalidOp, "CSocketPlus.Protocol", "Invalid operation at current state"
    Else
        .enmProtocol = enmProtocol
    End If
End With
End Property

Public Sub Accept(Index As Variant, requestID As Long)

Dim lngIndex As Long
lngIndex = GetSocketIndex(Index)

With m_Socket(lngIndex)

If .enmState <> sckClosed Then
        Err.Raise sckInvalidOp, "CSocketPlus.Accept", "Invalid operation at current state"
    End If

m_Socket(lngIndex).lngSocketHandle = requestID
    .enmProtocol = sckTCPProtocol
    ProcessOptions lngIndex

If Not ModSocketPlus.IsAcceptRegistered(requestID) Then
        If IsSocketRegistered(requestID) Then
            .lngSocketHandle = INVALID_SOCKET
            .lngRecvBufferLen = 0
            .lngSendBufferLen = 0
            Err.Raise sckBadState, "CSocketPlus.Accept", "Wrong protocol or connection state for the requested transaction or request"
        Else
            m_blnAcceptClass = True
            .enmState = sckConnected: Debug.Print "STATE: sckConnected"
            GetLocalInfo .lngSocketHandle, .lngLocalPortBind, .strLocalIP
            ModSocketPlus.RegisterSocket .lngSocketHandle, ObjPtr(Me), False
            Exit Sub
        End If
    End If

Dim clsSocket As CSocketPlus
    Set clsSocket = ModSocketPlus.GetAcceptClass(requestID)
    ModSocketPlus.UnregisterAccept requestID

GetLocalInfo .lngSocketHandle, .lngLocalPortBind, .strLocalIP
    GetRemoteInfo .lngSocketHandle, .lngRemotePort, .strRemoteHostIP, .strRemoteHost
    
    .enmState = sckConnected: Debug.Print "STATE: sckConnected"

If clsSocket.BytesReceived("Temporal_Socket") > 0 Then
        clsSocket.GetData "Temporal_Socket", .strRecvBuffer
    End If
    
    m_colSockHandle_Index.Add lngIndex, "S" & requestID
    ModSocketPlus.Subclass_ChangeOwner requestID, ObjPtr(Me)

If Len(.strRecvBuffer) > 0 Then RaiseEvent DataArrival(.varUserIndex, Len(.strRecvBuffer))

If clsSocket.State("Temporal_Socket") = sckClosing Then
        .enmState = sckClosing: Debug.Print "STATE: sckClosing"
        RaiseEvent CloseSck(.varUserIndex)
    End If

Set clsSocket = Nothing
End With
End Sub

'Create a new element in the socket array.
'Returns de index used. This can be used in case the
'user didn't pass the Index argument.
Public Function ArrayAdd(Optional Index As Variant) As Variant

On Error GoTo Error_Handler

Dim lngIndex As Long
lngIndex = GetFreeSocketIndex

m_Socket(lngIndex).lngSocketHandle = INVALID_SOCKET
Set m_Socket(lngIndex).colWaitingResolutions = New Collection
    
If IsMissing(Index) Then
    Dim Cont As Long
    
    Do
        Cont = Cont + 1
    Loop Until Not IsUserIndexRegistered(Cont)
        
    m_colUserIndex_Index.Add lngIndex, "I" & Cont
    
    m_Socket(lngIndex).varUserIndex = Cont
    ArrayAdd = Cont
    Debug.Print "OK Added '" & Cont & "' to the socket array"
Else
    m_Socket(lngIndex).varUserIndex = Index
    ArrayAdd = Index
    Select Case varType(Index)
    Case vbString
        m_colString_Index.Add lngIndex, "I" & Index
    Case vbInteger To vbLong
        m_colUserIndex_Index.Add lngIndex, "I" & Index
    Case Else
        Err.Raise sckWrongIndex, "CSocketPlus.ArrayAdd", "Unsupported index type."
    End Select
        
    Debug.Print "OK Added '" & Index & "' to the socket array"
End If

Exit Function

Error_Handler:
    Dim lngErrorCode As Long
    Dim strErrorDesc As String
    
    lngErrorCode = Err.Number
    strErrorDesc = Err.Description
    
    If lngErrorCode = 457 Then
        lngErrorCode = sckUsedIndex
        strErrorDesc = "This index is already associated with an element of this array."
    End If
    
    CleanSocketArray lngIndex
    Err.Raise lngErrorCode, "CSocketPlus.ArrayAdd", strErrorDesc
End Function

'Remove an element in the socket array
Public Function ArrayRemove(Index As Variant) As Variant
Dim lngIndex As Long
lngIndex = GetSocketIndex(Index)

CloseSck Index
    
Select Case varType(Index)
Case vbString
    m_colString_Index.Remove "I" & Index
Case vbInteger To vbLong
    m_colUserIndex_Index.Remove "I" & Index
Case Else
    Err.Raise sckWrongIndex, "CSocketPlus.ArrayRemove", "Unsupported index type."
End Select

CleanSocketArray lngIndex

ArrayRemove = Index

Debug.Print "OK Removed '" & Index & "' from the socket array"
End Function

'Returns TRUE if the index passed is in use by the array
Public Function ArrayIndexInUse(Index As Variant) As Boolean
On Error GoTo Error_Handler

GetSocketIndex Index
ArrayIndexInUse = True

Exit Function
Error_Handler:

Dim lngErrorCode As Long
    Dim strErrorDesc As String
    
    lngErrorCode = Err.Number
    strErrorDesc = Err.Description
    
    Const strSource As String = "CSocketPlus.ArrayIndexInUse"
    
    If Err.Number = sckWrongIndex Then
        Err.Raise sckWrongIndex, strSource, "Unsupported index type."
    ElseIf Err.Number = sckMissingIndex Then
        ArrayIndexInUse = False
    Else
        Err.Raise lngErrorCode, strSource, strErrorDesc
    End If

End Function

'Returns amount of 'sockets' created by user.
Public Function ArrayCount() As Long
ArrayCount = m_colString_Index.Count + m_colUserIndex_Index.Count
End Function

Public Sub Bind(Index As Variant, Optional LocalPort As Variant, Optional LocalIP As Variant)
Dim lngIndex As Long
lngIndex = GetSocketIndex(Index)

If m_Socket(lngIndex).enmState <> sckClosed Then
    Err.Raise sckInvalidOp, "CSocketPlus.Bind", "Invalid operation at current state"
End If

If BindInternal(lngIndex, LocalPort, LocalIP) Then
    m_Socket(lngIndex).enmState = sckOpen: Debug.Print "STATE: sckOpen"
End If
End Sub

Public Sub CloseSck(Index As Variant)
Dim lngIndex As Long
lngIndex = GetSocketIndex(Index)

With m_Socket(lngIndex)
    If .lngMemoryHandle = INVALID_SOCKET Then Exit Sub

.enmState = sckClosing: Debug.Print "STATE: sckClosing"
    CleanResolutionSystem lngIndex
    DestroySocket GetSocketIndex(Index)

.lngLocalPortBind = 0
    .strRemoteHostIP = ""
    .strRecvBuffer = ""
    .strSendBuffer = ""
    .lngSendBufferLen = 0
    .lngRecvBufferLen = 0
    .enmState = sckClosed: Debug.Print "STATE: sckClosed"
End With

End Sub

'Tries to connect to RemoteHost if it was passed, or uses
'm_strRemoteHost instead. If it is a hostname tries to
'resolve it first.
Public Sub Connect(Index As Variant, Optional RemoteHost As Variant, Optional RemotePort As Variant)
Dim lngIndex As Long
lngIndex = GetSocketIndex(Index)
If m_Socket(lngIndex).enmState <> sckClosed Then
    Err.Raise sckInvalidOp, "CSocketPlus.Connect", "Invalid operation at current state"
End If

If Not IsMissing(RemoteHost) Then
        m_Socket(lngIndex).strRemoteHost = CStr(RemoteHost)
End If

'for some reason we get a GPF if we try to
'resolve a null string, so we replace it with
'an empty string
If m_Socket(lngIndex).strRemoteHost = vbNullString Then
    m_Socket(lngIndex).strRemoteHost = ""
End If

'check if RemotePort is a number between 1 and 65535
If Not IsMissing(RemotePort) Then
    If IsNumeric(RemotePort) Then
        If CLng(RemotePort) > 65535 Or CLng(RemotePort) < 1 Then
            Err.Raise sckInvalidArg, "CSocketPlus.Connect", "The argument passed to a function was not in the correct format or in the specified range."
        Else
            m_Socket(lngIndex).lngRemotePort = CLng(RemotePort)
        End If
    Else
        Err.Raise sckUnsupported, "CSocketPlus.Connect", "Unsupported variant type."
    End If
End If

'create a socket if there isn't one yet
If Not SocketExists(lngIndex) Then Exit Sub

'Here we bind the socket
If Not BindInternal(lngIndex) Then Exit Sub

'If we are using UDP we just exit silently.
'Remember UDP is a connectionless protocol.
If m_Socket(lngIndex).enmProtocol = sckUDPProtocol Then
    m_Socket(lngIndex).enmState = sckOpen: Debug.Print "STATE: sckOpen"
    Exit Sub
End If

'try to get a 32 bits long that is used to identify a host
Dim lngAddress As Long
lngAddress = ResolveIfHostname(lngIndex, m_Socket(lngIndex).strRemoteHost)

'We've got two options here:
'1) m_strRemoteHost was an IP, so a resolution wasn't
'   necessary, and now lngAddress is a 32 bits long and
'   we proceed to connect.
'2) m_strRemoteHost was a hostname, so a resolution was
'   necessary and it's taking place right now. We leave
'   silently.

If lngAddress <> vbNull Then
    ConnectToIP lngIndex, lngAddress, 0
End If

End Sub

Public Sub GetData(Index As Variant, ByRef data As Variant, Optional varType As Variant, Optional maxLen As Variant)

Dim lngIndex As Long
lngIndex = GetSocketIndex(Index)

If m_Socket(lngIndex).enmProtocol = sckTCPProtocol Then
    If m_Socket(lngIndex).enmState <> sckConnected And Not m_blnAcceptClass Then
        Err.Raise sckBadState, "CSocketPlus.GetData", "Wrong protocol or connection state for the requested transaction or request"
        Exit Sub
    End If
Else
    If m_Socket(lngIndex).enmState <> sckOpen Then
        Err.Raise sckBadState, "CSocketPlus.GetData", "Wrong protocol or connection state for the requested transaction or request"
        Exit Sub
    End If
    If GetBufferLenUDP(lngIndex) = 0 Then Exit Sub
End If

If Not IsMissing(maxLen) Then
    If IsNumeric(maxLen) Then
        If CLng(maxLen) < 0 Then
            Err.Raise sckInvalidArg, "CSocketPlus.GetData", "The argument passed to a function was not in the correct format or in the specified range."
        End If
    Else
        If m_Socket(lngIndex).enmProtocol = sckTCPProtocol Then
            maxLen = Len(m_Socket(lngIndex).strRecvBuffer)
        Else
            maxLen = GetBufferLenUDP(lngIndex)
        End If
    End If
End If

Dim lngBytesRecibidos  As Long

lngBytesRecibidos = RecvData(lngIndex, data, False, varType, maxLen)
Debug.Print "OK Bytes obtained from buffer: " & lngBytesRecibidos

End Sub

Public Sub Listen(Index As Variant)
Dim lngIndex As Long
lngIndex = GetSocketIndex(Index)

If m_Socket(lngIndex).enmState <> sckClosed And m_Socket(lngIndex).enmState <> sckOpen Then
    Err.Raise sckInvalidOp, "CSocketPlus.Listen", "Invalid operation at current state"
End If

If Not SocketExists(lngIndex) Then Exit Sub
If Not BindInternal(lngIndex) Then Exit Sub

Dim lngResult As Long

lngResult = api_listen(m_Socket(lngIndex).lngSocketHandle, SOMAXCONN)

If lngResult = SOCKET_ERROR Then
    Dim lngErrorCode As Long
    lngErrorCode = Err.LastDllError
    Err.Raise lngErrorCode, "CSocketPlus.Listen", GetErrorDescription(lngErrorCode)
Else
    m_Socket(lngIndex).enmState = sckListening: Debug.Print "STATE: sckListening"
End If

End Sub

Public Sub PeekData(Index As Variant, ByRef data As Variant, Optional varType As Variant, Optional maxLen As Variant)

Dim lngIndex As Long
lngIndex = GetSocketIndex(Index)

If m_Socket(lngIndex).enmProtocol = sckTCPProtocol Then
    If m_Socket(lngIndex).enmState <> sckConnected Then
        Err.Raise sckBadState, "CSocketPlus.PeekData", "Wrong protocol or connection state for the requested transaction or request"
        Exit Sub
    End If
Else
    If m_Socket(lngIndex).enmState <> sckOpen Then
        Err.Raise sckBadState, "CSocketPlus.PeekData", "Wrong protocol or connection state for the requested transaction or request"
        Exit Sub
    End If
    If GetBufferLenUDP(lngIndex) = 0 Then Exit Sub
End If

If Not IsMissing(maxLen) Then
    If IsNumeric(maxLen) Then
        If CLng(maxLen) < 0 Then
            Err.Raise sckInvalidArg, "CSocketPlus.PeekData", "The argument passed to a function was not in the correct format or in the specified range."
        End If
    Else
        If m_Socket(lngIndex).enmProtocol = sckTCPProtocol Then
            maxLen = Len(m_Socket(lngIndex).strRecvBuffer)
        Else
            maxLen = GetBufferLenUDP(lngIndex)
        End If
    End If
End If

Dim lngBytesRecibidos  As Long

lngBytesRecibidos = RecvData(data, True, varType, maxLen)
Debug.Print "OK Bytes obtained from buffer: " & lngBytesRecibidos
End Sub

Public Sub SendData(Index As Variant, data As Variant)
On Error Resume Next
Dim lngIndex As Long
lngIndex = GetSocketIndex(Index)

Dim arrData() As Byte 'We store the data here before send it

If m_Socket(lngIndex).enmProtocol = sckTCPProtocol Then
    If m_Socket(lngIndex).enmState <> sckConnected Then
        Err.Raise sckBadState, "CSocketPlus.SendData", "Wrong protocol or connection state for the requested transaction or request"
        Exit Sub
    End If
Else 'If we use UDP we create a socket if there isn't one yet
    If Not SocketExists(lngIndex) Then Exit Sub
    If Not BindInternal(lngIndex) Then Exit Sub
    m_Socket(lngIndex).enmState = sckOpen: Debug.Print "STATE: sckOpen"
End If

'We need to convert data variant into a byte array
Select Case varType(data)
        Case vbString
            Dim strData As String
            strData = CStr(data)
            If Len(strData) = 0 Then Exit Sub
            ReDim arrData(Len(strData) - 1)
            arrData() = StrConv(strData, vbFromUnicode)
        Case vbArray + vbByte
            Dim strArray As String
            strArray = StrConv(data, vbUnicode)
            If Len(strArray) = 0 Then Exit Sub
            arrData() = StrConv(strArray, vbFromUnicode)
        Case vbBoolean
            Dim blnData As Boolean
            blnData = CBool(data)
            ReDim arrData(LenB(blnData) - 1)
            api_CopyMemory arrData(0), blnData, LenB(blnData)
        Case vbByte
            Dim bytData As Byte
            bytData = CByte(data)
            ReDim arrData(LenB(bytData) - 1)
            api_CopyMemory arrData(0), bytData, LenB(bytData)
        Case vbCurrency
            Dim curData As Currency
            curData = CCur(data)
            ReDim arrData(LenB(curData) - 1)
            api_CopyMemory arrData(0), curData, LenB(curData)
        Case vbDate
            Dim datData As Date
            datData = CDate(data)
            ReDim arrData(LenB(datData) - 1)
            api_CopyMemory arrData(0), datData, LenB(datData)
        Case vbDouble
            Dim dblData As Double
            dblData = CDbl(data)
            ReDim arrData(LenB(dblData) - 1)
            api_CopyMemory arrData(0), dblData, LenB(dblData)
        Case vbInteger
            Dim intData As Integer
            intData = CInt(data)
            ReDim arrData(LenB(intData) - 1)
            api_CopyMemory arrData(0), intData, LenB(intData)
        Case vbLong
            Dim lngData As Long
            lngData = CLng(data)
            ReDim arrData(LenB(lngData) - 1)
            api_CopyMemory arrData(0), lngData, LenB(lngData)
        Case vbSingle
            Dim sngData As Single
            sngData = CSng(data)
            ReDim arrData(LenB(sngData) - 1)
            api_CopyMemory arrData(0), sngData, LenB(sngData)
        Case Else
            Err.Raise sckUnsupported, "CSocketPlus.SendData", "Unsupported variant type."
    End Select

'if there's already something in the buffer that means we are
'already sending data, so we put the new data in the buffer
'and exit silently
If Len(m_Socket(lngIndex).strSendBuffer) > 0 Then
    m_Socket(lngIndex).strSendBuffer = m_Socket(lngIndex).strSendBuffer + StrConv(arrData(), vbUnicode)
    Exit Sub
Else
    m_Socket(lngIndex).strSendBuffer = m_Socket(lngIndex).strSendBuffer + StrConv(arrData(), vbUnicode)
End If

'send the data
SendBufferedData lngIndex

End Sub

'Destroys the socket if it exists and unregisters it
'from control list.
Private Sub DestroySocket(ByVal Index As Long)
If Not m_Socket(Index).lngSocketHandle = INVALID_SOCKET Then

Dim lngResult As Long
    
    lngResult = api_closesocket(m_Socket(Index).lngSocketHandle) ' m_lngSocketHandle)
    
    If lngResult = SOCKET_ERROR Then
        
        m_Socket(Index).enmState = sckError: Debug.Print "STATE: sckError"
        Dim lngErrorCode As Long
        lngErrorCode = Err.LastDllError
        Err.Raise lngErrorCode, "CSocketPlus.DestroySocket", GetErrorDescription(lngErrorCode)
    
    Else
        
        Debug.Print "OK Destroyed socket " & m_Socket(Index).lngSocketHandle
        ModSocketPlus.UnregisterSocket m_Socket(Index).lngSocketHandle
        m_colSockHandle_Index.Remove "S" & m_Socket(Index).lngSocketHandle
        m_Socket(Index).lngSocketHandle = INVALID_SOCKET
    End If

End If
End Sub

'Tries to create a socket if there isn't one yet and registers
'it to the control list.
'Returns TRUE if it has success
Private Function SocketExists(ByVal lngIndex As Long) As Boolean
SocketExists = True
Dim lngResult As Long
Dim lngErrorCode As Long

'check if there is a socket already
If m_Socket(lngIndex).lngSocketHandle = INVALID_SOCKET Then
    
    'decide what kind of socket we are creating, TCP or UDP
    If m_Socket(lngIndex).enmProtocol = sckTCPProtocol Then
        lngResult = api_socket(AF_INET, SOCK_STREAM, IPPROTO_TCP)
    Else
        lngResult = api_socket(AF_INET, SOCK_DGRAM, IPPROTO_UDP)
    End If
    
    If lngResult = INVALID_SOCKET Then
        
        m_Socket(lngIndex).enmState = sckError: Debug.Print "STATE: sckError"
        Debug.Print "ERROR trying to create socket"
        SocketExists = False
        lngErrorCode = Err.LastDllError
        Dim blnCancelDisplay As Boolean
        blnCancelDisplay = True
        RaiseEvent Error(m_Socket(lngIndex).varUserIndex, lngErrorCode, GetErrorDescription(lngErrorCode), 0, "CSocketPlus.SocketExists", "", 0, blnCancelDisplay)
        If blnCancelDisplay = False Then MsgBox GetErrorDescription(lngErrorCode), vbOKOnly, "CSocketPlus.SocketExists"
    Else
        
        Debug.Print "OK Created socket: " & lngResult
        m_colSockHandle_Index.Add lngIndex, "S" & lngResult
        m_Socket(lngIndex).lngSocketHandle = lngResult
        'set and get some socket options
        ProcessOptions lngIndex
        SocketExists = ModSocketPlus.RegisterSocket(m_Socket(lngIndex).lngSocketHandle, ObjPtr(Me), True)
    
    End If
End If
End Function

'When the system resolves a hostname in asynchronous way we
'call this function to decide what to do with the result.
Private Sub PostResolution(ByVal lngAsynHandle As Long, ByVal lngErrorCode As Long)
Dim lngIndex As Long

'find out which socket requested the host resolution
lngIndex = m_colWaitingResolutionsS.Item("R" & lngAsynHandle)
m_colWaitingResolutionsS.Remove ("R" & lngAsynHandle)

'erase that record from the collection since we won't need it any longer
m_Socket(lngIndex).colWaitingResolutions.Remove "R" & lngAsynHandle
UnregisterResolution lngAsynHandle

If m_Socket(lngIndex).enmState <> sckResolvingHost Then Exit Sub

If lngErrorCode = 0 Then 'if there weren't errors trying to resolve the hostname
    
     m_Socket(lngIndex).enmState = sckHostResolved: Debug.Print "STATE: sckHostResolved"
    
    Dim udtHostent As HOSTENT
    Dim lngPtrToIP As Long
    Dim arrIpAddress(1 To 4) As Byte
    Dim lngRemoteHostAddress As Long
    Dim Count As Integer
    Dim strIpAddress As String
    
    api_CopyMemory udtHostent, ByVal m_Socket(lngIndex).lngMemoryPointer, LenB(udtHostent)
    api_CopyMemory lngPtrToIP, ByVal udtHostent.hAddrList, 4
    api_CopyMemory arrIpAddress(1), ByVal lngPtrToIP, 4
    api_CopyMemory lngRemoteHostAddress, ByVal lngPtrToIP, 4
    
    'free memory, won't need it any longer
    FreeMemory lngIndex
    
    'We turn the 32 bits long into a readable string.
    'Note: we don't need this string. I put this here just
    'in case you need it.
    For Count = 1 To 4
        strIpAddress = strIpAddress & arrIpAddress(Count) & "."
    Next
        
    strIpAddress = Left$(strIpAddress, Len(strIpAddress) - 1)
    
    ConnectToIP lngIndex, lngRemoteHostAddress, 0

Else 'there were errors trying to resolve the hostname

'free buffer memory
    FreeMemory lngIndex
 
    ConnectToIP lngIndex, vbNull, lngErrorCode
        
End If
End Sub

'This procedure is called by the WindowProc callback function.
'The lngEventID argument is an ID of the network event
'occurred for the socket. The lngErrorCode argument contains
'an error code only if an error was occurred during an
'asynchronous execution.
Private Sub PostSocket(ByVal lngSocketHandle As Long, ByVal lngEventID As Long, ByVal lngErrorCode As Long)

Dim lngIndex As Long
'find out which socket the message belongs to
lngIndex = m_colSockHandle_Index.Item("S" & lngSocketHandle)

Dim blnCancelDisplay As Boolean

'handle any possible error
If lngErrorCode <> 0 Then
    m_Socket(lngIndex).enmState = sckError: Debug.Print "STATE: sckError"
    blnCancelDisplay = True
    RaiseEvent Error(m_Socket(lngIndex).varUserIndex, lngErrorCode, GetErrorDescription(lngErrorCode), 0, "CSocketPlus.PostSocket", "", 0, blnCancelDisplay)
    If blnCancelDisplay = False Then MsgBox GetErrorDescription(lngErrorCode), vbOKOnly, "CSocketPlus.PostSocket"
    Exit Sub
End If

Dim udtSockAddr As sockaddr_in
Dim lngResult As Long
Dim lngBytesReceived As Long

Select Case lngEventID

'======================================================================

Case FD_CONNECT

'Arrival of this message means that the connection initiated by the call
    'of the connect Winsock API function was successfully established.

Debug.Print "FD_CONNECT " & m_Socket(lngIndex).lngSocketHandle
    
    If m_Socket(lngIndex).enmState <> sckConnecting Then
        Debug.Print "WARNING: Omitting FD_CONNECT"
        Exit Sub
    End If
    
    'Get the local parameters
    GetLocalInfo m_Socket(lngIndex).lngSocketHandle, m_Socket(lngIndex).lngLocalPortBind, m_Socket(lngIndex).strLocalIP
    
    'Get the connection local end-point parameters
    GetRemoteInfo m_Socket(lngIndex).lngSocketHandle, m_Socket(lngIndex).lngRemotePort, m_Socket(lngIndex).strRemoteHostIP, m_Socket(lngIndex).strRemoteHost
    
    m_Socket(lngIndex).enmState = sckConnected: Debug.Print "STATE: sckConnected"
    RaiseEvent Connect(m_Socket(lngIndex).varUserIndex)

'======================================================================

Case FD_WRITE

'This message means that the socket in a write-able
    'state, that is, buffer for outgoing data of the transport
    'service is empty and ready to receive data to send through
    'the network.
    
    Debug.Print "FD_WRITE " & m_Socket(lngIndex).lngSocketHandle
    
    If m_Socket(lngIndex).enmState <> sckConnected Then
        Debug.Print "WARNING: Omitting FD_WRITE"
        Exit Sub
    End If
    
    If Len(m_Socket(lngIndex).strSendBuffer) > 0 Then
        SendBufferedData lngIndex
    End If
    
'======================================================================

Case FD_READ

'Some data has arrived for this socket.

Debug.Print "FD_READ " & m_Socket(lngIndex).lngSocketHandle
    
    If m_Socket(lngIndex).enmProtocol = sckTCPProtocol Then
        
        If m_Socket(lngIndex).enmState <> sckConnected Then
            Debug.Print "WARNING: Omitting FD_READ"
            Exit Sub
        End If
        
        'Call the RecvDataToBuffer function that move arrived data
        'from the Winsock buffer to the local one and returns number
        'of bytes received.
    
        lngBytesReceived = RecvDataToBuffer(lngIndex)
    
        If lngBytesReceived > 0 Then
            RaiseEvent DataArrival(m_Socket(lngIndex).varUserIndex, Len(m_Socket(lngIndex).strRecvBuffer))
        End If
    
    Else 'UDP protocol
        
        If m_Socket(lngIndex).enmState <> sckOpen Then
            Debug.Print "WARNING: Omitting FD_READ"
            Exit Sub
        End If
        
        'If we use UDP we don't remove data from winsock buffer.
        'We just let the user know the amount received so
        'he/she can decide what to do.
        
        lngBytesReceived = GetBufferLenUDP(lngIndex)
        
        If lngBytesReceived > 0 Then
            RaiseEvent DataArrival(m_Socket(lngIndex).varUserIndex, lngBytesReceived)
        End If
        
        
        'Now the buffer is emptied no matter what the user
        'dicided to do with the received data
        EmptyBuffer lngIndex
    End If
    
    
'======================================================================

Case FD_ACCEPT

'When the socket is in a listening state, arrival of this message
    'means that a connection request was received. Call the accept
    'Winsock API function in oreder to create a new socket for the
    'requested connection.
  
    Debug.Print "FD_ACCEPT " & m_Socket(lngIndex).lngSocketHandle
    If m_Socket(lngIndex).enmState <> sckListening Then
        Debug.Print "WARNING: Omitting FD_ACCEPT"
        Exit Sub
    End If
    
    lngResult = api_accept(m_Socket(lngIndex).lngSocketHandle, udtSockAddr, LenB(udtSockAddr))
    
    If lngResult = INVALID_SOCKET Then
        lngErrorCode = Err.LastDllError
        m_Socket(lngIndex).enmState = sckError: Debug.Print "STATE: sckError"
        blnCancelDisplay = True
        RaiseEvent Error(m_Socket(lngIndex).varUserIndex, lngErrorCode, GetErrorDescription(lngErrorCode), 0, "CSocketPlus.PostSocket", "", 0, blnCancelDisplay)
        If blnCancelDisplay = False Then MsgBox GetErrorDescription(lngErrorCode), vbOKOnly, "CSocketPlus.PostSocket"
    Else
        'We assign a temporal instance of CSocketPlus to
        'handle this new socket until user accepts (or not)
        'the new connection
        ModSocketPlus.RegisterAccept lngResult
        
        'We change remote info before firing ConnectionRequest
        'event so the user can see which host is trying to
        'connect.
        With m_Socket(lngIndex)
            Dim lngTempRP As Long
            Dim strTempRHIP As String
            Dim strTempRH As String
            lngTempRP = .lngRemotePort
            strTempRHIP = .strRemoteHostIP
            strTempRH = .strRemoteHost
        
            GetRemoteInfo lngResult, .lngRemotePort, .strRemoteHostIP, .strRemoteHost
        
            Debug.Print "OK Accepted socket: " & lngResult
            RaiseEvent ConnectionRequest(.varUserIndex, lngResult)
        
            'we return original info
            If .enmState = sckListening Then
                .lngRemotePort = lngTempRP
                .strRemoteHostIP = strTempRHIP
                .strRemoteHost = strTempRH
            End If
        End With
        'This is very important. If the connection wasn't accepted
        'we must close the socket.
        If IsAcceptRegistered(lngResult) Then
            api_closesocket lngResult
            ModSocketPlus.UnregisterSocket lngResult
            ModSocketPlus.UnregisterAccept lngResult
            Debug.Print "OK Closed accepted socket: " & lngResult
        End If
    End If
    
'======================================================================
    
Case FD_CLOSE
    
    'This message means that the remote host is closing the conection
    
    Debug.Print "FD_CLOSE " & m_Socket(lngIndex).lngSocketHandle
    
    If m_Socket(lngIndex).enmState <> sckConnected Then
        Debug.Print "WARNING: Omitting FD_CLOSE"
        Exit Sub
    End If
    
    m_Socket(lngIndex).enmState = sckClosing: Debug.Print "STATE: sckClosing"
    RaiseEvent CloseSck(m_Socket(lngIndex).varUserIndex)
    
End Select
End Sub

'Connect to a given 32 bits long ip
Private Sub ConnectToIP(ByVal lngIndex As Long, ByVal lngRemoteHostAddress As Long, ByVal lngErrorCode As Long)

Dim blnCancelDisplay As Boolean

'Check and handle errors
If lngErrorCode <> 0 Then
    m_Socket(lngIndex).enmState = sckError: Debug.Print "STATE: sckError"
    blnCancelDisplay = True
    RaiseEvent Error(m_Socket(lngIndex).varUserIndex, lngErrorCode, GetErrorDescription(lngErrorCode), 0, "CSocketPlus.ConnectToIP", "", 0, blnCancelDisplay)
    If blnCancelDisplay = False Then MsgBox GetErrorDescription(lngErrorCode), vbOKOnly, "CSocketPlus.ConnectToIP"
    Exit Sub
End If

Debug.Print "OK Connecting to: " + m_Socket(lngIndex).strRemoteHost + " " + m_Socket(lngIndex).strRemoteHostIP
m_Socket(lngIndex).enmState = sckConnecting: Debug.Print "STATE: sckConnecting"

Dim udtSockAddr As sockaddr_in
Dim lngResult As Long

'Build the sockaddr_in structure to pass it to the connect
'Winsock API function as an address of the remote host.
With udtSockAddr
    .sin_addr = lngRemoteHostAddress
    .sin_family = AF_INET
    .sin_port = api_htons(ModSocketPlus.UnsignedToInteger(m_Socket(lngIndex).lngRemotePort))
End With

'Call the connect Winsock API function in order to establish connection.
lngResult = api_connect(m_Socket(lngIndex).lngSocketHandle, udtSockAddr, LenB(udtSockAddr))

'Check and handle errors
If lngResult = SOCKET_ERROR Then
    lngErrorCode = Err.LastDllError
    If lngErrorCode <> WSAEWOULDBLOCK Then
        If lngErrorCode = WSAEADDRNOTAVAIL Then
            Err.Raise WSAEADDRNOTAVAIL, "CSocketPlus.ConnectToIP", GetErrorDescription(WSAEADDRNOTAVAIL)
        Else
            m_Socket(lngIndex).enmState = sckError: Debug.Print "STATE: sckError"
            blnCancelDisplay = True
            RaiseEvent Error(m_Socket(lngIndex).varUserIndex, lngErrorCode, GetErrorDescription(lngErrorCode), 0, "CSocketPlus.ConnectToIP", "", 0, blnCancelDisplay)
            If blnCancelDisplay = False Then MsgBox GetErrorDescription(lngErrorCode), vbOKOnly, "CSocketPlus.ConnectToIP"
        End If
    End If
End If

End Sub

'This function binds a socket to a local port and IP.
'Retunrs TRUE if it has success.
Private Function BindInternal(ByVal lngIndex As Long, Optional ByVal varLocalPort As Variant, Optional ByVal varLocalIP As Variant) As Boolean
If m_Socket(lngIndex).enmState = sckOpen Then
    BindInternal = True
    Exit Function
End If

Dim lngLocalPortInternal As Long
Dim strLocalHostInternal As String
Dim strIP As String
Dim lngAddressInternal As Long
Dim lngResult As Long
Dim lngErrorCode As Long

BindInternal = False

'Check if varLocalPort is a number between 0 and 65535
If Not IsMissing(varLocalPort) Then
    
    If IsNumeric(varLocalPort) Then
        If varLocalPort < 0 Or varLocalPort > 65535 Then
            BindInternal = False
            Err.Raise sckInvalidArg, "CSocketPlus.BindInternal", "The argument passed to a function was not in the correct format or in the specified range."
        Else
            lngLocalPortInternal = CLng(varLocalPort)
        End If
    Else
        BindInternal = False
        Err.Raise sckUnsupported, "CSocketPlus.BindInternal", "Unsupported variant type."
    End If
    
Else
    
    lngLocalPortInternal = m_Socket(lngIndex).lngLocalPort
    
End If

If Not IsMissing(varLocalIP) Then
    If varLocalIP <> vbNullString Then
        strLocalHostInternal = CStr(varLocalIP)
    Else
        strLocalHostInternal = ""
    End If
Else
    strLocalHostInternal = ""
End If

'get a 32 bits long IP
lngAddressInternal = ResolveIfHostnameSync(strLocalHostInternal, strIP, lngResult)

If lngResult <> 0 Then
    Err.Raise sckInvalidArg, "CSocketPlus.BindInternal", "Invalid argument"
End If

'create a socket if there isn't one yet
If Not SocketExists(lngIndex) Then Exit Function

Dim udtSockAddr As sockaddr_in

With udtSockAddr
    .sin_addr = lngAddressInternal
    .sin_family = AF_INET
    .sin_port = api_htons(ModSocketPlus.UnsignedToInteger(lngLocalPortInternal))
End With

'bind the socket
lngResult = api_bind(m_Socket(lngIndex).lngSocketHandle, udtSockAddr, LenB(udtSockAddr))

If lngResult = SOCKET_ERROR Then

lngErrorCode = Err.LastDllError
    Err.Raise lngErrorCode, "CSocketPlus.BindInternal", GetErrorDescription(lngErrorCode)
    
Else

If lngLocalPortInternal <> 0 Then
    
        Debug.Print "OK Bind HOST: " & strLocalHostInternal & " PORT: " & lngLocalPortInternal
        m_Socket(lngIndex).lngLocalPort = lngLocalPortInternal
        
    Else
        lngResult = GetLocalPort(m_Socket(lngIndex).lngSocketHandle)
        
        If lngResult = SOCKET_ERROR Then
            lngErrorCode = Err.LastDllError
            Err.Raise lngErrorCode, "CSocketPlus.BindInternal", GetErrorDescription(lngErrorCode)
        Else
            Debug.Print "OK Bind HOST: " & strLocalHostInternal & " PORT: " & lngResult
            m_Socket(lngIndex).lngLocalPortBind = lngResult
        End If
        
    End If
    
    BindInternal = True
End If
End Function

'Allocate some memory for HOSTEN structure and returns
'a pointer to this buffer if no error occurs.
'Returns 0 if it fails.
Private Function AllocateMemory(ByVal lngIndex As Long) As Long
With m_Socket(lngIndex)
    .lngMemoryHandle = api_GlobalAlloc(GMEM_FIXED, MAXGETHOSTSTRUCT)

If .lngMemoryHandle <> 0 Then
        .lngMemoryPointer = api_GlobalLock(.lngMemoryHandle)
    
        If .lngMemoryPointer <> 0 Then
            api_GlobalUnlock (.lngMemoryHandle)
            AllocateMemory = .lngMemoryPointer
        Else
            api_GlobalFree (.lngMemoryHandle)
            AllocateMemory = .lngMemoryPointer '0
        End If

Else
        AllocateMemory = m_Socket(lngIndex).lngMemoryHandle '0
    End If
End With
End Function

'Free memory allocated by AllocateMemory
Private Sub FreeMemory(ByVal lngIndex As Long)
With m_Socket(lngIndex)
    If .lngMemoryHandle <> 0 Then
        .lngMemoryPointer = 0
        api_GlobalFree .lngMemoryHandle
        .lngMemoryHandle = 0
        Debug.Print "OK Freed resolution memory"
    End If
End With
End Sub

Private Function GetLocalHostName() As String
Dim strHostNameBuf As String * LOCAL_HOST_BUFF
Dim lngResult As Long

lngResult = api_gethostname(strHostNameBuf, LOCAL_HOST_BUFF)

If lngResult = SOCKET_ERROR Then
    GetLocalHostName = vbNullString
    Dim lngErrorCode As Long
    lngErrorCode = Err.LastDllError
    Err.Raise lngErrorCode, "CSocketPlus.GetLocalHostName", GetErrorDescription(lngErrorCode)
Else
    GetLocalHostName = Left(strHostNameBuf, InStr(1, strHostNameBuf, vbNullChar) - 1)
End If
End Function

'Get local IP when the socket isn't connected yet
Private Function GetLocalIP() As String
Dim lngResult As Long
Dim lngPtrToIP As Long
Dim strLocalHost As String
Dim arrIpAddress(1 To 4) As Byte
Dim Count As Integer
Dim udtHostent As HOSTENT
Dim strIpAddress As String

strLocalHost = GetLocalHostName

lngResult = api_gethostbyname(strLocalHost)

If lngResult = 0 Then
    GetLocalIP = vbNullString
    Dim lngErrorCode As Long
    lngErrorCode = Err.LastDllError
    Err.Raise lngErrorCode, "CSocketPlus.GetLocalIP", GetErrorDescription(lngErrorCode)
Else
    api_CopyMemory udtHostent, ByVal lngResult, LenB(udtHostent)
    api_CopyMemory lngPtrToIP, ByVal udtHostent.hAddrList, 4
    api_CopyMemory arrIpAddress(1), ByVal lngPtrToIP, 4
   
    For Count = 1 To 4
        strIpAddress = strIpAddress & arrIpAddress(Count) & "."
    Next
   
    strIpAddress = Left$(strIpAddress, Len(strIpAddress) - 1)
    GetLocalIP = strIpAddress
End If
End Function

'If Host is an IP doesn't resolve anything and returns a
'a 32 bits long IP.
'If Host isn't an IP then returns vbNull, tries to resolve it
'in asynchronous way.
Private Function ResolveIfHostname(ByVal lngIndex As Long, ByVal Host As String) As Long
Dim lngAddress As Long
lngAddress = api_inet_addr(Host)

If lngAddress = INADDR_NONE Then 'if Host isn't an IP
    
    ResolveIfHostname = vbNull
    m_Socket(lngIndex).enmState = sckResolvingHost: Debug.Print "STATE: sckResolvingHost"
    
    If AllocateMemory(lngIndex) Then
        
        Dim lngAsynHandle As Long
        lngAsynHandle = ModSocketPlus.ResolveHost(Host, m_Socket(lngIndex).lngMemoryPointer, ObjPtr(Me))
        
        If lngAsynHandle = 0 Then
            FreeMemory lngIndex
            m_Socket(lngIndex).enmState = sckError: Debug.Print "STATE: sckError"
            Dim lngErrorCode As Long
            lngErrorCode = Err.LastDllError
            Dim blnCancelDisplay As Boolean
            blnCancelDisplay = True
            RaiseEvent Error(m_Socket(lngIndex).varUserIndex, lngErrorCode, GetErrorDescription(lngErrorCode), 0, "CSocketPlus.ResolveIfHostname", "", 0, blnCancelDisplay)
            If blnCancelDisplay = False Then MsgBox GetErrorDescription(lngErrorCode), vbOKOnly, "CSocketPlus.ResolveIfHostname"
        Else
            m_Socket(lngIndex).colWaitingResolutions.Add lngAsynHandle, "R" & lngAsynHandle
            m_colWaitingResolutionsS.Add lngIndex, "R" & lngAsynHandle
            Debug.Print "Resolving host " & Host; " with handle " & lngAsynHandle
        End If
        
    Else
        
        m_Socket(lngIndex).enmState = sckError: Debug.Print "STATE: sckError"
        Debug.Print "Error trying to allocate memory"
        Err.Raise sckOutOfMemory, "CSocketPlus.ResolveIfHostname", "Out of memory"
        
    End If
    
Else 'if Host is an IP doen't need to resolve anything
    ResolveIfHostname = lngAddress
End If
End Function

'Resolves a host (if necessary) in synchronous way
'If succeeds returns a 32 bits long IP,
'strHostIP = readable IP string and lngErrorCode = 0
'If fails returns vbNull,
'strHostIP = vbNullString and lngErrorCode <> 0
Private Function ResolveIfHostnameSync(ByVal Host As String, ByRef strHostIP As String, ByRef lngErrorCode As Long) As Long
Dim lngPtrToHOSTENT As Long
Dim udtHostent As HOSTENT
Dim lngAddress As Long
Dim lngPtrToIP As Long
Dim arrIpAddress(1 To 4) As Byte
Dim Count As Integer

lngAddress = api_inet_addr(Host)

If lngAddress = INADDR_NONE Then 'if Host isn't an IP
    
    lngPtrToHOSTENT = api_gethostbyname(Host)
    
    If lngPtrToHOSTENT = 0 Then
        lngErrorCode = Err.LastDllError
        strHostIP = vbNullString
        ResolveIfHostnameSync = vbNull
    Else
        api_CopyMemory udtHostent, ByVal lngPtrToHOSTENT, LenB(udtHostent)
        api_CopyMemory lngPtrToIP, ByVal udtHostent.hAddrList, 4
        api_CopyMemory arrIpAddress(1), ByVal lngPtrToIP, 4
        api_CopyMemory lngAddress, ByVal lngPtrToIP, 4
        
        For Count = 1 To 4
            strHostIP = strHostIP & arrIpAddress(Count) & "."
        Next
        
        strHostIP = Left$(strHostIP, Len(strHostIP) - 1)
        
        lngErrorCode = 0
        ResolveIfHostnameSync = lngAddress
    End If
    
Else 'if Host is an IP doen't need to resolve anything
    
    lngErrorCode = 0
    strHostIP = Host
    ResolveIfHostnameSync = lngAddress
    
End If
End Function

'Returns local port from a connected or bound socket.
'Returns SOCKET_ERROR if fails.
Private Function GetLocalPort(ByVal lngSocket As Long) As Long
Dim udtSockAddr As sockaddr_in
Dim lngResult As Long

lngResult = api_getsockname(lngSocket, udtSockAddr, LenB(udtSockAddr))

If lngResult = SOCKET_ERROR Then
    GetLocalPort = SOCKET_ERROR
Else
    GetLocalPort = ModSocketPlus.IntegerToUnsigned(api_ntohs(udtSockAddr.sin_port))
End If
End Function

'Check which protocol we are using to decide which
'function should handle the data sending.
Private Sub SendBufferedData(ByVal lngIndex As Long)
If m_Socket(lngIndex).enmProtocol = sckTCPProtocol Then
    SendBufferedDataTCP lngIndex
Else
    SendBufferedDataUDP lngIndex
End If
End Sub

'Send buffered data if we are using UDP protocol.
Private Sub SendBufferedDataUDP(ByVal lngIndex As Long)
Dim lngAddress As Long
Dim udtSockAddr As sockaddr_in
Dim arrData() As Byte
Dim lngBufferLength As Long
Dim lngResult As Long
Dim lngErrorCode As Long

Dim strTemp As String
lngAddress = ResolveIfHostnameSync(m_Socket(lngIndex).strRemoteHost, strTemp, lngErrorCode)
    
If lngErrorCode <> 0 Then
    m_Socket(lngIndex).strSendBuffer = ""
    
    If lngErrorCode = WSAEAFNOSUPPORT Then
        Err.Raise lngErrorCode, "CSocketPlus.SendBufferedDataUDP", GetErrorDescription(lngErrorCode)
    Else
        Err.Raise sckInvalidArg, "CSocketPlus.SendBufferedDataUDP", "Invalid argument"
    End If
End If

With udtSockAddr
    .sin_addr = lngAddress
    .sin_family = AF_INET
    .sin_port = api_htons(ModSocketPlus.UnsignedToInteger(m_Socket(lngIndex).lngRemotePort))
End With
    
lngBufferLength = Len(m_Socket(lngIndex).strSendBuffer)
    
arrData() = StrConv(m_Socket(lngIndex).strSendBuffer, vbFromUnicode)
    
m_Socket(lngIndex).strSendBuffer = ""

lngResult = api_sendto(m_Socket(lngIndex).lngSocketHandle, arrData(0), lngBufferLength, 0&, udtSockAddr, LenB(udtSockAddr))
    
If lngResult = SOCKET_ERROR Then
    lngErrorCode = Err.LastDllError
    m_Socket(lngIndex).enmState = sckError: Debug.Print "STATE: sckError"
    Dim blnCancelDisplay As Boolean
    blnCancelDisplay = True
    RaiseEvent Error(m_Socket(lngIndex).varUserIndex, lngErrorCode, GetErrorDescription(lngErrorCode), 0, "CSocketPlus.SendBufferedDataUDP", "", 0, blnCancelDisplay)
    If blnCancelDisplay = False Then MsgBox GetErrorDescription(lngErrorCode), vbOKOnly, "CSocketPlus.SendBufferedDataUDP"
End If
    
End Sub

'Send buffered data if we are using TCP protocol.
Private Sub SendBufferedDataTCP(ByVal lngIndex As Long)

Dim arrData()       As Byte
Dim lngBufferLength As Long
Dim lngResult    As Long
Dim lngTotalSent As Long

With m_Socket(lngIndex)

Do Until lngResult = SOCKET_ERROR Or Len(.strSendBuffer) = 0

lngBufferLength = Len(.strSendBuffer)

If lngBufferLength > .lngSendBufferLen Then
            lngBufferLength = .lngSendBufferLen
            arrData() = StrConv(Left$(.strSendBuffer, .lngSendBufferLen), vbFromUnicode)
        Else
            arrData() = StrConv(.strSendBuffer, vbFromUnicode)
        End If

lngResult = api_send(.lngSocketHandle, arrData(0), lngBufferLength, 0&)

If lngResult = SOCKET_ERROR Then
            Dim lngErrorCode As Long
            lngErrorCode = Err.LastDllError
    
            If lngErrorCode = WSAEWOULDBLOCK Then
                Debug.Print "WARNING: Send buffer full, waiting..."
                If lngTotalSent > 0 Then RaiseEvent SendProgress(.varUserIndex, lngTotalSent, Len(.strSendBuffer))
            Else
                .enmState = sckError: Debug.Print "STATE: sckError"
                Dim blnCancelDisplay As Boolean
                blnCancelDisplay = True
                RaiseEvent Error(.varUserIndex, lngErrorCode, GetErrorDescription(lngErrorCode), 0, "CSocketPlus.SendBufferedData", "", 0, blnCancelDisplay)
                If blnCancelDisplay = False Then MsgBox GetErrorDescription(lngErrorCode), vbOKOnly, "CSocketPlus.SendBufferedData"
            End If

Else
            Debug.Print "OK Bytes sent: " & lngResult
            lngTotalSent = lngTotalSent + lngResult
            If Len(.strSendBuffer) > lngResult Then
                .strSendBuffer = Mid$(.strSendBuffer, lngResult + 1)
            Else
                Debug.Print "OK Finished SENDING"
                .strSendBuffer = ""
                Dim lngTemp As Long
                lngTemp = lngTotalSent
                lngTotalSent = 0
                RaiseEvent SendProgress(.varUserIndex, lngTemp, 0)
                RaiseEvent SendComplete(.varUserIndex)
            End If
        End If

Loop
    
End With

End Sub

'This function retrieves data from the Winsock buffer
'into the class local buffer. The function returns number
'of bytes retrieved (received).
Private Function RecvDataToBuffer(ByVal lngIndex As Long) As Long
Dim arrBuffer() As Byte
Dim lngBytesReceived As Long
Dim strBuffTemporal As String

With m_Socket(lngIndex)

ReDim arrBuffer(.lngRecvBufferLen - 1)

lngBytesReceived = api_recv(.lngSocketHandle, arrBuffer(0), .lngRecvBufferLen, 0&)

If lngBytesReceived = SOCKET_ERROR Then
    
        .enmState = sckError: Debug.Print "STATE: sckError"
        Dim lngErrorCode As Long
        lngErrorCode = Err.LastDllError
        Err.Raise lngErrorCode, "CSocketPlus.RecvDataToBuffer", GetErrorDescription(lngErrorCode)
    
    ElseIf lngBytesReceived > 0 Then
    
        strBuffTemporal = StrConv(arrBuffer(), vbUnicode)
        .strRecvBuffer = .strRecvBuffer & Left$(strBuffTemporal, lngBytesReceived)
        RecvDataToBuffer = lngBytesReceived
    
    End If

End With
End Function

'Retrieves some socket options.
'If it is an UDP socket also sets SO_BROADCAST option.
Private Sub ProcessOptions(ByVal lngIndex As Long)
Dim lngResult As Long
Dim lngBuffer As Long
Dim lngErrorCode As Long

With m_Socket(lngIndex)

If .enmProtocol = sckTCPProtocol Then
        lngResult = api_getsockopt(.lngSocketHandle, SOL_SOCKET, SO_RCVBUF, lngBuffer, LenB(lngBuffer))
    
        If lngResult = SOCKET_ERROR Then
            lngErrorCode = Err.LastDllError
            Err.Raise lngErrorCode, "CSocketPlus.ProcessOptions", GetErrorDescription(lngErrorCode)
        Else
            .lngRecvBufferLen = lngBuffer
        End If

lngResult = api_getsockopt(.lngSocketHandle, SOL_SOCKET, SO_SNDBUF, lngBuffer, LenB(lngBuffer))

If lngResult = SOCKET_ERROR Then
            lngErrorCode = Err.LastDllError
            Err.Raise lngErrorCode, "CSocketPlus.ProcessOptions", GetErrorDescription(lngErrorCode)
        Else
            .lngSendBufferLen = lngBuffer
        End If

Else
        lngBuffer = 1
        lngResult = api_setsockopt(.lngSocketHandle, SOL_SOCKET, SO_BROADCAST, lngBuffer, LenB(lngBuffer))
    
        lngResult = api_getsockopt(.lngSocketHandle, SOL_SOCKET, SO_MAX_MSG_SIZE, lngBuffer, LenB(lngBuffer))

If lngResult = SOCKET_ERROR Then
            lngErrorCode = Err.LastDllError
            Err.Raise lngErrorCode, "CSocketPlus.ProcessOptions", GetErrorDescription(lngErrorCode)
        Else
            .lngRecvBufferLen = lngBuffer
            .lngSendBufferLen = lngBuffer
        End If
    End If

Debug.Print "Winsock buffer size for sends: " & .lngRecvBufferLen
    Debug.Print "Winsock buffer size for receives: " & .lngSendBufferLen
    
End With
End Sub

'This function is to retrieve data from the buffer. If we are using TCP
'then the data is retrieved from a local buffer (m_strRecvBuffer). If we
'are using UDP the data is retrieved from winsock buffer.
'It can be called by two public methods of the class - GetData and PeekData.
'Behavior of the function is defined by the blnPeek argument. If a value of
'that argument is TRUE, the function returns number of bytes in the
'buffer, and copy data from that buffer into the data argument.
'If a value of the blnPeek is FALSE, then this function returns number of
'bytes received, and move data from the buffer into the data
'argument. MOVE means that data will be removed from the buffer.
Private Function RecvData(ByVal lngIndex As Long, ByRef data As Variant, ByVal blnPeek As Boolean, Optional varClass As Variant, Optional maxLen As Variant) As Long
On Error Resume Next
Dim blnMaxLenMiss   As Boolean
Dim blnClassMiss    As Boolean
Dim strRecvData     As String
Dim lngBufferLen    As Long
Dim arrBuffer()     As Byte
Dim lngErrorCode    As Long

If m_Socket(lngIndex).enmProtocol = sckTCPProtocol Then
    lngBufferLen = Len(m_Socket(lngIndex).strRecvBuffer)
Else
    lngBufferLen = GetBufferLenUDP(lngIndex)
End If

blnMaxLenMiss = IsMissing(maxLen)
blnClassMiss = IsMissing(varClass)

'Select type of data
If varType(data) = vbEmpty Then
    If blnClassMiss Then varClass = vbArray + vbByte
Else
    varClass = varType(data)
End If

'As stated on Winsock control documentation if the
'data type passed is string or byte array type then
'we must take into account maxLen argument.
'If it is another type maxLen is ignored.
If varClass = vbString Or varClass = vbArray + vbByte Then

If blnMaxLenMiss Then 'if maxLen argument is missing
    
        If lngBufferLen = 0 Then
        
            RecvData = 0
        
            arrBuffer = StrConv("", vbFromUnicode)
            data = arrBuffer

Exit Function
    
        Else
            
            RecvData = lngBufferLen
            BuildArray lngIndex, lngBufferLen, blnPeek, lngErrorCode, arrBuffer

End If

Else 'if maxLen argument is not missing

If maxLen = 0 Or lngBufferLen = 0 Then

RecvData = 0
        
            arrBuffer = StrConv("", vbFromUnicode)
            data = arrBuffer
            
            If m_Socket(lngIndex).enmProtocol = sckUDPProtocol Then
                EmptyBuffer lngIndex
                Err.Raise WSAEMSGSIZE, "CSocketPlus.RecvData", GetErrorDescription(WSAEMSGSIZE)
            End If
            
            Exit Function
        
        ElseIf maxLen > lngBufferLen Then
            
            RecvData = lngBufferLen
            BuildArray lngIndex, lngBufferLen, blnPeek, lngErrorCode, arrBuffer

Else
            
            RecvData = CLng(maxLen)
            BuildArray lngIndex, CLng(maxLen), blnPeek, lngErrorCode, arrBuffer

End If
    
    End If
        
End If

Select Case varClass
    
    Case vbString
        Dim strData As String
        strData = StrConv(arrBuffer(), vbUnicode)
        data = strData
    Case vbArray + vbByte
        data = arrBuffer
    Case vbBoolean
        Dim blnData As Boolean
        If LenB(blnData) > lngBufferLen Then Exit Function
        BuildArray lngIndex, LenB(blnData), blnPeek, lngErrorCode, arrBuffer
        RecvData = LenB(blnData)
        api_CopyMemory blnData, arrBuffer(0), LenB(blnData)
        data = blnData
    Case vbByte
        Dim bytData As Byte
        If LenB(bytData) > lngBufferLen Then Exit Function
        BuildArray lngIndex, LenB(bytData), blnPeek, lngErrorCode, arrBuffer
        RecvData = LenB(bytData)
        api_CopyMemory bytData, arrBuffer(0), LenB(bytData)
        data = bytData
    Case vbCurrency
        Dim curData As Currency
        If LenB(curData) > lngBufferLen Then Exit Function
        BuildArray lngIndex, LenB(curData), blnPeek, lngErrorCode, arrBuffer
        RecvData = LenB(curData)
        api_CopyMemory curData, arrBuffer(0), LenB(curData)
        data = curData
    Case vbDate
        Dim datData As Date
        If LenB(datData) > lngBufferLen Then Exit Function
        BuildArray lngIndex, LenB(datData), blnPeek, lngErrorCode, arrBuffer
        RecvData = LenB(datData)
        api_CopyMemory datData, arrBuffer(0), LenB(datData)
        data = datData
    Case vbDouble
        Dim dblData As Double
        If LenB(dblData) > lngBufferLen Then Exit Function
        BuildArray lngIndex, LenB(dblData), blnPeek, lngErrorCode, arrBuffer
        RecvData = LenB(dblData)
        api_CopyMemory dblData, arrBuffer(0), LenB(dblData)
        data = dblData
    Case vbInteger
        Dim intData As Integer
        If LenB(intData) > lngBufferLen Then Exit Function
        BuildArray lngIndex, LenB(intData), blnPeek, lngErrorCode, arrBuffer
        RecvData = LenB(intData)
        api_CopyMemory intData, arrBuffer(0), LenB(intData)
        data = intData
    Case vbLong
        Dim lngData As Long
        If LenB(lngData) > lngBufferLen Then Exit Function
        BuildArray lngIndex, LenB(lngData), blnPeek, lngErrorCode, arrBuffer
        RecvData = LenB(lngData)
        api_CopyMemory lngData, arrBuffer(0), LenB(lngData)
        data = lngData
    Case vbSingle
        Dim sngData As Single
        If LenB(sngData) > lngBufferLen Then Exit Function
        BuildArray lngIndex, LenB(sngData), blnPeek, lngErrorCode, arrBuffer
        RecvData = LenB(sngData)
        api_CopyMemory sngData, arrBuffer(0), LenB(sngData)
        data = sngData
    Case Else
        Err.Raise sckUnsupported, "CSocketPlus.RecvData", "Unsupported variant type."
       
    End Select

'if BuildArray returns an error is handled here
If lngErrorCode <> 0 Then
    Err.Raise lngErrorCode, "CSocketPlus.RecvData", GetErrorDescription(lngErrorCode)
End If

End Function

'Returns a byte array of Size bytes filled with incoming buffer data.
Private Sub BuildArray(ByVal lngIndex As Long, ByVal Size As Long, ByVal blnPeek As Boolean, ByRef lngErrorCode As Long, ByRef bytArray() As Byte)
Dim strData As String

With m_Socket(lngIndex)
    
    If .enmProtocol = sckTCPProtocol Then
        
        strData = Left$(.strRecvBuffer, CLng(Size))
        bytArray = StrConv(strData, vbFromUnicode)
                
        If Not blnPeek Then
            .strRecvBuffer = Mid$(.strRecvBuffer, Size + 1)
        End If

Else 'UDP protocol
        Dim arrBuffer() As Byte
        Dim lngResult As Long
        Dim udtSockAddr As sockaddr_in
        Dim lngFlags As Long
    
        If blnPeek Then lngFlags = MSG_PEEK
    
        ReDim arrBuffer(Size - 1)
    
        lngResult = api_recvfrom(.lngSocketHandle, arrBuffer(0), Size, lngFlags, udtSockAddr, LenB(udtSockAddr))
    
        If lngResult = SOCKET_ERROR Then
            lngErrorCode = Err.LastDllError
        End If
    
        bytArray = arrBuffer
        GetRemoteInfoFromSI udtSockAddr, .lngRemotePort, .strRemoteHostIP, .strRemoteHost
    
    End If
End With
End Sub

'Clean resolution system that is in charge of
'asynchronous hostname resolutions.
Private Sub CleanResolutionSystem(ByVal lngIndex As Long)
Dim varAsynHandle As Variant
Dim lngResult As Long

'cancel async resolutions if they're still running
For Each varAsynHandle In m_Socket(lngIndex).colWaitingResolutions
    lngResult = api_WSACancelAsyncRequest(varAsynHandle)
    If lngResult = 0 Then
        ModSocketPlus.UnregisterResolution varAsynHandle
        
        Set m_Socket(lngIndex).colWaitingResolutions = Nothing
        Set m_Socket(lngIndex).colWaitingResolutions = New Collection

'free memory buffer where resolution results are stored
        FreeMemory lngIndex
        
    End If
Next

End Sub

'Retrieves local info from a connected socket.
'If succeeds returns TRUE and loads the arguments.
'If fails returns FALSE and arguments are not loaded.
Private Function GetLocalInfo(ByVal lngSocket As Long, ByRef lngLocalPort As Long, ByRef strLocalIP As String) As Boolean
GetLocalInfo = False
Dim lngResult As Long
Dim udtSockAddr As sockaddr_in

lngResult = api_getsockname(lngSocket, udtSockAddr, LenB(udtSockAddr))

If lngResult = SOCKET_ERROR Then
    lngLocalPort = 0
    strLocalIP = ""
Else
    GetLocalInfo = True
    lngLocalPort = IntegerToUnsigned(api_ntohs(udtSockAddr.sin_port))
    strLocalIP = StringFromPointer(api_inet_ntoa(udtSockAddr.sin_addr))
End If

End Function

'Retrieves remote info from a connected socket.
'If succeeds returns TRUE and loads the arguments.
'If fails returns FALSE and arguments are not loaded.
Private Function GetRemoteInfo(ByVal lngSocket As Long, ByRef lngRemotePort As Long, ByRef strRemoteHostIP As String, ByRef strRemoteHost As String) As Boolean
GetRemoteInfo = False
Dim lngResult As Long
Dim udtSockAddr As sockaddr_in

lngResult = api_getpeername(lngSocket, udtSockAddr, LenB(udtSockAddr))

If lngResult = 0 Then
    GetRemoteInfo = True
    GetRemoteInfoFromSI udtSockAddr, lngRemotePort, strRemoteHostIP, strRemoteHost
Else
   lngRemotePort = 0
   strRemoteHostIP = ""
   strRemoteHost = ""
End If
End Function

'Gets remote info from a sockaddr_in structure.
Private Sub GetRemoteInfoFromSI(ByRef udtSockAddr As sockaddr_in, ByRef lngRemotePort As Long, ByRef strRemoteHostIP As String, ByRef strRemoteHost As String)

'Dim lngResult As Long
'Dim udtHostent As HOSTENT

lngRemotePort = IntegerToUnsigned(api_ntohs(udtSockAddr.sin_port))
strRemoteHostIP = StringFromPointer(api_inet_ntoa(udtSockAddr.sin_addr))
'lngResult = api_gethostbyaddr(udtSockAddr.sin_addr, 4&, AF_INET)

'If lngResult <> 0 Then
'    api_CopyMemory udtHostent, ByVal lngResult, LenB(udtHostent)
'    strRemoteHost = StringFromPointer(udtHostent.hName)
'Else
    strRemoteHost = ""
'End If

End Sub

'Returns winsock incoming buffer length from an UDP socket.
Private Function GetBufferLenUDP(ByVal lngIndex As Long) As Long
Dim lngResult As Long
Dim lngBuffer As Long
lngResult = api_ioctlsocket(m_Socket(lngIndex).lngSocketHandle, FIONREAD, lngBuffer)

If lngResult = SOCKET_ERROR Then
    GetBufferLenUDP = 0
Else
    GetBufferLenUDP = lngBuffer
End If
End Function

'Empty winsock incoming buffer from an UDP socket.
Private Sub EmptyBuffer(ByVal lngIndex As Long)
Dim B As Byte
api_recv m_Socket(lngIndex).lngSocketHandle, B, Len(B), 0&
End Sub

'Removes the socket Index from the socket array
'If it is the last one cleans the array
Private Sub CleanSocketArray(ByVal lngIndex As Long)

On Error GoTo Error_Handler

Dim lngNextEmptyIndex As Long
lngNextEmptyIndex = UBound(m_EmptyIndex) + 1

If UBound(m_Socket) = lngNextEmptyIndex Then
    ReDim m_Socket(0) As typSocket
    ReDim m_EmptyIndex(0) As Long
Else 'if it is the last in the array we can erase it from the array
    If UBound(m_Socket) = lngIndex Then
        ReDim Preserve m_Socket(0 To lngIndex - 1) As typSocket
    Else 'if it isn't the last in the array we can't erase it
        With m_Socket(lngIndex)
        Set .colWaitingResolutions = Nothing
        Set .colWaitingResolutions = New Collection
        .enmProtocol = sckTCPProtocol
        .enmState = sckClosed
        .lngLocalPort = -1
        .lngLocalPortBind = -1
        .lngMemoryHandle = 0
        .lngMemoryPointer = 0
        .lngRecvBufferLen = 0
        .lngRemotePort = -1
        .lngSendBufferLen = 0
        .lngSocketHandle = -1
        .strLocalIP = ""
        .strRecvBuffer = ""
        .strRemoteHost = ""
        .strRemoteHostIP = ""
        .strSendBuffer = ""
        .strTag = ""
        .varUserIndex = 0
        End With
        ReDim Preserve m_EmptyIndex(lngNextEmptyIndex)
        m_EmptyIndex(lngNextEmptyIndex) = lngIndex
    End If
End If

Exit Sub

Error_Handler:
    Err.Raise sckOutOfMemory, "CSocketPlus.CleanSocketArray", "Out of memory"
End Sub

'Returns a free index to be used on the socket array.
'Redims the array if necessary.
Private Function GetFreeSocketIndex() As Long
On Error GoTo Error_Handler:

Dim lngFreeBound As Long
Dim lngIndex As Long

lngFreeBound = UBound(m_EmptyIndex)

If lngFreeBound = 0 Then    'if there isn't any empty index

lngIndex = UBound(m_Socket) + 1
    ReDim Preserve m_Socket(lngIndex)
    
Else 'if there are some empty indexes we take the last one
    lngIndex = m_EmptyIndex(UBound(m_EmptyIndex))
    ReDim Preserve m_EmptyIndex(UBound(m_EmptyIndex) - 1)

End If

GetFreeSocketIndex = lngIndex

Exit Function

Error_Handler:
    Err.Raise sckOutOfMemory, "CSocketPlus.GetFreeSocketIndex", "Out of memory"
End Function

'Get socket array index from user index or string index
Private Function GetSocketIndex(Index As Variant) As Long
On Error GoTo Error_Handler

Select Case varType(Index)
    Case vbString
        GetSocketIndex = m_colString_Index("I" & Index)
    Case vbInteger To vbLong
        GetSocketIndex = m_colUserIndex_Index("I" & Index)
    Case Else
        Err.Raise sckWrongIndex
End Select

Exit Function

Error_Handler:
    Dim lngErrorCode As Long
    Dim strErrorDesc As String
    
    lngErrorCode = Err.Number
    strErrorDesc = Err.Description
    
    Const strSource As String = "CSocketPlus.GetSocketIndex"
    
    If Err.Number = sckWrongIndex Then
        Err.Raise sckWrongIndex, strSource, "Unsupported index type."
    ElseIf Err.Number = 5 Then
        Err.Raise sckMissingIndex, strSource, "Unknown index."
    Else
        Err.Raise lngErrorCode, strSource, strErrorDesc
    End If
End Function

'returns true if user index is registered on
'm_colUserIndex_Index
Private Function IsUserIndexRegistered(ByVal lngIndex As Long) As Boolean
On Error GoTo Error_Handler

m_colUserIndex_Index.Item ("I" & lngIndex)
IsUserIndexRegistered = True

Exit Function

Error_Handler:
    IsUserIndexRegistered = False
End Function

Lalu ubah lah nama dari class1 menjadi CSocketPlus

Klik kanan lagi di Project > Add > Module
lalu pastekan coding ini ke kolom kode module

'
Option Explicit

'==============================================================================
'API FUNCTIONS
'==============================================================================

'Public Declare Function api_WSAGetLastError Lib "ws2_32.dll" Alias "WSAGetLastError" () As Long
Public Declare Sub api_CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Public Declare Function api_GlobalAlloc Lib "kernel32" Alias "GlobalAlloc" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Public Declare Function api_GlobalFree Lib "kernel32" Alias "GlobalFree" (ByVal hMem As Long) As Long
Private Declare Function api_WSAStartup Lib "ws2_32.dll" Alias "WSAStartup" (ByVal wVersionRequired As Long, lpWSADATA As WSAData) As Long
Private Declare Function api_WSACleanup Lib "ws2_32.dll" Alias "WSACleanup" () As Long
Private Declare Function api_WSAAsyncGetHostByName Lib "ws2_32.dll" Alias "WSAAsyncGetHostByName" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal strHostName As String, buf As Any, ByVal buflen As Long) As Long
Private Declare Function api_WSAAsyncSelect Lib "ws2_32.dll" Alias "WSAAsyncSelect" (ByVal s As Long, ByVal hwnd As Long, ByVal wMsg As Long, ByVal lEvent As Long) As Long
Private Declare Function api_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 api_DestroyWindow Lib "user32" Alias "DestroyWindow" (ByVal hwnd As Long) As Long
Private Declare Function api_lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As Any) As Long
Private Declare Function api_lstrcpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpString1 As String, ByVal lpString2 As Long) As Long
Private Declare Function api_LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function api_SetTimer Lib "user32" Alias "SetTimer" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function api_KillTimer Lib "user32" Alias "KillTimer" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long

'==============================================================================
'CONSTANTS
'==============================================================================

Public Const SOCKET_ERROR   As Integer = -1
Public Const INVALID_SOCKET As Integer = -1
Public Const INADDR_NONE As Long = &HFFFF

Private Const WSADESCRIPTION_LEN As Integer = 257
Private Const WSASYS_STATUS_LEN  As Integer = 129

Private Enum WinsockVersion
    SOCKET_VERSION_11 = &H101
    SOCKET_VERSION_22 = &H202
End Enum

Public Const MAXGETHOSTSTRUCT As Long = 1024

Public Const AF_INET        As Long = 2
Public Const SOCK_STREAM    As Long = 1
Public Const SOCK_DGRAM     As Long = 2
Public Const IPPROTO_TCP    As Long = 6
Public Const IPPROTO_UDP    As Long = 17

Public Const FD_READ    As Integer = &H1&
Public Const FD_WRITE   As Integer = &H2&
Public Const FD_ACCEPT  As Integer = &H8&
Public Const FD_CONNECT As Integer = &H10&
Public Const FD_CLOSE   As Integer = &H20&

Private Const OFFSET_2 As Long = 65536
Private Const MAXINT_2 As Long = 32767

Public Const GMEM_FIXED As Integer = &H0
Public Const LOCAL_HOST_BUFF As Integer = 256

Public Const SOL_SOCKET         As Long = 65535
Public Const SO_SNDBUF          As Long = &H1001&
Public Const SO_RCVBUF          As Long = &H1002&
Public Const SO_MAX_MSG_SIZE    As Long = &H2003
Public Const SO_BROADCAST       As Long = &H20
Public Const FIONREAD           As Long = &H4004667F

'==============================================================================
'ERROR CODES
'==============================================================================

Public Const WSABASEERR         As Long = 10000
Public Const WSAEINTR           As Long = (WSABASEERR + 4)
Public Const WSAEACCES          As Long = (WSABASEERR + 13)
Public Const WSAEFAULT          As Long = (WSABASEERR + 14)
Public Const WSAEINVAL          As Long = (WSABASEERR + 22)
Public Const WSAEMFILE          As Long = (WSABASEERR + 24)
Public Const WSAEWOULDBLOCK     As Long = (WSABASEERR + 35)
Public Const WSAEINPROGRESS     As Long = (WSABASEERR + 36)
Public Const WSAEALREADY        As Long = (WSABASEERR + 37)
Public Const WSAENOTSOCK        As Long = (WSABASEERR + 38)
Public Const WSAEDESTADDRREQ    As Long = (WSABASEERR + 39)
Public Const WSAEMSGSIZE        As Long = (WSABASEERR + 40)
Public Const WSAEPROTOTYPE      As Long = (WSABASEERR + 41)
Public Const WSAENOPROTOOPT     As Long = (WSABASEERR + 42)
Public Const WSAEPROTONOSUPPORT As Long = (WSABASEERR + 43)
Public Const WSAESOCKTNOSUPPORT As Long = (WSABASEERR + 44)
Public Const WSAEOPNOTSUPP      As Long = (WSABASEERR + 45)
Public Const WSAEPFNOSUPPORT    As Long = (WSABASEERR + 46)
Public Const WSAEAFNOSUPPORT    As Long = (WSABASEERR + 47)
Public Const WSAEADDRINUSE      As Long = (WSABASEERR + 48)
Public Const WSAEADDRNOTAVAIL   As Long = (WSABASEERR + 49)
Public Const WSAENETDOWN        As Long = (WSABASEERR + 50)
Public Const WSAENETUNREACH     As Long = (WSABASEERR + 51)
Public Const WSAENETRESET       As Long = (WSABASEERR + 52)
Public Const WSAECONNABORTED    As Long = (WSABASEERR + 53)
Public Const WSAECONNRESET      As Long = (WSABASEERR + 54)
Public Const WSAENOBUFS         As Long = (WSABASEERR + 55)
Public Const WSAEISCONN         As Long = (WSABASEERR + 56)
Public Const WSAENOTCONN        As Long = (WSABASEERR + 57)
Public Const WSAESHUTDOWN       As Long = (WSABASEERR + 58)
Public Const WSAETIMEDOUT       As Long = (WSABASEERR + 60)
Public Const WSAEHOSTUNREACH    As Long = (WSABASEERR + 65)
Public Const WSAECONNREFUSED    As Long = (WSABASEERR + 61)
Public Const WSAEPROCLIM        As Long = (WSABASEERR + 67)
Public Const WSASYSNOTREADY     As Long = (WSABASEERR + 91)
Public Const WSAVERNOTSUPPORTED As Long = (WSABASEERR + 92)
Public Const WSANOTINITIALISED  As Long = (WSABASEERR + 93)
Public Const WSAHOST_NOT_FOUND  As Long = (WSABASEERR + 1001)
Public Const WSATRY_AGAIN       As Long = (WSABASEERR + 1002)
Public Const WSANO_RECOVERY     As Long = (WSABASEERR + 1003)
Public Const WSANO_DATA         As Long = (WSABASEERR + 1004)

'==============================================================================
'WINSOCK CONTROL ERROR CODES
'==============================================================================

Public Const sckOutOfMemory As Long = 7
Public Const sckBadState    As Long = 40006
Public Const sckInvalidArg  As Long = 40014
Public Const sckUnsupported As Long = 40018
Public Const sckInvalidOp   As Long = 40020

'==============================================================================
'SOCKET ARRAY ERROR CODES
'==============================================================================
Public Const sckWrongIndex      As Long = 40027
Public Const sckUsedIndex       As Long = 40028
Public Const sckMissingIndex    As Long = 40029

'==============================================================================
'STRUCTURES
'==============================================================================

Private Type WSAData
   wVersion       As Integer
   wHighVersion   As Integer
   szDescription  As String * WSADESCRIPTION_LEN
   szSystemStatus As String * WSASYS_STATUS_LEN
   iMaxSockets    As Integer
   iMaxUdpDg      As Integer
   lpVendorInfo   As Long
End Type

Public Type HOSTENT
    hName     As Long
    hAliases  As Long
    hAddrType As Integer
    hLength   As Integer
    hAddrList As Long
End Type

Public Type sockaddr_in
    sin_family       As Integer
    sin_port         As Integer
    sin_addr         As Long
    sin_zero(1 To 8) As Byte
End Type

'==============================================================================
'MEMBER VARIABLES
'==============================================================================

Private m_blnInitiated          As Boolean      'specify if winsock service was initiated
Private m_lngSocksQuantity      As Long         'number of instances created
Private m_colSocketsInst        As Collection   'sockets list and instance owner
Private m_colAcceptList         As Collection   'sockets in queue that need to be accepted
Private m_lngWindowHandle       As Long         'message window handle

'==============================================================================
'SUBCLASSING DECLARATIONS
'by Paul Caton
'==============================================================================
Private Declare Function api_IsWindow Lib "user32" Alias "IsWindow" (ByVal hwnd As Long) As Long
Private Declare Function api_GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function api_SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function api_GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
Private Declare Function api_GetProcAddress Lib "kernel32" Alias "GetProcAddress" (ByVal hModule As Long, ByVal lpProcName As String) As Long

Private Const PATCH_09 As Long = 119
Private Const PATCH_0C As Long = 150

Private Const GWL_WNDPROC As Long = (-4)

Private Const WM_APP As Long = 32768 '0x8000

Public Const RESOLVE_MESSAGE As Long = WM_APP
Public Const SOCKET_MESSAGE  As Long = WM_APP + 1

Private Const TIMER_TIMEOUT As Long = 200   'control timer time out, in milliseconds

Private lngMsgCntA      As Long     'TableA entry count
Private lngMsgCntB      As Long     'TableB entry count
Private lngTableA1()    As Long     'TableA1: list of async handles
Private lngTableA2()    As Long     'TableA2: list of async handles owners
Private lngTableB1()    As Long     'TableB1: list of sockets
Private lngTableB2()    As Long     'TableB2: list of sockets owners
Private hWndSub         As Long     'window handle subclassed
Private nAddrSubclass   As Long     'address of our WndProc
Private nAddrOriginal   As Long     'address of original WndProc
Private hTimer          As Long     'control timer handle

'This function initiates the processes needed to keep
'control of sockets. Returns 0 if it has success.
Public Function InitiateProcesses() As Long

InitiateProcesses = 0
m_lngSocksQuantity = m_lngSocksQuantity + 1

'if the service wasn't initiated yet we do it now
If Not m_blnInitiated Then
     
    Subclass_Initialize
   
    m_blnInitiated = True
    
    Dim lngResult As Long
    lngResult = InitiateService
    
    If lngResult = 0 Then
        Debug.Print "OK Winsock service initiated"
    Else
        Debug.Print "ERROR trying to initiate winsock service"
        Err.Raise lngResult, "modSocketPlus.InitiateProcesses", GetErrorDescription(lngResult)
        InitiateProcesses = lngResult
    End If
    
End If
End Function

'This function initiate the winsock service calling
'the api_WSAStartup funtion and returns resulting value.
Private Function InitiateService() As Long
Dim udtWSAData As WSAData
Dim lngResult As Long

lngResult = api_WSAStartup(SOCKET_VERSION_11, udtWSAData)
InitiateService = lngResult
End Function

'Once we are done with the class instance we call this
'function to discount it and finish winsock service if
'it was the last one.
'Returns 0 if it has success.
Public Function FinalizeProcesses() As Long
FinalizeProcesses = 0
m_lngSocksQuantity = m_lngSocksQuantity - 1

'if the service was initiated and there's no more instances
'of the class then we finish the service
If m_blnInitiated And m_lngSocksQuantity = 0 Then
    If FinalizeService = SOCKET_ERROR Then
        Dim lngErrorCode As Long
        lngErrorCode = Err.LastDllError
        FinalizeProcesses = lngErrorCode
        Err.Raise lngErrorCode, "modSocketPlus.FinalizeProcesses", GetErrorDescription(lngErrorCode)
    Else
        Debug.Print "OK Winsock service finalized"
    End If
    
    Subclass_Terminate
    m_blnInitiated = False
End If

End Function

'Finish winsock service calling the function
'api_WSACleanup and returns the result.
Private Function FinalizeService() As Long
Dim lngResultado As Long
lngResultado = api_WSACleanup
FinalizeService = lngResultado
End Function

'This function receives a number that represents an error
'and returns the corresponding description string.
Public Function GetErrorDescription(ByVal lngErrorCode As Long) As String
Select Case lngErrorCode
    Case WSAEACCES
        GetErrorDescription = "Permission denied."
    Case WSAEADDRINUSE
        GetErrorDescription = "Address already in use."
    Case WSAEADDRNOTAVAIL
        GetErrorDescription = "Cannot assign requested address."
    Case WSAEAFNOSUPPORT
        GetErrorDescription = "Address family not supported by protocol family."
    Case WSAEALREADY
        GetErrorDescription = "Operation already in progress."
    Case WSAECONNABORTED
        GetErrorDescription = "Software caused connection abort."
    Case WSAECONNREFUSED
        GetErrorDescription = "Connection refused."
    Case WSAECONNRESET
        GetErrorDescription = "Connection reset by peer."
    Case WSAEDESTADDRREQ
        GetErrorDescription = "Destination address required."
    Case WSAEFAULT
        GetErrorDescription = "Bad address."
    Case WSAEHOSTUNREACH
        GetErrorDescription = "No route to host."
    Case WSAEINPROGRESS
        GetErrorDescription = "Operation now in progress."
    Case WSAEINTR
        GetErrorDescription = "Interrupted function call."
    Case WSAEINVAL
        GetErrorDescription = "Invalid argument."
    Case WSAEISCONN
        GetErrorDescription = "Socket is already connected."
    Case WSAEMFILE
        GetErrorDescription = "Too many open files."
    Case WSAEMSGSIZE
        GetErrorDescription = "Message too long."
    Case WSAENETDOWN
        GetErrorDescription = "Network is down."
    Case WSAENETRESET
        GetErrorDescription = "Network dropped connection on reset."
    Case WSAENETUNREACH
        GetErrorDescription = "Network is unreachable."
    Case WSAENOBUFS
        GetErrorDescription = "No buffer space available."
    Case WSAENOPROTOOPT
        GetErrorDescription = "Bad protocol option."
    Case WSAENOTCONN
        GetErrorDescription = "Socket is not connected."
    Case WSAENOTSOCK
        GetErrorDescription = "Socket operation on nonsocket."
    Case WSAEOPNOTSUPP
        GetErrorDescription = "Operation not supported."
    Case WSAEPFNOSUPPORT
        GetErrorDescription = "Protocol family not supported."
    Case WSAEPROCLIM
        GetErrorDescription = "Too many processes."
    Case WSAEPROTONOSUPPORT
        GetErrorDescription = "Protocol not supported."
    Case WSAEPROTOTYPE
        GetErrorDescription = "Protocol wrong type for socket."
    Case WSAESHUTDOWN
        GetErrorDescription = "Cannot send after socket shutdown."
    Case WSAESOCKTNOSUPPORT
        GetErrorDescription = "Socket type not supported."
    Case WSAETIMEDOUT
        GetErrorDescription = "Connection timed out."
    Case WSAEWOULDBLOCK
        GetErrorDescription = "Resource temporarily unavailable."
    Case WSAHOST_NOT_FOUND
        GetErrorDescription = "Host not found."
    Case WSANOTINITIALISED
        GetErrorDescription = "Successful WSAStartup not yet performed."
    Case WSANO_DATA
        GetErrorDescription = "Valid name, no data record of requested type."
    Case WSANO_RECOVERY
        GetErrorDescription = "This is a nonrecoverable error."
    Case WSASYSNOTREADY
        GetErrorDescription = "Network subsystem is unavailable."
    Case WSATRY_AGAIN
        GetErrorDescription = "Nonauthoritative host not found."
    Case WSAVERNOTSUPPORTED
        GetErrorDescription = "Winsock.dll version out of range."
    Case Else
        GetErrorDescription = "Unknown error."
End Select

End Function

'Create a window that is used to capture sockets messages.
'Returns 0 if it has success.
Private Function CreateWinsockMessageWindow() As Long
m_lngWindowHandle = api_CreateWindowEx(0&, "STATIC", "SOCKET_WINDOW", 0&, 0&, 0&, 0&, 0&, 0&, 0&, App.hInstance, ByVal 0&)

If m_lngWindowHandle = 0 Then
    CreateWinsockMessageWindow = sckOutOfMemory
    Exit Function
Else
    CreateWinsockMessageWindow = 0
    Debug.Print "OK Created winsock message window " & m_lngWindowHandle
End If
End Function

'Destroy the window that is used to capture sockets messages.
'Returns 0 if it has success.
Private Function DestroyWinsockMessageWindow() As Long
DestroyWinsockMessageWindow = 0

If m_lngWindowHandle = 0 Then
    Debug.Print "WARNING lngWindowHandle is ZERO"
    Exit Function
End If
    
Dim lngResult As Long

lngResult = api_DestroyWindow(m_lngWindowHandle)
    
If lngResult = 0 Then
    DestroyWinsockMessageWindow = sckOutOfMemory
    Err.Raise sckOutOfMemory, "modSocketPlus.DestroyWinsockMessageWindow", "Out of memory"
Else
    Debug.Print "OK Destroyed winsock message window " & m_lngWindowHandle
    m_lngWindowHandle = 0
End If
    
End Function

'When a socket needs to resolve a hostname in asynchronous way
'it calls this function. If it has success it returns a nonzero
'number that represents the async task handle and register this
'number in the TableA list.
'Returns 0 if it fails.
Public Function ResolveHost(ByVal strHost As String, ByVal lngHOSTENBuf As Long, ByVal lngObjectPointer As Long) As Long
Dim lngAsynHandle As Long
lngAsynHandle = api_WSAAsyncGetHostByName(m_lngWindowHandle, RESOLVE_MESSAGE, strHost, ByVal lngHOSTENBuf, MAXGETHOSTSTRUCT)
If lngAsynHandle <> 0 Then Subclass_AddResolveMessage lngAsynHandle, lngObjectPointer
ResolveHost = lngAsynHandle
End Function

'Returns the hi word from a double word.
Public Function HiWord(lngValue As Long) As Long
If (lngValue And &H80000000) = &H80000000 Then
    HiWord = ((lngValue And &H7FFF0000) \ &H10000) Or &H8000&
Else
    HiWord = (lngValue And &HFFFF0000) \ &H10000
End If
End Function

'Returns the low word from a double word.
Public Function LoWord(lngValue As Long) As Long
LoWord = (lngValue And &HFFFF&)
End Function

'Receives a string pointer and it turns it into a regular string.
Public Function StringFromPointer(ByVal lPointer As Long) As String
Dim strTemp As String
Dim lRetVal As Long

strTemp = String$(api_lstrlen(ByVal lPointer), 0)
lRetVal = api_lstrcpy(ByVal strTemp, ByVal lPointer)
If lRetVal Then StringFromPointer = strTemp
End Function

'The function takes an unsigned Integer from and API and?
'converts it to a Long for display or arithmetic purposes
Public Function UnsignedToInteger(Value As Long) As Integer
If Value < 0 Or Value >= OFFSET_2 Then Error 6 ' Overflow
If Value <= MAXINT_2 Then
    UnsignedToInteger = Value
Else
    UnsignedToInteger = Value - OFFSET_2
End If
End Function

'The function takes a Long containing a value in the range?
'of an unsigned Integer and returns an Integer that you?
'can pass to an API that requires an unsigned Integer
Public Function IntegerToUnsigned(Value As Integer) As Long
If Value < 0 Then
    IntegerToUnsigned = Value + OFFSET_2
Else
    IntegerToUnsigned = Value
End If
End Function

'Adds the socket to the m_colSocketsInst collection, and
'registers that socket with WSAAsyncSelect Winsock API
'function to receive network events for the socket.
'If this socket is the first one to be registered, the
'window and collection will be created in this function as well.
Public Function RegisterSocket(ByVal lngSocket As Long, ByVal lngObjectPointer As Long, ByVal blnEvents As Boolean) As Boolean

If m_colSocketsInst Is Nothing Then
    Set m_colSocketsInst = New Collection
    Debug.Print "OK Created socket array"
    
    If CreateWinsockMessageWindow <> 0 Then
        Err.Raise sckOutOfMemory, "modSocketPlus.RegisterSocket", "Out of memory"
    End If
    
    Subclass_Subclass (m_lngWindowHandle)
    
End If

Subclass_AddSocketMessage lngSocket, lngObjectPointer

'Do we need to register socket events?
If blnEvents Then
    Dim lngEvents As Long
    Dim lngResult As Long
    Dim lngErrorCode As Long

lngEvents = FD_READ Or FD_WRITE Or FD_ACCEPT Or FD_CONNECT Or FD_CLOSE
    lngResult = api_WSAAsyncSelect(lngSocket, m_lngWindowHandle, SOCKET_MESSAGE, lngEvents)
        
    If lngResult = SOCKET_ERROR Then
        Debug.Print "ERROR trying to register events from socket " & lngSocket
        lngErrorCode = Err.LastDllError
        Err.Raise lngErrorCode, "modSocketPlus.RegisterSocket", GetErrorDescription(lngErrorCode)
    Else
        Debug.Print "OK Registered events from socket " & lngSocket
    End If
End If

m_colSocketsInst.Add lngObjectPointer, "S" & lngSocket
RegisterSocket = True
End Function

'Removes the socket from the m_colSocketsInst collection
'If it is the last socket in that collection, the window
'and colection will be destroyed as well.
Public Sub UnregisterSocket(ByVal lngSocket As Long)
Subclass_DelSocketMessage lngSocket
On Error Resume Next
m_colSocketsInst.Remove "S" & lngSocket

If m_colSocketsInst.Count = 0 Then
    Set m_colSocketsInst = Nothing
    Subclass_UnSubclass
    DestroyWinsockMessageWindow
    Debug.Print "OK Destroyed socket array"
End If
End Sub

'Returns TRUE si the socket that is passed is registered
'in the colSocketsInst collection.
Public Function IsSocketRegistered(ByVal lngSocket As Long) As Boolean
On Error GoTo Error_Handler

m_colSocketsInst.Item ("S" & lngSocket)
IsSocketRegistered = True

Exit Function

Error_Handler:
    IsSocketRegistered = False
End Function

'When ResolveHost is called an async task handle is added
'to TableA list. Use this function to remove that record.
Public Sub UnregisterResolution(ByVal lngAsynHandle As Long)
Subclass_DelResolveMessage lngAsynHandle
End Sub

'Assing a temporal instance of CSocketPlus to a
'socket and register this socket to the accept list.
Public Sub RegisterAccept(ByVal lngSocket As Long)
If m_colAcceptList Is Nothing Then
    Set m_colAcceptList = New Collection
    Debug.Print "OK Created accept collection"
End If
Dim Socket As CSocketPlus
Set Socket = New CSocketPlus
Socket.ArrayAdd "Temporal_Socket"
Socket.Accept "Temporal_Socket", lngSocket
m_colAcceptList.Add Socket, "S" & lngSocket
End Sub

'Returns True is lngSocket is registered on the
'accept list.
Public Function IsAcceptRegistered(ByVal lngSocket As Long) As Boolean
On Error GoTo Error_Handler

m_colAcceptList.Item ("S" & lngSocket)
IsAcceptRegistered = True

Exit Function

Error_Handler:
    IsAcceptRegistered = False
End Function

'Unregister lngSocket from the accept list.
Public Sub UnregisterAccept(ByVal lngSocket As Long)
m_colAcceptList.Remove "S" & lngSocket

If m_colAcceptList.Count = 0 Then
    Set m_colAcceptList = Nothing
    Debug.Print "OK Destroyed accept collection"
End If
End Sub

'Return the accept instance class from a socket.
Public Function GetAcceptClass(ByVal lngSocket As Long) As CSocketPlus
Set GetAcceptClass = m_colAcceptList("S" & lngSocket)
End Function

'==============================================================================
'SUBCLASSING CODE
'based on code by Paul Caton
'==============================================================================

Private Sub Subclass_Initialize()
Const PATCH_01 As Long = 16                                 'Code buffer offset to the location of the relative address to EbMode
Const PATCH_03 As Long = 72                                 'Relative address of SetWindowsLong
Const PATCH_04 As Long = 77                                 'Relative address of WSACleanup
Const PATCH_06 As Long = 89                                 'Relative address of KillTimer
Const PATCH_08 As Long = 113                                'Relative address of CallWindowProc
Const FUNC_EBM As String = "EbMode"                         'VBA's EbMode function allows the machine code thunk to know if the IDE has stopped or is on a breakpoint
Const FUNC_SWL As String = "SetWindowLongA"                 'SetWindowLong allows the cSubclasser machine code thunk to unsubclass the subclasser itself if it detects via the EbMode function that the IDE has stopped
Const FUNC_CWP As String = "CallWindowProcA"                'We use CallWindowProc to call the original WndProc
Const FUNC_WCU As String = "WSACleanup"                     'closesocket is called when the program is closed to release the sockets
Const FUNC_KTM As String = "KillTimer"                      'KillTimer destroys the control timer
Const MOD_VBA5 As String = "vba5"                           'Location of the EbMode function if running VB5
Const MOD_VBA6 As String = "vba6"                           'Location of the EbMode function if running VB6
Const MOD_USER As String = "user32"                         'Location of the SetWindowLong & CallWindowProc functions
Const MOD_WS   As String = "ws2_32"                         'Location of the closesocket function
  Dim i        As Long                                      'Loop index
  Dim nLen     As Long                                      'String lengths
  Dim sHex     As String                                    'Hex code string
  Dim sCode    As String                                    'Binary code string
  
  
  
  'Store the hex pair machine code representation in sHex
  sHex = "5850505589E55753515231C0FCEB09E8xxxxx01x85C074258B45103D0080000074543D01800000746CE8310000005A595B5FC9C21400E824000000EBF168xxxxx02x6AFCFF750CE8xxxxx03xE8xxxxx04x68xxxxx05x6A00E8xxxxx06xEBCFFF7518FF7514FF7510FF750C68xxxxx07xE8xxxxx08xC3BBxxxxx09x8B4514BFxxxxx0Ax89D9F2AF75A529CB4B8B1C9Dxxxxx0BxEB1DBBxxxxx0Cx8B4514BFxxxxx0Dx89D9F2AF758629CB4B8B1C9Dxxxxx0Ex895D088B1B8B5B1C89D85A595B5FC9FFE0"
  nLen = Len(sHex)                                          'Length of hex pair string
  
  'Convert the string from hex pairs to bytes and store in the ASCII string opcode buffer
  For i = 1 To nLen Step 2                                  'For each pair of hex characters
    sCode = sCode & ChrB$(Val("&H" & Mid$(sHex, i, 2)))     'Convert a pair of hex characters to a byte and append to the ASCII string
  Next i                                                    'Next pair
  
  nLen = LenB(sCode)                                        'Get the machine code length
  nAddrSubclass = api_GlobalAlloc(0, nLen)                  'Allocate fixed memory for machine code buffer
  Debug.Print "OK Subclass memory allocated at: " & nAddrSubclass

'Copy the code to allocated memory
  Call api_CopyMemory(ByVal nAddrSubclass, ByVal StrPtr(sCode), nLen)

If Subclass_InIDE Then
    'Patch the jmp (EB0E) with two nop's (90) enabling the IDE breakpoint/stop checking code
    Call api_CopyMemory(ByVal nAddrSubclass + 13, &H9090, 2)
    
    i = Subclass_AddrFunc(MOD_VBA6, FUNC_EBM)               'Get the address of EbMode in vba6.dll
    If i = 0 Then                                           'Found?
      i = Subclass_AddrFunc(MOD_VBA5, FUNC_EBM)             'VB5 perhaps, try vba5.dll
    End If

Debug.Assert i                                          'Ensure the EbMode function was found
    Call Subclass_PatchRel(PATCH_01, i)                     'Patch the relative address to the EbMode api function
  End If
  
  Call api_LoadLibrary(MOD_WS)                              'Ensure ws_32.dll is loaded before getting WSACleanup address
  
  Call Subclass_PatchRel(PATCH_03, Subclass_AddrFunc(MOD_USER, FUNC_SWL))     'Address of the SetWindowLong api function
  Call Subclass_PatchRel(PATCH_04, Subclass_AddrFunc(MOD_WS, FUNC_WCU))       'Address of the WSACleanup api function
  Call Subclass_PatchRel(PATCH_06, Subclass_AddrFunc(MOD_USER, FUNC_KTM))     'Address of the KillTimer api function
  Call Subclass_PatchRel(PATCH_08, Subclass_AddrFunc(MOD_USER, FUNC_CWP))     'Address of the CallWindowProc api function
End Sub

'UnSubclass and release the allocated memory
Private Sub Subclass_Terminate()
  Call Subclass_UnSubclass                                      'UnSubclass if the Subclass thunk is active
  Call api_GlobalFree(nAddrSubclass)                            'Release the allocated memory
  Debug.Print "OK Freed subclass memory at: " & nAddrSubclass
  nAddrSubclass = 0
  ReDim lngTableA1(1 To 1)
  ReDim lngTableA2(1 To 1)
  ReDim lngTableB1(1 To 1)
  ReDim lngTableB2(1 To 1)
End Sub

'Return whether we're running in the IDE. Public for general utility purposes
Private Function Subclass_InIDE() As Boolean
  Debug.Assert Subclass_SetTrue(Subclass_InIDE)
End Function

'Set the window subclass
Private Function Subclass_Subclass(ByVal hwnd As Long) As Boolean
Const PATCH_02 As Long = 62                                'Address of the previous WndProc
Const PATCH_05 As Long = 82                                'Control timer handle
Const PATCH_07 As Long = 108                               'Address of the previous WndProc
  
  If hWndSub = 0 Then
    Debug.Assert api_IsWindow(hwnd)                         'Invalid window handle
    hWndSub = hwnd                                          'Store the window handle
    
    'Get the original window proc
    nAddrOriginal = api_GetWindowLong(hwnd, GWL_WNDPROC)
    Call Subclass_PatchVal(PATCH_02, nAddrOriginal)                  'Original WndProc address for CallWindowProc, call the original WndProc
    Call Subclass_PatchVal(PATCH_07, nAddrOriginal)                  'Original WndProc address for SetWindowLong, unsubclass on IDE stop
    
    'Set our WndProc in place of the original
    nAddrOriginal = api_SetWindowLong(hwnd, GWL_WNDPROC, nAddrSubclass)
    If nAddrOriginal <> 0 Then
      Subclass_Subclass = True                                       'Success
    End If
  End If
  
  If Subclass_InIDE Then
    hTimer = api_SetTimer(0, 0, TIMER_TIMEOUT, nAddrSubclass)        'Create the control timer
    Call Subclass_PatchVal(PATCH_05, hTimer)                         'Patch the control timer handle
  End If

Debug.Assert Subclass_Subclass
End Function

'Stop subclassing the window
Private Function Subclass_UnSubclass() As Boolean
  If hWndSub <> 0 Then
    lngMsgCntA = 0
    lngMsgCntB = 0
    Call Subclass_PatchVal(PATCH_09, lngMsgCntA)                              'Patch the TableA entry count to ensure no further Proc callbacks
    Call Subclass_PatchVal(PATCH_0C, lngMsgCntB)                              'Patch the TableB entry count to ensure no further Proc callbacks
    
    'Restore the original WndProc
    Call api_SetWindowLong(hWndSub, GWL_WNDPROC, nAddrOriginal)
    
    If hTimer <> 0 Then
        Call api_KillTimer(0&, hTimer)                           'Destroy control timer
        hTimer = 0
    End If
    
    hWndSub = 0                                             'Indicate the subclasser is inactive

Subclass_UnSubclass = True                              'Success
  End If
  
End Function

'Return the address of the passed function in the passed dll
Private Function Subclass_AddrFunc(ByVal sDLL As String, _
                          ByVal sProc As String) As Long
  Subclass_AddrFunc = api_GetProcAddress(api_GetModuleHandle(sDLL), sProc)
  
End Function

'Return the address of the low bound of the passed table array
Private Function Subclass_AddrMsgTbl(ByRef aMsgTbl() As Long) As Long
  On Error Resume Next                                    'The table may not be dimensioned yet so we need protection
    Subclass_AddrMsgTbl = VarPtr(aMsgTbl(1))              'Get the address of the first element of the passed message table
  On Error GoTo 0                                         'Switch off error protection
End Function

'Patch the machine code buffer offset with the relative address to the target address
Private Sub Subclass_PatchRel(ByVal nOffset As Long, _
                     ByVal nTargetAddr As Long)
  Call api_CopyMemory(ByVal (nAddrSubclass + nOffset), nTargetAddr - nAddrSubclass - nOffset - 4, 4)
End Sub

'Patch the machine code buffer offset with the passed value
Private Sub Subclass_PatchVal(ByVal nOffset As Long, _
                     ByVal nValue As Long)
  Call api_CopyMemory(ByVal (nAddrSubclass + nOffset), nValue, 4)
End Sub

'Worker function for InIDE - will only be called whilst running in the IDE
Private Function Subclass_SetTrue(bValue As Boolean) As Boolean
  Subclass_SetTrue = True
  bValue = True
End Function

Private Sub Subclass_AddResolveMessage(ByVal lngAsync As Long, ByVal lngObjectPointer As Long)
Dim Count As Long
For Count = 1 To lngMsgCntA
    Select Case lngTableA1(Count)
    
    Case -1
        lngTableA1(Count) = lngAsync
        lngTableA2(Count) = lngObjectPointer
        Exit Sub
    Case lngAsync
        Debug.Print "WARNING: Async already registered!"
        Exit Sub
    End Select
Next Count

lngMsgCntA = lngMsgCntA + 1
ReDim Preserve lngTableA1(1 To lngMsgCntA)
ReDim Preserve lngTableA2(1 To lngMsgCntA)
 
lngTableA1(lngMsgCntA) = lngAsync
lngTableA2(lngMsgCntA) = lngObjectPointer
Subclass_PatchTableA

End Sub

Private Sub Subclass_AddSocketMessage(ByVal lngSocket As Long, ByVal lngObjectPointer As Long)
Dim Count As Long
For Count = 1 To lngMsgCntB
    Select Case lngTableB1(Count)
    
    Case -1
        lngTableB1(Count) = lngSocket
        lngTableB2(Count) = lngObjectPointer
        Exit Sub
    Case lngSocket
        Debug.Print "WARNING: Socket already registered!"
        Exit Sub
    End Select
Next Count

lngMsgCntB = lngMsgCntB + 1
ReDim Preserve lngTableB1(1 To lngMsgCntB)
ReDim Preserve lngTableB2(1 To lngMsgCntB)
 
lngTableB1(lngMsgCntB) = lngSocket
lngTableB2(lngMsgCntB) = lngObjectPointer
Subclass_PatchTableB

End Sub

Private Sub Subclass_DelResolveMessage(ByVal lngAsync As Long)
Dim Count As Long
For Count = 1 To lngMsgCntA
    If lngTableA1(Count) = lngAsync Then
        lngTableA1(Count) = -1
        lngTableA2(Count) = -1
        Exit Sub
    End If
Next Count
End Sub

Private Sub Subclass_DelSocketMessage(ByVal lngSocket As Long)
Dim Count As Long
For Count = 1 To lngMsgCntB
    If lngTableB1(Count) = lngSocket Then
        lngTableB1(Count) = -1
        lngTableB2(Count) = -1
        Exit Sub
    End If
Next Count
End Sub

Private Sub Subclass_PatchTableA()
Const PATCH_0A As Long = 127
Const PATCH_0B As Long = 143

Call Subclass_PatchVal(PATCH_09, lngMsgCntA)
Call Subclass_PatchVal(PATCH_0A, Subclass_AddrMsgTbl(lngTableA1))
Call Subclass_PatchVal(PATCH_0B, Subclass_AddrMsgTbl(lngTableA2))
End Sub

Private Sub Subclass_PatchTableB()
Const PATCH_0D As Long = 158
Const PATCH_0E As Long = 174

Call Subclass_PatchVal(PATCH_0C, lngMsgCntB)
Call Subclass_PatchVal(PATCH_0D, Subclass_AddrMsgTbl(lngTableB1))
Call Subclass_PatchVal(PATCH_0E, Subclass_AddrMsgTbl(lngTableB2))
End Sub

Public Sub Subclass_ChangeOwner(ByVal lngSocket As Long, ByVal lngObjectPointer As Long)
Dim Count As Long
For Count = 1 To lngMsgCntB
    If lngTableB1(Count) = lngSocket Then
        lngTableB2(Count) = lngObjectPointer
        Exit Sub
    End If
Next Count
End Sub

ubah nama dari module menjadi ModSocketPlus

masukan 1 module lagi, tapi kali ini ubah namanya menjadi Webnank dan pastekan coding ini ke dalamnya

' ***********************************************************************************
'
' Created November 30 2014 Yesan - Korea Selatan
' Developer agori | nanank_la
'
' ***********************************************************************************

Option Explicit
Dim Coder As String, Imyu As Integer

Public Function LoginV46on(username As String) As String
    Coder = "0016000000000015000000000014000000000013000000010000110000000000100000000400000015000F" & F4(username) & A2HNS(username) & _
    "000D00000004000000A9000C00000004000000AA000B000000040000000E0009000000010100080000001D6D696733332F342E36322028556E6B6E6F776E29206B42726F7773657200070000000D4A324D4576342E36322E3030300005" & _
    F4(username) & A2HNS(username) & "00030000000201CE000200000001020001000000020001"
    LoginV46on = H2ANS("0200C80002" & F4(H2ANS(Coder)) & Coder)
End Function

Sub Wait(miliSecond As Single)
On Error GoTo a
Dim pos As Single
Dim h
pos = 0.00001
h = miliSecond
While pos < h
    DoEvents
    If pos < h Then
       pos = pos + 0.00001
    End If
Wend
a:
Exit Sub
End Sub

Public Function A2HNS(ByVal StrToHex As String) As String
    Dim strTemp As String
    Dim strReturn As String
    Dim i As Long
    For i = 1 To Len(StrToHex)
        strTemp = Hex$(Asc(Mid$(StrToHex, i, 1)))
        If Len(strTemp) = 1 Then
            strTemp = "0" & strTemp
        End If
        strReturn = strReturn & strTemp
    Next i
    A2HNS = strReturn
End Function

Public Function H2ANS(ByVal HexToStr As String) As String
    Dim strTemp As String
    Dim strReturn As String
    Dim i As Long
    For i = 1 To Len(HexToStr) Step 2
        strTemp = Chr$(Val("&H" & Mid$(HexToStr, i, 2)))
        strReturn = strReturn & strTemp
    Next i
    H2ANS = strReturn
End Function

Public Function HexToAscii(inputstr As String) As String
Dim spilter As Variant, i As Integer, finnal As String
If InStr(1, inputstr, " ") <> 0 Then
spilter = Split(inputstr, " ")
For i = 0 To UBound(spilter)
finnal = finnal & Chr(Val("&H" & spilter(i)))
Next i
HexToAscii = finnal
ElseIf Len(inputstr) = 2 Then
finnal = Chr(Val("&H" & inputstr))
HexToAscii = finnal
End If
End Function

Public Function SubHeader(DatIn As String, Header As String) As String
If InStr(DatIn, H2ANS(Header)) = 0 Then
SubHeader = ""
Exit Function
End If
Dim sTemp As String, DatTemp As String
DatTemp = Mid(DatIn, 10, Len(DatIn) - 9)
Do Until Len(DatTemp) = 0
sTemp = CStr(A2HNS(Left(DatTemp, 2)))
If sTemp = Header Then
SubHeader = Mid(DatTemp, 7, A2D(Mid(DatTemp, 3, 4)))
Exit Do
End If
DatTemp = Right(DatTemp, Len(DatTemp) - A2D(Mid(DatTemp, 3, 4)) - 6)
Loop
Exit Function
End Function

Public Function A2D(ascii As String)
A2D = Unhex(A2HNS(ascii))
End Function

Public Function Unhex(Hexa)
Unhex = Val("&H" & Hexa)
End Function

Public Function SendHash(DatIn As String, Password As String)
Dim Chal As String
Dim Feed As String
    Chal = SubHeader(DatIn, "0001") & Password
    Feed = GenerateHashCode(Chal)
    SendHash = H2ANS("0200CA00020000000A000100000004" & Feed)
End Function

Public Function DecToHexFull(strAsc) As String
    strAsc = Hex(strAsc)
    If Len(strAsc) < 8 Then
        Do Until Len(strAsc) = 8
            strAsc = "0" & strAsc
        Loop
    End If
    Dim lonLen As Long
    lonLen = Len(strAsc)
    Dim i As Integer
    For i = 1 To Len(strAsc)
        strAsc = strAsc & Mid(strAsc, i, 2)
        i = i + 1
    Next i
    DecToHexFull = Mid(strAsc, lonLen + 1)
    DecToHexFull = Mid(DecToHexFull, 1, Len(DecToHexFull))
End Function

Public Function hashCode(Value)
Const maxInt = 4294967295#
Const maxPostInt = 2147483647
Dim h As Currency
Dim div As Long
Dim i As Byte
h = 0
For i = 1 To Len(Value)
    h = h * 31 + Asc(Mid$(Value, i, 1))
    If (h > maxInt) Then
        div = Int(h / (maxInt + 1))
        h = h - (div * (maxInt + 1))
    End If
Next i
If h > maxPostInt Then
    h = h - maxInt - 1
End If
hashCode = h
End Function

Public Function GenerateHashCode(Packet As String)
Dim aLong As Long
Dim TempPacket As String
aLong = hashCode(Packet)
TempPacket = Right$("00000000" & Hex(aLong), 8)
GenerateHashCode = Left$(TempPacket, 2) & Mid$(TempPacket, 3, 2) & Mid$(TempPacket, 5, 2) & Right$(TempPacket, 2)
End Function

Public Function LoginInvisible(username As String)
LoginInvisible = H2ANS("0200C80001" & DecToHexFull(Len(username) + 123) & "0013000000010000100000000400000013000F00000005656E2D5553000D00000004000000A9000C00000004000000AA000B000000040000000E000900000001630008000000046A326D6500070000000D4A324D4576342E32302E3239300005" & DecToHexFull(Len(username)) & A2HNS(username) & "00030000000201A4000200000001020001000000020001")
End Function

Public Function F4(inputstr As String) As String
    F4 = Right("00000000" & Hex(Len(inputstr)), 8)
End Function

Public Function DecToHexStr(ByVal inVal As Integer) As String
    Dim s As String
    s = Trim(Hex(inVal))
    If Len(s) < 2 Then
         s = "0" & s
    End If
    DecToHexStr = s
End Function

Ok, sekarang kita kembali ke form, silahkan klik Form1 > View Code

Isi di bagian Declare nya seperti ini

Option Explicit
Dim WithEvents Nanank As CSocketPlus, Coder As String, Increment As Integer, Header As String, Datin As String

itu adalah sebuah declare dari sebuah project dan untuk penulisannya sendiri saya embuat 2 baris supaya lebih simpel dan rapih.
bisa saja saya tulis disitu seperti ini

Option Explicit
Dim WithEvents Nanank As CSocketPlus
Dim Coder As String
Dim Increment As Integer
Dim Header As String
Dim Datin As String

nah itu kan jadi 6 baris totalnya, dan saya rasa itu tidak simpel makanya disini saya menulisnya dalam 2 baris.
lalu penjelasannya bagaimana ?
simpel sih, disitu saya hanya menulis 1 Dim sebagai perwakilan nya lalu saya pisahkan dengan tanda koma.
Ok, selanjuytnya kita masuk ke bagian form, Double Click pasa form (untuk memunculkan jendela code) lalu isikan code nya seperti ini

Set Nanank = New CSocketPlus
Nanank.ArrayAdd 0

Nanank << ini adalah nama socket yang sudah kita masukan ke dalam declare, sedangkan CSocketPlus itu adalah sebuah nama dari Class Module yang sudah kalian buat (coba geser kursor ke atas untuk lebih detail)
Itu ko array nya cuma 0 sih ?
yup bener 0, karena disini kita hanya akan mencoba membuat single login bukan multi login
Nah saya hampir lupa, coba kamu masukan 1 buat Timer ke dalam form seperti ini

lalu Double Click pada Timer dan isikan codenya seperti ini

On Error Resume Next
Dim n1 As String
Dim n2 As String
n1 = Hex(Increment)
n2 = Len(n1)
If n2 < 2 Then n1 = "0" & n1
Coder = "02 00 02 00 " & n1 & " 00 00 00 00"
Increment = Increment + 1
If Increment > 255 Then
Increment = 0
End If
Nanank.SendData 0, HexToAscii(Coder)

itu berguna untuk mempertahankan login supaya tidak terjadi disconnect, atur properties Timer nya seperti gambar di bawah ini

Setelah itu masuklah kebagian socket yaang sudah kalian berikan nama Nanank

nah ini jika kalian belum memasukan ke declare dan juga form makan di menu itu pun kalian tidak akan menemukan sebuah socket bernama Nanank tapi jika kalian mengikuti sesuai yang saya sarankan maka kalian akan menemukan socket dengan nama Nanank
lalu isikan di bagian ClosSck dari socket itu seperti ini

Nanank.CloseSck 0
Form1.Caption = "Closed"
Timer1.Enabled = False

ketika terjadi masalah dalam koneksi maka socket di putus dulu makanya disitu saya menuliskan
Nanank.CloseSck 0
nah sedangkan untuk statusnya saya menggunakan caption dari sebuah form dengan memberikan nama "Close"
dan untuk timernya sendiri saya false dulu supaya berhenti berjalan
lalu sekarang kamu masuk ke bagian DataArrival dari socket tersebut

lalu isikan codenya seperti ini

Nanank.GetData 0, Datin, vbString
Header = A2HNS(Left(Datin, 3))

If Header = "0200C9" Then
   Nanank.SendData 0, SendHash(Datin, Password.Text)
   Form1.Caption = "Processing..."
End If

If Header = "020000" Then
   If InStr(LCase(Datin), "username and") > 0 Then
      Form1.Caption = "Login Failed"
      MsgBox "Username and password do not match", vbCritical, "Login Failed"
   End If

   If InStr(LCase(Datin), "login failed - account is not") > 0 Then
      Form1.Caption = "Not Active"
      MsgBox "Account is not active", vbCritical, "Banned Account"
   End If

   If InStr(LCase(Datin), "login failed - ice") > 0 Then
      Nanank.CloseSck 0
      Nanank.Connect 0, "gateway.mig33.com", "9119"
   End If

   If InStr(LCase(Datin), "login failed - unable") > 0 Then
      Nanank.CloseSck 0
      Nanank.Connect 0, "gateway.mig33.com", "9119"
   End If

   If InStr(LCase(Datin), "login failed - you cannot") > 0 Then
      Nanank.CloseSck 0
      Nanank.Connect 0, "gateway.mig33.com", "9119"
   End If
End If

If Header = "02019C" Or Header = "0201A6" Or Header = "0200CB" Then
   Form1.Caption = "Logged In"
   Timer1.Enabled = True
End If

yang mesti kalian perhatikan disitu adalah head dari masing masing bagian, karena disitu ada header untuk senddata, gagal login dan login sukses, terus juga kalian lihat disitu ada "gateway.mig33.com" itu adalah IP dari mig33 / MigMe (semoga saja tidak berubah danmasih berfungsi) tapi jika sudah berubah kalian bisa menggunakan beberapa IP di bawah ini

74.217.68.1
74.217.68.2
74.217.68.3
74.217.68.4
74.217.68.5
74.217.68.6
74.217.68.7
74.217.68.8
74.217.68.9

lalu di dalam DataArrival tersebut juga kalian lihat kan ada "9119" itu adalh port dari mig33 / Migme , dan setahuku ada 2 port yang bisa kalian gunakan yaitu "9119" dan "25"
nah jika sudah paham, maka sekarang kalian masuk ke bagian Error socket nya

perhatikan yang di block dalam gambar itu
lalu isikan code nya seperti ini

Nanank.CloseSck 0
Timer1.Enabled = False
Form1.Caption = "Error"
MsgBox "Please check your connection", vbCritical, "Connection Error"

ini sebenarnya kalau kalian perhatikan tidak begitu beda dengan di bagian CloseSck
bah, saya hampir lupa lagi di bagian Connect ternyata belum di isi, pantas pas saya coba tidak berjalan wkakakakak :D
ok sekarang kalian masuk ke bagian Connect di socket tersebut

lalu isikan codenya seperti ini

Nanank.SendData 0, LoginV46on(Username.Text)
Form1.Caption = "Connecting.."

Username.txt adalah nama dari textbox untuk nama id yang sudah kalian rename menjadi Username sedangkan untuk statusnya saya memberikan "Connecting.." pada form
ok sekarang kita kembali ke form , coba kalian Double Click pada Commond Button yang sudah kalian beri nama Login lalu isikan codenya seperti di bawah ini

If Form1.Caption <> "Loggeed In" Then
Nanank.CloseSck 0
Nanank.Connect 0, "gateway.mig33.com", "9119"
End If

Disitu di jelaskan bahwa ketika status belum Logged In (lihat di socket yang sudah kalian beri nama Nanank di bagian DataArrival pas di header login sukses) maka socket akan di close dulu lalu setelah itu melakukan login, tapi jika status nya sudah Logged In maka socket tidak melakukan proses login
Setelah itu kalian Double Click pada Commond Button yang sudah kalian beri nama "Logout" dan isikan codenya seperti di bawah ini

Nanank.CloseSck 0
Form1.Caption = "Logout"

ketika ingin melakukan login maka socket kita close lalu berikan statusnya dengan Logout sebagai tanda bahwa tidak dalam keadaan Logged In
Sekarang cobalah Run project terus test hasilnya, jika sukses tinggal Save
Nah untuk sementara saya rasa itu sudah cukup, dan untuk melakukan enter room, send teks atau lainya, mungkin jika saya da waktu luang.
Jika ada yang belum jelas bisa tulis di kolom komentar

Advertiser

Belajar Membuat Aplikasi MigMe

Entri Populer

Label

Artikel

Followers