Running Winsock in VBA MS Access

[nector]

Dear All

I would like to ask for assistance on VBA Winsock 2.2 I have seen its similar to COM port communication , I have been using a serial port (COM) for server communication for several years and all is fine but the COM port method does not allow users to share the dedicated COM Port which is responsible for sending back the accessed messages. For example the message will be send to that instrument and then the instrument will reply by sending back the requested message.

From this site I have seen the library below I have read it but I got stuck on how to call the winsock due to lack of proper commented notes, for example starting the winsock if called from another module I thought its supposed to be :

'Start Winsock Session
StartWinsock(2.2) 'is this the correct way of starting winsok2.2

In other words the sequence of calling the functions according my scant understanding are as below:

StartWinsock(2.2)

'************************************************************
'Sending data
'************************************************************
SendDataToBuffer("IpAddress(Server),Portnumber(server)",DatatoSend)

'************************************************************
'Reading data
'************************************************************
ReadDataToBuffer("IpAddress(Server),Portnumber(server)") As Long

But I keep on not getting right , could it be I'm missing something in MS Access


Below is VBA Bas I got from here:

Public Const SERVER_TO_CONNECT = "IP Address for the server"

Public Const AF_INET = 2
Public Const INVALID_SOCKET = -1
Public Const SOCKET_ERROR = -1
Public Const FD_READ = &H1&
Public Const FD_WRITE = &H2&
Public Const FD_CONNECT = &H10&
Public Const FD_CLOSE = &H20&
Public Const PF_INET = 2
Public Const SOCK_STREAM = 1
Public Const IPPROTO_TCP = 6
Public Const GWL_WNDPROC = (-4)
Public Const WINSOCKMSG = 1025
Public Const WSA_DESCRIPTIONLEN = 256
Public Const WSA_DescriptionSize = WSA_DESCRIPTIONLEN + 1
Public Const WSA_SYS_STATUS_LEN = 128
Public Const WSA_SysStatusSize = WSA_SYS_STATUS_LEN + 1
Public Const INADDR_NONE = &HFFFF
Public Const SOL_SOCKET = &HFFFF&
Public Const SO_LINGER = &H80&
Public Const SD_SEND = &H1
Public Const SD_BOTH = &H2

Public Const hostent_size = 16
Public Const sockaddr_size = 16
Type WSADataType
    wVersion As Integer
    wHighVersion As Integer
    szDescription As String * WSA_DescriptionSize
    szSystemStatus As String * WSA_SysStatusSize
    iMaxSockets As Integer
    iMaxUdpDg As Integer
    lpVendorInfo As Long
End Type
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
Type sockaddr
    sin_family As Integer
    sin_port As Integer
    sin_addr As Long
    sin_zero As String * 8
End Type
Type LingerType
    l_onoff As Integer
    l_linger As Integer
End Type
Public Declare PtrSafe Function FindWindowA Lib "user32.dll" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Public Declare PtrSafe 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
Public Declare PtrSafe Function getsockopt Lib "wsock32.dll" (ByVal s As Long, ByVal Level As Long, ByVal optname As Long, optval As Any, optlen As Long) As Long
Public Declare PtrSafe Function WSAGetLastError Lib "wsock32.dll" () As Long
Public Declare PtrSafe Function SetWindowLongPtr Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
Public Declare PtrSafe Function CallWindowProc Lib "user32" Alias "CallWindowProcW" (ByVal lpPrevWndFunc As LongPtr, ByVal hwnd As LongPtr, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As LongPtr) As LongPtr
Public Declare PtrSafe Function WSAIsBlocking Lib "wsock32.dll" () As Long
Public Declare PtrSafe Function WSACleanup Lib "wsock32.dll" () As Long
Public Declare PtrSafe Function Send Lib "wsock32.dll" Alias "send" (ByVal s As Long, buf As Any, ByVal buflen As Long, ByVal flags As Long) As Long
Public Declare PtrSafe Function recv Lib "wsock32.dll" (ByVal s As Long, buf As Any, ByVal buflen As Long, ByVal flags As Long) As Long
Public Declare PtrSafe Function WSAStartup Lib "wsock32.dll" (ByVal wVR As Long, lpWSAD As WSADataType) As Long
Public Declare PtrSafe Function htons Lib "wsock32.dll" (ByVal hostshort As Long) As Integer
Public Declare PtrSafe Function ntohs Lib "wsock32.dll" (ByVal netshort As Long) As Integer
Public Declare PtrSafe Function socket Lib "wsock32.dll" (ByVal af As Long, ByVal s_type As Long, ByVal protocol As Long) As Long
Public Declare PtrSafe Function closesocket Lib "wsock32.dll" (ByVal s As Long) As Long
Public Declare PtrSafe Function Connect Lib "wsock32.dll" Alias "connect" (ByVal s As Long, addr As sockaddr, ByVal namelen As Long) As Long
Public Declare PtrSafe Function shutdown Lib "ws2_32.dll" (ByVal s As Long, ByVal how As Long) As Long

