VB NetCat connections (via WinSock)

Following these interesting posts: the seed post, a question in MSDN forum, two Blogger Scott’s and Christophe’s (both similar, but Chistophe’s looks more evolved), and finally korean–japanese ones (no understanding of the chars…), should let get to a code to allow make GET/POST to any IP. This is an “abstract” from a post of Askur Corp, just keeping the interesting part of it:

Netcat utility allows to open a network connection interactively, or to pipe the input/output of another program to a network socket, but in some office environment one may find the Windows version of netcat blocked by enterprise security software. So if there is a locked-down sysadmin a port netcat to Microsoft Excel should come to the rescue.

The point here is to import Windows WinSock functions and defining the WinSock constants and data structures into the MS Office VBA environment. Once that is sorted out, it’s pretty quick to cobble together a user interface to allow the user to initiate a connection and to send/receive data.

But I must confess that there is a little caveat as, althought I could successfully make a connection, I could not been able to pull any data back from my requests. So, this post, is not jet finished.

Option Explicit

'!!!!!!!!!!!!!!!
Private Type tKey
    Id As Long
End Type
Private Type tCellResult
    Id As Long
End Type
Private Type tCellAddress
    keys() As tKey
    Exists() As tCellResult
    Item() As tCellResult
End Type

Dim CellAddress As tCellAddress
'!!!!!!!!!!!!!!!

Private Const SOCKET_ERROR As Long = -1
Private Const SOCK_STREAM As Long = 1
Private Const IPPROTO_IP As Long = 0
Private Const IPPROTO_UDP As Long = 17
Private Const IP_ADD_MEMBERSHIP As Long = 12
Private Const IP_DROP_MEMBERSHIP As Long = 13
Private Const AF_INET As Long = 2
Private Const SOCK_DGRAM As Long = 2
Private Const FD_SETSIZE As Long = 64
Private Const FIONBIO = 2147772030#
Private Const SOCKADDR_SIZE As Long = 16
Private Const SOCKADDR_IN_SIZE As Long = 16
Private Const FORMAT_MESSAGE_FROM_SYSTEM As Long = &H1000
Private Const WS_VERSION_REQD As Long = &H101
Private Const IP_SUCCESS As Long = 0

Private Type WSADATA
   wVersion As Integer
   wHighVersion As Integer
   szDescription As String * 257
   szSystemStatus As String * 129
   iMaxSockets As Integer
   iMaxUDPDG As Integer
   lpVendorInfo As Long
End Type

Private Type Hostent
    h_name As Long
    h_aliases As Long
    h_addrtype As Integer
    h_length As Integer
    h_addr_list As Long
End Type

Private Type SOCKADDR
   sin_family As Integer
   sin_zero As String * 14
End Type

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

#If VBA7 Then
    Private Type fd_set
       fd_count As LongPtr
       fd_array(FD_SETSIZE) As Long
    End Type
#Else
    Private Type fd_set
       fd_count As Long
       fd_array(FD_SETSIZE) As Long
    End Type
#End If

Private Type timeval
   tv_sec As Long
   tv_usec As Long
End Type

Private Type ip_mreq
    imr_multiaddr As Long
    imr_interface As Long
End Type

Private wd As WSADATA
Private LocalAddress As SOCKADDR_IN
Private ServerAddress As SOCKADDR_IN

'!!!
Public ip As String
Public remotePort As Integer
    Public Address As String
    Public port As Integer
'!!!
Public SocketHandle As Long
Private listenPort As Integer
Private localHostName As String
Private localHostIP As String
Private remoteAddr As SOCKADDR_IN
Private recvBuffer As String * 2048
Private fromAddr As SOCKADDR_IN
Private fromAddrSize As Long
Private SendSocketHandle As Long
Private ListenSocketHandle As Long
Private Joined As Boolean
Private UserDetails As String

Private previousToken As Integer
Public tokenCount As Integer
Private Const reSendLimit As Integer = 3
Private Const reqLength As Long = 500
Private isComplete As Boolean
Private GUID As String
Private tokenSeperator As String
Private dataSeparator As String
Private valueSeperator As String

