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 koreanjapanese 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]

Leave a Reply

Your email address will not be published. Required fields are marked *