Public Declare PtrSafe Function WSAAsyncSelect Lib "wsock32.dll" (ByVal s As Long, ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal lEvent As Long) As Long
Public Declare PtrSafe Function inet_addr Lib "wsock32.dll" (ByVal cp As String) As Long
Public Declare PtrSafe Function gethostbyname Lib "wsock32.dll" (ByVal host_name As String) As Long
Public Declare PtrSafe Sub MemCopy Lib "kernel32" Alias "RtlMoveMemory" (Dest As Any, Src As Any, ByVal cb As Long)
Public Declare PtrSafe Function inet_ntoa Lib "wsock32.dll" (ByVal inn As Long) As Long
Public Declare PtrSafe Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As Any) As Long
Public Declare PtrSafe Function WSACancelBlockingCall Lib "wsock32.dll" () As Long
Public saZero As sockaddr
Public WSAStartedUp As Boolean, Obj As Object
Public PrevProc As LongPtr, lSocket As Long

Dim strData As String
Dim ReadBuffer(1 To 1024) As Byte

Public Function WindowProc(ByVal hwnd As LongPtr, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As LongPtr) As LongPtr
    If uMsg = WINSOCKMSG Then
        ProcessMessage wParam, lParam
    Else
        WindowProc = CallWindowProc(PrevProc, hwnd, uMsg, wParam, lParam)
    End If
End Function
'our Winsock-message handler
Public Sub ProcessMessage(ByVal lFromSocket As Long, ByVal lParam As LongPtr)
    Dim X As Long, strCommand As String
      
    'strCommand = "GET http://www.microsoft.com/ HTTP/1.0" + vbCrLf
    'strcomand = strCommand + "Pragma: no-cache" + vbCrLf
    'strCommand = strCommand + "Accept: */*" + vbCrLf
    'strCommand = strCommand + "Accept: text/html" + vbCrLf + vbCrLf

    'send the data to our google.com-connection

    Select Case lParam
        Case FD_CONNECT                                    'we are connected to microsoft.com
            ShowLog "Connected to [" & SERVER_TO_CONNECT & "] on Port [" & PORT_TO_CONNECT & "] , Socket [" & lFromSocket & "]"
            lSocket = lFromSocket
        Case FD_WRITE                                      'we can write to our connection
            'SendData lFromSocket, strCommand
            'ShowLog "Write ..."
        Case FD_READ                                       'we have data waiting to be processed
            ReadDataToBuffer lFromSocket
            If strData <> "" Then ShowLog "Server >> " & strData
        Case FD_CLOSE       'the connection with server is closed
                'Read remaining data in the buffer
                Do
                X = recv(lFromSocket, ReadBuffer(1), 1024, 0)
                If X > 0 Then
                    strData = strData & Left$(StrConv(ReadBuffer, vbUnicode), X)
                End If
                Loop Until X = 0 Or X = SOCKET_ERROR
                
                If strData <> "" Then ShowLog "Server >> " & strData
            closesocket lFromSocket
            ShowLog "Connection Closed... "
    End Select
End Sub

'Start Winsock Session
Public Function StartWinsock(Optional sDescription) As Boolean
Dim StartupData As WSADataType
    If Not WSAStartedUp Then
        If Not WSAStartup(&H101, StartupData) Then
            WSAStartedUp = True
            sDescription = StartupData.szDescription
        Else
            WSAStartedUp = False
        End If
    End If
    StartWinsock = WSAStartedUp
End Function
'End Winsock Session so no more connections
Sub EndWinsock()
    Dim ret As Long
    If WSAIsBlocking() Then
        ret = WSACancelBlockingCall()
    End If
    ret = WSACleanup()
    WSAStartedUp = False
End Sub

'************************************************************
'Sending data
'************************************************************
Public Function SendDataToBuffer(ByVal lToSocket As Long, vMessage As Variant) As Long
   Dim TheMsg() As Byte, sTemp As String
   TheMsg = ""
   Select Case VarType(vMessage)
   Case 8209    'byte array
        sTemp = vMessage
       TheMsg = sTemp
   Case 8    'string, if we recieve a string, its assumed we are linemode
        sTemp = StrConv(vMessage, vbFromUnicode)
   Case Else
       sTemp = CStr(vMessage)
       sTemp = StrConv(vMessage, vbFromUnicode)
   End Select
   TheMsg = sTemp
   If UBound(TheMsg) > -1 Then
       SendDataToBuffer = Send(lToSocket, TheMsg(0), (UBound(TheMsg) - LBound(TheMsg) + 1), 0)
   End If
End Function

'************************************************************
'Reading data
'************************************************************
Function ReadDataToBuffer(lFromSocket As Long) As Long
   Dim X As Long
   strData = "" 'Clear old data before reading new one
   'start reading the data
    Do
       'Read in 1K chunk ,  ReadBuffer is a bytearray
        X = recv(lFromSocket, ReadBuffer(1), 1024, 0)
       If X > 0 Then
           strData = strData & Left$(StrConv(ReadBuffer, vbUnicode), X)
       End If
       If X <> 1024 Or X = SOCKET_ERROR Then Exit Do
   Loop
   RecvDataToBuffer = X
End Function