#If VBA7 Then
    Private Declare PtrSafe Function gethostbyname Lib "wsock32.dll" (ByVal host_name As String) As Long
    Private Declare PtrSafe Function gethostname Lib "wsock32.dll" (ByVal host_name As String, ByVal namelen As Integer) As Integer
    Private Declare PtrSafe Function setsockopt Lib "wsock32.dll" (ByVal S As LongPtr, ByVal level As LongPtr, ByVal optname As LongPtr, optval As Any, ByVal optlen As LongPtr) As Long
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
    Private Declare PtrSafe Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal Buffer As String, Size As Long) As Long

    Private Declare PtrSafe Function WSAStartup Lib "wsock32.dll" (ByVal wVersionRequired&, lpWSADATA As WSADATA) As Long
    Private Declare PtrSafe Function WSACleanup Lib "wsock32.dll" () As Long
    Private Declare PtrSafe Function w_socket Lib "wsock32.dll" Alias "socket" (ByVal lngAf As LongPtr, ByVal lngType As LongPtr, ByVal lngProtocol As LongPtr) As Long
    Private Declare PtrSafe Function w_closesocket Lib "wsock32.dll" Alias "closesocket" (ByVal socketHandle As LongPtr) As Long
    Private Declare PtrSafe Function w_bind Lib "wsock32.dll" Alias "bind" (ByVal SOCKET As LongPtr, Name As SOCKADDR_IN, ByVal namelen As Long) As Long
    Private Declare PtrSafe Function w_connect Lib "wsock32.dll" Alias "connect" (ByVal SOCKET As LongPtr, Name As SOCKADDR_IN, ByVal namelen As LongPtr) As Long
    Private Declare PtrSafe Function w_send Lib "wsock32.dll" Alias "send" (ByVal SOCKET As LongPtr, buf As Any, ByVal length As LongPtr, ByVal Flags As LongPtr) As Long
Private Declare PtrSafe Function w_sendTo Lib "wsock32.dll" Alias "sendto" (ByVal SOCKET As LongPtr, buf As Any, ByVal length As LongPtr, ByVal Flags As LongPtr, remoteAddr As SOCKADDR_IN, ByVal remoteAddrSize As LongPtr) As Long
    Private Declare PtrSafe Function w_recv Lib "wsock32.dll" Alias "recv" (ByVal SOCKET As LongPtr, buf As Any, ByVal length As LongPtr, ByVal Flags As LongPtr) As Long
Private Declare PtrSafe Function w_recvFrom Lib "wsock32.dll" Alias "recvfrom" (ByVal SOCKET As LongPtr, buf As Any, ByVal length As LongPtr, ByVal Flags As Long, fromAddr As SOCKADDR_IN, fromAddrSize As Long) As Long
    Private Declare PtrSafe Function w_select Lib "wsock32.dll" Alias "select" (ByVal nfds As Long, readFds As fd_set, writeFds As fd_set, exceptFds As fd_set, timeout As timeval) As Long
Private Declare PtrSafe Function w_getLastError Lib "wsock32.dll" Alias "WSAGetLastError" () As Integer
    Private Declare PtrSafe Function htons Lib "wsock32.dll" (ByVal hostshort As Long) As Long
    Private Declare PtrSafe Function ntohl Lib "wsock32.dll" (ByVal netlong As Long) As Long
    Private Declare PtrSafe Function inet_addr Lib "wsock32.dll" (ByVal cp As String) As Long
#Else
    Private Declare Function gethostbyname Lib "wsock32.dll" (ByVal host_name As String) As Long
    Private Declare Function gethostname Lib "wsock32.dll" (ByVal host_name As String, ByVal namelen As Integer) As Integer
    Private Declare Function setsockopt Lib "wsock32.dll" (ByVal S As Long, ByVal level As Long, ByVal optname As Long, optval As Any, ByVal optlen As Long) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
    Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal Buffer As String, Size As Long) As Long

    Private Declare Function WSAStartup Lib "wsock32.dll" (ByVal intVersionRequested As Integer, lpWSAData As WSADATA) As Long
    Private Declare Function WSACleanup Lib "wsock32.dll" () As Long
    Private Declare Function w_socket Lib "wsock32.dll" Alias "socket" (ByVal lngAf As Long, ByVal lngType As Long, ByVal lngProtocol As Long) As Long
    Private Declare Function w_closesocket Lib "wsock32.dll" Alias "closesocket" (ByVal SocketHandle As Long) As Long
    Private Declare Function w_bind Lib "wsock32.dll" Alias "bind" (ByVal SOCKET As Long, Name As SOCKADDR_IN, ByVal namelen As Long) As Long
    Private Declare Function w_connect Lib "wsock32.dll" Alias "connect" (ByVal SOCKET As Long, Name As SOCKADDR_IN, ByVal namelen As Long) As Long
    Private Declare Function w_send Lib "wsock32.dll" Alias "send" (ByVal SOCKET As Long, ByVal buf As String, ByVal length As Long, ByVal Flags As Long) As Long
    Private Declare Function w_sendTo Lib "wsock32.dll" Alias "sendto" (ByVal SOCKET As Long, buf As Any, ByVal length As Long, ByVal Flags As Long, remoteAddr As SOCKADDR_IN, ByVal remoteAddrSize As Long) As Long
    Private Declare Function w_recv Lib "wsock32.dll" Alias "recv" (ByVal SOCKET As Long, ByVal buf As String, ByVal length As Long, ByVal Flags As Long) As Long
    Private Declare Function w_recvFrom Lib "wsock32.dll" Alias "recvfrom" (ByVal SOCKET As Long, buf As Any, ByVal length As Long, ByVal Flags As Long, fromAddr As SOCKADDR_IN, fromAddrSize As Long) As Long
    Private Declare Function w_select Lib "wsock32.dll" Alias "select" (ByVal nfds As Long, readFds As fd_set, writeFds As fd_set, exceptFds As fd_set, timeout As timeval) As Long
Private Declare Function w_getLastError Lib "wsock32.dll" Alias "WSAGetLastError" () As Integer
    Private Declare Function htons Lib "wsock32.dll" (ByVal hostshort As Integer) As Integer
    Private Declare Function ntohl Lib "wsock32.dll" (ByVal netlong As Long) As Long
    Private Declare Function inet_addr Lib "wsock32.dll" (ByVal Address As String) As Long
Private Declare Function ioctlsocket Lib "wsock32.dll" (ByVal SOCKET As Long, ByVal cmd As Long, argp As Long) As Long
Private Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" (ByVal dwFlags As Long, lpSource As Any, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, Arguments As Long) As Long
#End If

'------------------
' one implementation
'------------------

Public Sub InitializeConnection()
    ip = "224.0.0.1"
    listenPort = 3001
    remotePort = 3002

    'FinalizeSilverlightConnection
    If (Not SocketsInitialize()) Then
        MsgBox "Error initializing WinSock"
        Return
    End If
    SendSocketHandle = w_socket(AF_INET, SOCK_DGRAM, IPPROTO_UDP)

    remoteAddr.sin_family = AF_INET
    remoteAddr.sin_addr = inet_addr(ip)
    remoteAddr.sin_port = UnsignedLongToInteger(htons(remotePort))

    localHostName = GetPcName()
    'localHostIP = GetIPFromHostName(localHostName)

    ListenSocketHandle = w_socket(AF_INET, SOCK_DGRAM, IPPROTO_UDP)
    Dim listenAddr As SOCKADDR_IN
    listenAddr.sin_family = AF_INET
    listenAddr.sin_addr = inet_addr(localHostIP)
    listenAddr.sin_port = UnsignedLongToInteger(htons(listenPort))
    Dim bindResult As Long
    bindResult = w_bind(ListenSocketHandle, listenAddr, SOCKADDR_IN_SIZE)
    If bindResult = SOCKET_ERROR Then
        MsgBox "Error binding listener socket: " & CStr(Err.LastDllError)
        Call SocketsCleanup
        'Return
    End If

    If JoinSourceGroup(ListenSocketHandle, inet_addr(ip), inet_addr(localHostIP)) = SOCKET_ERROR Then
        Call SocketsCleanup
    Else
        Joined = True
    End If