Function ConnectSock(ByVal Host As String, ByVal Port As Long, retIpPort As String, ByVal HWndToMsg As LongPtr, Optional IsBlocking As Boolean = False) As Long
    Dim s As Long, SelectOps As Long, Dummy As Long
    Dim sockin As sockaddr
    Dim SockReadBuffer As String
    SockReadBuffer = ""
    sockin = saZero
    sockin.sin_family = AF_INET
    sockin.sin_port = htons(Port)
    If sockin.sin_port = INVALID_SOCKET Then
        ConnectSock = INVALID_SOCKET
        Exit Function
    End If

    sockin.sin_addr = GetHostByNameAlias(Host)
    If sockin.sin_addr = INADDR_NONE Then
        ConnectSock = INVALID_SOCKET
        Exit Function
    End If
    retIpPort = getascip(sockin.sin_addr) & ":" & ntohs(sockin.sin_port)
    
    s = socket(PF_INET, SOCK_STREAM, IPPROTO_TCP)
    If s < 0 Then
        ConnectSock = INVALID_SOCKET
        Exit Function
    End If
    If SetSockLinger(s, 1, 0) = SOCKET_ERROR Then
        If s > 0 Then
            Dummy = closesocket(s)
        End If
        ConnectSock = INVALID_SOCKET
        Exit Function
    End If
    
    If ret = SOCKET_ERROR Then
        If s > 0 Then Call closesocket(s)
        ConnectSock = INVALID_SOCKET
        Exit Function
    End If
    
    '//For Blocking Socket we call WSAAsyncSelect after connect
    '//For Non-Blocking Socket we call WSAAsyncSelect before connect
    If IsBlocking = True Then
        If Connect(s, sockin, sockaddr_size) <> 0 Then
            If s > 0 Then
                Dummy = closesocket(s)
            End If
            ConnectSock = INVALID_SOCKET
            Exit Function
        End If
        SelectOps = FD_READ Or FD_WRITE Or FD_CONNECT Or FD_CLOSE
        If WSAAsyncSelect(s, HWndToMsg, ByVal 1025, ByVal SelectOps) Then
            If s > 0 Then
                Dummy = closesocket(s)
            End If
            ConnectSock = INVALID_SOCKET
            Exit Function
        End If
    Else
        SelectOps = FD_READ Or FD_WRITE Or FD_CONNECT Or FD_CLOSE
        'SelectOps = FD_CONNECT Or FD_READ Or FD_WRITE Or FD_CLOSE
        Dummy = WSAAsyncSelect(s, HWndToMsg, ByVal 1025, ByVal SelectOps)

        If Dummy Then
            If s > 0 Then
                Dummy = closesocket(s)
            End If
            ConnectSock = INVALID_SOCKET
            Exit Function
        End If
        If Connect(s, sockin, sockaddr_size) <> -1 Then
            If s > 0 Then
                Dummy = closesocket(s)
            End If
            ConnectSock = INVALID_SOCKET
            Exit Function
        End If

    End If
            
    ConnectSock = s
End Function
Function GetHostByNameAlias(ByVal hostname As String) As Long
    On Error Resume Next
    Dim phe As Long
    Dim heDestHost As HostEnt
    Dim addrList As Long
    Dim retIP As Long
    retIP = inet_addr(hostname)
    If retIP = INADDR_NONE Then
        phe = gethostbyname(hostname)
        If phe <> 0 Then
            MemCopy heDestHost, ByVal phe, hostent_size
            MemCopy addrList, ByVal heDestHost.h_addr_list, 4
            MemCopy retIP, ByVal addrList, heDestHost.h_length
        Else
            retIP = INADDR_NONE
        End If
    End If
    GetHostByNameAlias = retIP
    If Err Then GetHostByNameAlias = INADDR_NONE
End Function

Function getascip(ByVal inn As Long) As String
    On Error Resume Next
    Dim lpStr As Long
    Dim nStr As Long
    Dim retString As String
    retString = String(32, 0)
    lpStr = inet_ntoa(inn)
    If lpStr = 0 Then
        getascip = "255.255.255.255"
        Exit Function
    End If
    nStr = lstrlen(lpStr)
    If nStr > 32 Then nStr = 32
    MemCopy ByVal retString, ByVal lpStr, nStr
    retString = Left(retString, nStr)
    getascip = retString
    If Err Then getascip = "255.255.255.255"
End Function

Public Function SetSockLinger(ByVal SockNum As Long, ByVal OnOff As Integer, ByVal LingerTime As Integer) As Long
    Dim Linger As LingerType
    Linger.l_onoff = OnOff
    Linger.l_linger = LingerTime
    If setsockopt(SockNum, SOL_SOCKET, SO_LINGER, Linger, 4) Then
        Debug.Print "Error setting linger info: " & WSAGetLastError()
        SetSockLinger = SOCKET_ERROR
    Else
        If getsockopt(SockNum, SOL_SOCKET, SO_LINGER, Linger, 4) Then
            Debug.Print "Error getting linger info: " & WSAGetLastError()
            SetSockLinger = SOCKET_ERROR
        End If
    End If
End Function

Sub ShowLog(sDesc As String)
    Obj.Text = Obj.Text & sDesc & vbCrLf
End Sub