End Sub

Public Sub FinalizeSilverlightConnection()
    If Joined Then DropSourceGroup ListenSocketHandle, inet_addr(ip), inet_addr(localHostIP)
    Call SocketsCleanup
End Sub

Private Function JoinSourceGroup(SocketHandle As Long, GroupAddress As Long, InterfaceAddress As Long) As Long
    Dim Error As Long
    Dim imr As ip_mreq

    imr.imr_multiaddr = GroupAddress
    imr.imr_interface = InterfaceAddress

    Error = setsockopt(SocketHandle, IPPROTO_IP, IP_ADD_MEMBERSHIP, imr, LenB(imr))

    If Error = SOCKET_ERROR Then
        MsgBox "Error Setting IP_ADD_MEMBERSHIP: " & CStr(Err.LastDllError)
    End If

    JoinSourceGroup = Error
End Function

Private Function DropSourceGroup(SOCKET As Long, GroupAddress As Long, InterfaceAddress As Long) As Long
    Dim Error As Long
    Dim imr As ip_mreq

    imr.imr_multiaddr = GroupAddress
    imr.imr_interface = InterfaceAddress

    Error = setsockopt(SOCKET, IPPROTO_IP, IP_DROP_MEMBERSHIP, imr, LenB(imr))
    If Error = SOCKET_ERROR Then
        MsgBox "Error Setting IP_DROP_MEMBERSHIP: " & CStr(Err.LastDllError)
    End If

    DropSourceGroup = Error
End Function

Public Sub ProcessData()
    Dim tempReq As String
    Dim processRes As String
    Dim sendResult As Long
    Dim rndToken As Integer

'!!!!!!!!!!!!!!!
    Dim keys As tKey
'!!!!!!!!!!!!!!!

    rndToken = Int((999 - 100 + 1) * Rnd + 100)  ' Random number between 100 and 999
    tempReq = XOREncryption(UserDetails, GUID & tokenSeperator & "Excel Start" & tokenSeperator & rndToken)
    processRes = SendData(tempReq, rndToken)
    tempReq = ""

''    For Each keys In CellAddress.keys
''        If Len(tempReq & dataSeparator & keys) > reqLength Then
''            rndToken = Int((999 - 100 + 1) * Rnd + 100)  ' Random number between 100 and 999
''            tempReq = XOREncryption(UserDetails, GUID & tokenSeperator & tempReq & tokenSeperator & rndToken)
''            processRes = SendData(tempReq, rndToken)
''            tempReq = keys
''        Else
''            If tempReq = "" Then
''                tempReq = keys
''            Else
''                tempReq = tempReq & dataSeparator & keys
''            End If
''        End If
''    Next

    If tempReq  "" Then
        rndToken = Int((999 - 100 + 1) * Rnd + 100)  ' Random number between 100 and 999
        tempReq = XOREncryption(UserDetails, GUID & tokenSeperator & tempReq & tokenSeperator & rndToken)
        processRes = SendData(tempReq, rndToken)
    End If

    rndToken = Int((999 - 100 + 1) * Rnd + 100)  ' Random number between 100 and 999
    tempReq = XOREncryption(UserDetails, GUID & tokenSeperator & "Excel Stop" & tokenSeperator & rndToken)
    processRes = SendData(tempReq, rndToken)

    isComplete = False
    Do While isComplete = False
        rndToken = Int((999 - 100 + 1) * Rnd + 100)  ' Random number between 100 and 999
        tempReq = XOREncryption(UserDetails, GUID & tokenSeperator & "Excel" & tokenSeperator & rndToken)
        processRes = SendData(tempReq, rndToken)
    Loop
End Sub

Private Function SendData(strBuffer As String, rndToken As Integer) As String
' Send the psuedo command / request
    Dim i As Long
    Dim sendResult As Long
    Dim processRes As String
    Dim tempReq As String

    If strBuffer  "" Then
        sendResult = w_sendTo(SendSocketHandle, ByVal strBuffer, Len(strBuffer), 0, remoteAddr, SOCKADDR_IN_SIZE)
    End If

    ' Wait for the response
    Dim SelectTiming As Integer
    SelectTiming = recvfromTimeOutUDP(ListenSocketHandle, 5, 0)
    ' Evaluate the response
    Select Case SelectTiming
        Case 0
            If rndToken  previousToken Then
                previousToken = rndToken
                tokenCount = 1
            Else
                tokenCount = tokenCount + 1
            End If
            If tokenCount > reSendLimit Then
                SendData = "Listener timed out waiting for a response from the server"
            Else
                processRes = SendData(strBuffer, rndToken)
            End If
        Case -1
            SendData = "Error encountered.  Code = " & CStr(w_getLastError())

        Case Else   ' Found some data
            Dim recvResult As Long
            Dim arrResult As Variant
            Dim dtResult As Variant
            Dim cellResult As Variant

            recvBuffer = ""
            fromAddrSize = SOCKADDR_SIZE
            recvResult = w_recvFrom(ListenSocketHandle, ByVal recvBuffer, Len(recvBuffer), 0, fromAddr, fromAddrSize)
            recvBuffer = XORDecryption(UserDetails, recvBuffer)
            arrResult = Split(recvBuffer, tokenSeperator)

            If UBound(arrResult) = 3 Then
                If arrResult(0) = rndToken Then
                    If arrResult(1) = "I am here" Then
                        Dim senderIP As String
                        senderIP = LongIP2Dotted(fromAddr.sin_addr)
                        If senderIP = localHostIP Or senderIP = "0.0.0.0" Then
                            If arrResult(2) = "" Then
                                processRes = SendData(strBuffer, rndToken)
                            Else
                                SendData = arrResult(2)
                            End If
                        End If

                    ElseIf arrResult(1) = "End Silverlight Responce" Then
                        isComplete = True

                    ElseIf arrResult(1)  "Silverlight" Then
                        tempReq = ""
                        dtResult = Split(arrResult(1), dataSeparator)

                        For i = LBound(dtResult) To UBound(dtResult)
''                            cellResult = Split(dtResult(i), valueSeperator)
''                            If CellAddress.Exists(cellResult(0)) Then
''                                CellAddress.Item(cellResult(0)) = cellResult(1)
''                            End If
                        Next i

                    Else
                        ' Do nothing
                    End If
                Else
                    processRes = SendData(strBuffer, rndToken)
                End If
            Else
                SendData = "Invalid Value"
            End If
    End Select
End Function

Private Sub SocketsCleanup()
    w_closesocket (ListenSocketHandle)
    w_closesocket (SendSocketHandle)
    If WSACleanup()  0 Then
        MsgBox "Windows Sockets error occurred in Cleanup.", vbExclamation
    End If
End Sub

Public Function SocketsInitialize() As Boolean
    Dim WSAD As WSADATA
    SocketsInitialize = WSAStartup(WS_VERSION_REQD, WSAD) = IP_SUCCESS
End Function

Private Function GetPcName() As String
    Dim strBuf As String * 16, strPcName As String, lngPc As Long
    lngPc = GetComputerName(strBuf, Len(strBuf))
    If lngPc  0 Then
        strPcName = Left(strBuf, InStr(strBuf, vbNullChar) - 1)
        GetPcName = strPcName
    Else
        GetPcName = vbNullString
    End If
End Function

Private Function GetIPFromHostName(ByVal sHostName As String) As String
    'converts a host name to an IP address.
    Dim nbytes As Long
    Dim ptrHosent As Long 'address of hostent structure
    Dim ptrName As Long 'address of name pointer
    Dim ptrAddress As Long 'address of address pointer
    Dim ptrIPAddress As Long
    Dim sAddress As String
    sAddress = Space$(4)
    ptrHosent = gethostbyname(sHostName & vbNullChar)
    If ptrHosent  0 Then
    ptrName = ptrHosent
    ptrAddress = ptrHosent + 12
    'get the IP address
    CopyMemory ptrName, ByVal ptrName, 4
    CopyMemory ptrAddress, ByVal ptrAddress, 4
    CopyMemory ptrIPAddress, ByVal ptrAddress, 4
    CopyMemory ByVal sAddress, ByVal ptrIPAddress, 4
    GetIPFromHostName = IPToText(sAddress)
    End If
End Function

Private Function IPToText(ByVal IPAddress As String) As String
    IPToText = CStr(Asc(IPAddress)) & "." & _
     CStr(Asc(Mid$(IPAddress, 2, 1))) & "." & _
     CStr(Asc(Mid$(IPAddress, 3, 1))) & "." & _
     CStr(Asc(Mid$(IPAddress, 4, 1)))
End Function

Private Function UnsignedLongToInteger_mine(uLong As Long) As Integer
    If uLong > 32767 Then
'!?        UnsignedLongToInteger = uLong - 65536
    Else
'!?        UnsignedLongToInteger = uLong
    End If
End Function

Private Function UnsignedLongToInteger(uLong As Long) As Integer
    If uLong > 32767 Then
        UnsignedLongToInteger = uLong - 65536
    Else
        UnsignedLongToInteger = uLong
    End If
End Function

Private Function recvfromTimeOutUDP(SocketHandle As Long, sec As Long, usec As Long) As Integer
    'Setup timeval variable
    Dim timeout As timeval
    Dim readFds As fd_set
    Dim writeFds As fd_set
    Dim exceptFds As fd_set
    timeout.tv_sec = sec
    timeout.tv_usec = usec

    'Setup fd_set structure
    readFds.fd_array(0) = SocketHandle
    readFds.fd_count = 1
    writeFds.fd_count = 0
    exceptFds.fd_count = 0

    'Return value:
    '-1: error occurred
    '0: timed out
    '> 0: data ready to be read

    recvfromTimeOutUDP = w_select(0, readFds, writeFds, exceptFds, timeout)
End Function

Private Function Dotted2LongIP(DottedIP As String) As Variant
    ' errors will result in a zero value
    On Error Resume Next
    Dim i As Byte, pos As Integer
    Dim PrevPos As Integer, num As Integer
    ' string cruncher
    For i = 1 To 4
        ' Parse the position of the dot
        pos = InStr(PrevPos + 1, DottedIP, ".", 1)
        ' If its past the 4th dot then set pos to the last
        'position + 1
        If i = 4 Then pos = Len(DottedIP) + 1
       ' Parse the number from between the dots
        num = Int(Mid(DottedIP, PrevPos + 1, pos - PrevPos - 1))
        ' Set the previous dot position
        PrevPos = pos
        ' No dot value should ever be larger than 255
        ' Technically it is allowed to be over 255 -it just
        ' rolls over e.g.
         '256 => 0 -note the (4 - i) that's the
         'proper exponent for this calculation

      Dotted2LongIP = ((num Mod 256) * (256 ^ (4 - i))) + _
         Dotted2LongIP
    Next
End Function

Private Function LongIP2Dotted(ByVal LongIP As Variant) As String
' convert long IP to dotted notation
    On Error GoTo ExitFun
    If LongIP = "" Or LongIP  255 Then Err.Raise vbObjectError + 1
        ' string builder
        If i = 1 Then
            ' 1st dot value has no leading dot
            LongIP2Dotted = num
        Else
            ' other dot values have a leading dot
            LongIP2Dotted = num & "." & LongIP2Dotted
        End If
    Next
Exit Function
ExitFun:
     LongIP2Dotted = "0.0.0.0" '"Invalid Input" ' whatever
End Function

'------------------
' one implementation
'------------------

Public Sub NetCat()
    frmConnection.Show
End Sub

Public Function DoConnect(ByVal Address As String, Optional ByVal port As Long = 80) As Long
    Dim lgRetVal As Long

    lgRetVal = WSAStartup(&H101, wd)                            'Init winsock
    'Debug.Print lgRetVal

    SocketHandle = w_socket(AF_INET, SOCK_STREAM, 0)       'Open socket, get sockethandle

    LocalAddress.sin_family = AF_INET
    LocalAddress.sin_port = 0 'local port defined by operating system
    LocalAddress.sin_addr = 0 'local address

    lgRetVal = w_bind(SocketHandle, LocalAddress, SOCKADDR_IN_SIZE) 'Bind socket to local port

    ServerAddress.sin_family = AF_INET
    ServerAddress.sin_port = htons(port) 'port number
    ServerAddress.sin_addr = inet_addr(Address) 'ip address

    lgRetVal = w_connect(SocketHandle, ServerAddress, SOCKADDR_IN_SIZE)

    lgRetVal = DoConnect
End Function

Public Sub DoDisconnect()
    'If SocketHandle  -1 Then w_closesocket SocketHandle ...
    w_closesocket SocketHandle
    WSACleanup

    frmNetCat.Hide
    Unload frmNetCat

    'frmConnection.Show
    Unload frmConnection
End Sub

Public Function SendText(ByVal str As String) As Long
    Dim strData As String
    Dim lgRetVal As Long

    strData = str & vbCrLf & vbCrLf
    lgRetVal = w_send(SocketHandle, strData, Len(strData), 0)
End Function

Public Function ReceiveText() As String
    Dim retBuff As String * 1024
    Dim lgRetVal As Long
    Dim strResponse As String

    retBuff = ""
    strResponse = ""
    Do
        lgRetVal = w_recv(SocketHandle, retBuff, 1024, 0)
        If lgRetVal > 0 Then strResponse = strResponse & retBuff
    Loop While lgRetVal > 0
    ReceiveText = strResponse
End Function

'------------------
' one implementation
'------------------

Private Sub CloseSocket(SOCKET As Long)
    If SOCKET  -1 Then w_closesocket SOCKET
    WSACleanup
End Sub

'Private Sub sReadURL()
'    Dim adr As SOCKADDR_IN
'    Dim URL As String
'    Dim hh As Variant
'
'    adr.sin_addr = inet_addr("66.102.11.104")
'    adr.sin_port = htons(80)
'
'    adr.sin_family = AF_INET
'    hh = ReadURI(adr, URL)
'    MsgBox hh
'End Sub
'
'Public Function ReadURI(Address As SOCKADDR_IN, Port As String)
'    Dim ret As Long
'    Dim SocketHandle As Long
'    Dim wd As WSADATA
'    Dim localAddress As SOCKADDR_IN
'    Dim serverAddress As SOCKADDR_IN
'    Dim URIRequest As String
'    Dim retBuff(1000) As Byte
'    Dim retString As String
'    Dim tempString As String
'
'    retString = vbNullString
'    SocketHandle = -1
'    ret = WSAStartup(&H101, wd)
'
'    If ret  0 Then GoTo ErrorHandler
'    SocketHandle = w_socket(AF_INET, SOCK_STREAM, 0)
'
'    If SocketHandle = -1 Then GoTo ErrorHandler
'    localAddress.sin_family = AF_INET
'    localAddress.sin_port = 0
'    localAddress.sin_addr = 0
'    ret = w_bind(SocketHandle, localAddress, SOCKADDR_IN_SIZE)
'
'    If ret = -1 Then GoTo ErrorHandler
'
'    serverAddress.sin_family = AF_INET
'    serverAddress.sin_port = htons(80)
'    serverAddress.sin_addr = inet_addr(Address)
'
'    ret = w_connect(SocketHandle, serverAddress, SOCKADDR_IN_SIZE)
'    If ret = -1 Then GoTo ErrorHandler
'
'    URIRequest = "GET /" & URI & " HTTP/1.0" & vbCrLf & vbCrLf
'
'    ret = w_send(SocketHandle, ByVal URIRequest, Len(URIRequest), 0)
'    If ret = -1 Then GoTo ErrorHandler
'
'    Do
'        ret = w_recv(SocketHandle, retBuff(0), 1000, 0)
'        If ret = -1 Then GoTo ErrorHandler
'        If ret > 0 Then
'            tempString = StrConv(retBuff, vbUnicode)
'            retString = retString & Left(tempString, ret)
'        End If
'    Loop While ret > 0
'
'    ReadURI = retString
'
'ErrorHandler:
'    CloseSocket SocketHandle
'End Function

'------------------
' one implementation
'------------------

Public Function sendMsg(Address As String, port As Integer, URI As String)
'https://blog.stevens.club/2016/10/interaction-between-vbaexcel-and-java.html
    Dim ret As Long
    Dim SocketHandle As Long
    Dim wd As WSADATA
    Dim LocalAddress As SOCKADDR_IN
    Dim ServerAddress As SOCKADDR_IN
    Dim URIRequest As String
    Dim retBuff(1024) As Byte
    Dim retString As String
    Dim tempstring As String

    sendMsg = ""
    SocketHandle = -1
    ret = WSAStartup(&H101, wd)
    If ret  0 Then GoTo ErrorHandler

    SocketHandle = w_socket(AF_INET, SOCK_STREAM, 0)

    If SocketHandle = -1 Then GoTo ErrorHandler

    LocalAddress.sin_family = AF_INET
    LocalAddress.sin_port = 0
    LocalAddress.sin_addr = 0
    ret = w_bind(SocketHandle, LocalAddress, SOCKADDR_IN_SIZE)

    If ret = -1 Then GoTo ErrorHandler

    ServerAddress.sin_family = AF_INET
    ServerAddress.sin_port = htons(port)
    ServerAddress.sin_addr = inet_addr(Address)
    ret = w_connect(SocketHandle, ServerAddress, SOCKADDR_IN_SIZE)

    If ret = -1 Then GoTo ErrorHandler

    URIRequest = URI & vbCrLf
    ret = w_send(SocketHandle, ByVal URIRequest, Len(URIRequest), 0)

    If ret = -1 Then GoTo ErrorHandler

ErrorHandler:
    CloseSocket SocketHandle
End Function

Public Function XORDecryption(CodeKey As String, DataIn As String) As String
    Dim lonDataPtr As Long
    Dim strDataOut As String
    Dim intXOrValue1 As Integer
    Dim intXOrValue2 As Integer

    For lonDataPtr = 1 To (Len(DataIn) / 2)
        'The first value to be XOr-ed comes from the data to be encrypted
        intXOrValue1 = Val("&H" & (Mid$(DataIn, (2 * lonDataPtr) - 1, 2)))
        'The second value comes from the code key
        intXOrValue2 = Asc(Mid$(CodeKey, ((lonDataPtr Mod Len(CodeKey)) + 1), 1))

        strDataOut = strDataOut + Chr(intXOrValue1 Xor intXOrValue2)
    Next lonDataPtr
    XORDecryption = strDataOut
End Function

Private Function XOREncryption(CodeKey As String, DataIn As String) As String
    Dim lonDataPtr As Long
    Dim strDataOut As String
    Dim temp As Integer
    Dim tempstring As String
    Dim intXOrValue1 As Integer
    Dim intXOrValue2 As Integer

    For lonDataPtr = 1 To Len(DataIn)
        'The first value to be XOr-ed comes from the data to be encrypted
        intXOrValue1 = Asc(Mid$(DataIn, lonDataPtr, 1))
        'The second value comes from the code key
        intXOrValue2 = Asc(Mid$(CodeKey, ((lonDataPtr Mod Len(CodeKey)) + 1), 1))

        temp = (intXOrValue1 Xor intXOrValue2)
        tempstring = Hex(temp)
        If Len(tempstring) = 1 Then tempstring = "0" & tempstring

        strDataOut = strDataOut + tempstring
    Next lonDataPtr
    XOREncryption = strDataOut
End Function

Private Function fEncrypt(ByVal strSourceText As String, _
                          Optional ByVal strCodeKey As String = "") As String

    If strCodeKey = vbNullString Then
        strCodeKey = InputBox("Please enter your password", "XOr Decryption")
    End If
    fEncrypt = XOREncryption(strCodeKey, strSourceText)
End Function

Private Function fDecrypt(ByVal strSourceText As String, _
                          Optional ByVal strCodeKey As String = "") As String
    If strCodeKey = vbNullString Then
        strCodeKey = InputBox("Please enter your password", "XOr Decryption")
    End If
    fDecrypt = XORDecryption(strCodeKey, strSourceText)
End Function
[/sourcecode]