Client server using vba

I

Ishkabish

New Member
Joined
Jun 25, 2020
Messages
4
Office Version
  1. 2010
Platform
  1. Windows
Hi. Anyone have a vba client server code???
 

Excel Facts

Lock one reference in a formula
Need 1 part of a formula to always point to the same range? use $ signs: $V$2:$Z$99 will always point to V2:Z99, even after copying
Sort by date Sort by votes
You'll have to be infinitely more specific than that. I could answer "42" and be correct, without knowing any other info. Be detailed, be thorough, give examples.
 
Upvote 0
Thanks man im literaly new to this forum. A while back a created a client server program in visual basic using winsock. Due to licensing issues i could not use it. I however recreated the program using vba through excel. Now im stuck creating my pc as a server to which other client pc needs to connect and send me there data when they click save. Hope this is clearer. Thanx
 
Upvote 0
No, it is not. You've given a small fraction of a story, yet not actually asked a specific question. Please be extremely specific. Remember, we can't see anything you have and do not have any background on what you have currently, any of the architecture or code used, etc. You may as well have said, "...does anyone have any engineering plans for a car, I need help."
 
Upvote 0
A simple chat program would do. Two or more pcs on a wifi network. I type in 'hi how r u' the other person gets it on their screen n are able to respond n i will get their response on my pc. I need this in vba. This will be sufficient to incorperate in into my macro
 
Upvote 0
Ishkabish said:
Hi. Anyone have a vba client server code???
Click to expand...
Hi my friend
I'm newbie and I have research the same your question for a long time.
I have consulted in Binary World website with VB code.

I try modified the code more time, and now I success without any add-in.
I'm very happy to share it for you and other.
I tested it on my machine and LAN.

Pls Note: This is a test version only, no other function for you. You can develop by yourself.
These files only run on Excel 64 bit.

If you get Err: 10022, you must Run Excel as Administrator then open file serverVB.xlsb.

Now, let see some pic and download file to test.

Oh, this forum cannot attach excel files :(
You can go to Vietnamese forum to download.

www.giaiphapexcel.com

Share source code VBA client/server sử dụng thư viện wsoc32.dll trên excel 64bit

Xin chào các bạn. Mình là newbie Sau 1 thời gian tìm hiểu cách thức tạo ứng dụng client/server trên excel 64 bit nhưng không thấy nơi nào có source. Thấy có nhiều bạn cũng đang tìm vấn đề giống mình nên mình post thành quả của mình lên đây. 2 file này mình dựa trên source VB trên mạng và sửa...
www.giaiphapexcel.com www.giaiphapexcel.com
 

Attachments

  • ClientServerEXCEL1.jpg
    ClientServerEXCEL1.jpg
    190 KB · Views: 52
  • ClientServerEXCEL2.jpg
    ClientServerEXCEL2.jpg
    132.5 KB · Views: 54
  • ClientServerEXCEL3.jpg
    ClientServerEXCEL3.jpg
    138.6 KB · Views: 48
  • ClientServerEXCEL4.jpg
    ClientServerEXCEL4.jpg
    123.1 KB · Views: 54
Upvote 0
Fluff said:
@ban0955 Please post you code here as per Board rules. Thanks
How to Post Your VBA Code
Click to expand...
My server code
First I create a form with the name is frmAPIDemo, it have a textbox (Text1) and a command button (command1)
Here is code of form:
VBA Code: 
Option Explicit

Const PORT_TO_LISTEN = 5555

    Public mlnghWnd As LongPtr
 
    Public Property Get hwnd() As LongPtr
        hwnd = mlnghWnd
    End Property
Private Sub Form_Load()
    Set Obj = Me.Text1.Object
    Command1.Caption = "Start Listen"

    'Start subclassing
    HookForm
    'create a new winsock session
    StartWinsock
End Sub

Private Sub Command1_Click()
    Dim frmhWnd As LongPtr
    frmhWnd = hwnd
    If Command1.Caption = "Stop Listen" Then
    'Once you call shutdown then server will issue FD_CLOSE then
    'u can call closesocket to fully close the connection
        DisconnectAll
        closesocket lSocket
        Call ShowLog("Stopped Listining on port 5555...")
        Command1.Caption = "Start Listen"
    Else
        If WSAStartedUp = True Then
            lSocket = NewSocket(AF_INET, SOCK_STREAM, IPPROTO_TCP, frmhWnd)
            If lSocket > 0 Then
                Call ShowLog("Created new socket [" & lSocket & "]..." & Now)
                If StartListen(lSocket, PORT_TO_LISTEN) <> SOCKET_ERROR Then
                    Call ShowLog("Started Listining on port 5555...")
                    Command1.Caption = "Stop Listen"
                Else
    'Call ShowLog("Error : " & GetWinsockError(Err.LastDllError))
                    Call ShowLog("Error : " & Err.LastDllError)
                    Command1.Caption = "Start Listen"
                End If
            Else
    'Call ShowLog("Error : " & GetWinsockError(Err.LastDllError))
                Call ShowLog("Error : " & Err.LastDllError)
                Command1.Caption = "Start Listen"
            End If
        End If
    End If
End Sub
Sub DisconnectAll()
'//Loop throuh all socket connected to server and close them
    Dim i As Integer
    For i = 1 To colConnections.Count
        shutdown colConnections(i), SD_SEND
    Next
End Sub



Private Sub UserForm_Initialize()
    'StorehWnd
    StorehWnd
    Call Form_Load
End Sub
Private Sub StorehWnd()
 
    Dim strCaption As String
    Dim strClass As String
 
    'class name changed in Office 2000
    If Val(Application.Version) >= 9 Then
        strClass = "ThunderDFrame"
    Else
        strClass = "ThunderXFrame"
    End If
 
    'remember the caption so we can
    'restore it when we're done
    strCaption = Me.Caption
 
    'give the userform a random
    'unique caption so we can reliably
    'get a handle to its window
    Randomize
    Me.Caption = CStr(Rnd)
 
    'store the handle so we can use
    'it for the userform's lifetime
    mlnghWnd = FindWindowA(strClass, Me.Caption)
 
    'set the caption back again
    Me.Caption = strCaption
 
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    'close our connection to microsoft.com
    closesocket lSocket
    'end winsock session
    EndWinsock
    'stop subclassing
    UnHookForm
End Sub
Public Sub HookForm()
    
    PrevProc = SetWindowLongPtr(frmAPIDemo.hwnd, GWL_WNDPROC, AddressOf WindowProc)
End Sub
Public Sub UnHookForm()
    
    If PrevProc <> 0 Then
        SetWindowLongPtr frmAPIDemo.hwnd, GWL_WNDPROC, PrevProc
        PrevProc = 0
    End If
End Sub

And here is API and Function
VBA Code: 
'Maximum queue length specifiable by listen.
Public Const SOMAXCONN = &H7FFFFFFF

Public colConnections As New Collection

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_ACCEPT = &H8
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_REUSEADDR = &H4

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 bind Lib "ws2_32.dll" (ByVal s As Long, ByRef name As sockaddr, ByRef namelen As Long) 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 accept Lib "ws2_32.dll" (ByVal s As Long, ByRef addr As sockaddr, ByRef addrlen 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 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 listen Lib "ws2_32.dll" (ByVal s As Long, ByVal backlog 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 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 ' Global variable to hold received data
Dim ReadBuffer(1 To 1024) As Byte 'Buffer of received bytes 'Max 1k

'subclassing functions
'for more information about subclassing,
'check out the subclassing tutorial at http://www.allapi.net/

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
        cnt = uMsg
        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, strDataToSend As String
    'Form1.Caption = lParam
    Select Case lParam
    Case FD_CONNECT   '
    Case FD_ACCEPT    '
        ShowLog "New connection request [socket :" & lFromSocket & "].." & Now
        SocketAccept (lFromSocket)
    Case FD_WRITE    'we can write to our connection
    Case FD_READ    'we have data waiting to be processed
        ReadDataToBuffer lFromSocket
        
        If strData <> "" Then ShowLog "Client >> " & strData
        
        If strData = "time?" Then
                strDataToSend = "Time on server is " & Now()
        ElseIf strData = "date?" Then
                strDataToSend = "Date on server is " & Date
        Else
                strDataToSend = strData & " is not a valid Command"
        End If
        
        'Send data to client
        SendDataToBuffer lFromSocket, strDataToSend

    Case FD_CLOSE    'the connection with client 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 "Client >> " & strData

        closesocket lFromSocket
        ShowLog "Connection Closed... "
    End Select
End Sub
'the following functions are standard WinSock functions
'from the wsksock.bas-file
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
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

Public Function NewSocket(ByVal AdrFamily As Long, ByVal SckType As Long, ByVal SckProtocol As Long, HWndForMsg As LongPtr) As Long
'********************************************************************************
'Purpose   :Creates a new socket
'Returns   :The socket handle if successful, otherwise - INVALID_SOCKET
'Arguments :AddressFamily, SocketType and SocketProtocol
'********************************************************************************
    On Error GoTo errHandler
    Dim hSocket As Long    'value returned by the socket API function
    Dim lngEvents  As Long

    'Call the socket Winsock API function in order create a new socket
    hSocket = socket(AdrFamily, SckType, SckProtocol)
    NewSocket = hSocket    'Assign returned value ( -1 => INVALID_SOCKET)

    If hSocket <> INVALID_SOCKET Then
        'The lngEvents variable contains a bitmask of events we are
        'going to catch with the window callback function.
        lngEvents = FD_CONNECT Or FD_READ Or FD_WRITE Or FD_CLOSE Or FD_ACCEPT
        '
        'Force the Winsock service to send the network event notifications
        'to the window which handle is p_lngWindowHandle.
        lngRetValue = WSAAsyncSelect(hSocket, HWndForMsg, WINSOCKMSG, lngEvents)    'Modified:04-MAR-2002
    End If
    Exit Function
errHandler:
    NewSocket = INVALID_SOCKET
End Function
Function StartListen(hSocket As Long, Port As Long) As Long
'********************************************************************************
'Purpose   :Turns a socket into a listening state.
'Return    :If no error occurs, returns zero. Otherwise, it returns SOCKET_ERROR.
'Arguments :lngSocketHandle - the socket to turn into a listening state.
'********************************************************************************
    Dim lngRetValue As Long

    If SocketBind(hSocket, Port) = SOCKET_ERROR Then StartListen = SOCKET_ERROR
    lngRetValue = listen(hSocket, SOMAXCONN)
    '
    StartListen = lngRetValue
End Function
Public Function SocketAccept(ByVal lngSocketHandle As Long) As Long
'********************************************************************************
'Purpose   :Accepts a connection request, and creates a new socket.
'Return    :If no error occurs, returns the new socket's handle.
'           Otherwise, it returns INVALID_SOCKET.
'Arguments :lngSocketHandle - the listening socket.
'********************************************************************************
'
    Dim lngRetValue         As Long
    Dim udtSocketAddress    As sockaddr
    Dim lngBufferSize       As Long
    '
    'Calculate the buffer size
    lngBufferSize = LenB(udtSocketAddress)
    '
    'Call the accept Winsock API function in order to create a new socket
    lngRetValue = accept(lngSocketHandle, udtSocketAddress, lngBufferSize)

    SocketAccept = lngRetValue
    If lngRetValue <> INVALID_SOCKET Then colConnections.Add lngRetValue
End Function

Public Function SocketBind(ByVal lngSocket As Long, ByVal lngLocalPort As Long, Optional ByVal strLocalHost As String = "127.0.0.1") As Long
'********************************************************************************
'Purpose   :Binds the socket to the local address
'Return    :If no error occurs, returns zero. Otherwise, it returns SOCKET_ERROR.
'Arguments :lngSocket    - the socket to bind
'           strLocalHost - name or IP address of the local host to bind to
'           lngLocalPort - the port number to bind to
'********************************************************************************
    On Error GoTo errHandler

    Dim udtSocketAddress As sockaddr
    Dim lngReturnValue   As Long
    Dim lngAddress       As Long

    SocketBind = SOCKET_ERROR

    With udtSocketAddress
        .sin_family = AF_INET

        '////////////////////////////////////////////////////////
        '[1] The strRemoteHost may contain the host name
        '    or IP address - GetAddressLong returns a valid
        '    value anyway
        '////////////////////////////////////////////////////////
        .sin_addr = GetHostByNameAlias(strLocalHost)

        '////////////////////////////////////////////////////////
        '[2] convert the port number to the network byte ordering
        '////////////////////////////////////////////////////////
        .sin_port = htons(lngLocalPort)
        If .sin_port = INVALID_SOCKET Then
            SocketBind = INVALID_SOCKET
            Exit Function
        End If
    End With

    '//Set option to reuse the port if its already in use
    Dim optvalue As Boolean
    optvalue = True
    If setsockopt(lngSocket, SOL_SOCKET, SO_REUSEADDR, optvalue, Len(optval)) Then
        ShowLog "Error setting SO_REUSEADDR option : " & WSAGetLastError()
    End If

    SocketBind = bind(lngSocket, udtSocketAddress, LenB(udtSocketAddress))

    Exit Function
errHandler:
    SocketBind = SOCKET_ERROR
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

Sub ShowLog(sDesc As String)
    On Error Resume Next
    Obj.Text = Obj.Text & sDesc & vbCrLf
End Sub
 
Upvote 0
ban0955 said:
Hi my friend
I'm newbie and I have research the same your question for a long time.
I have consulted in Binary World website with VB code.

I try modified the code more time, and now I success without any add-in.
I'm very happy to share it for you and other.
I tested it on my machine and LAN.

Pls Note: This is a test version only, no other function for you. You can develop by yourself.
These files only run on Excel 64 bit.

If you get Err: 10022, you must Run Excel as Administrator then open file serverVB.xlsb.

Now, let see some pic and download file to test.

Oh, this forum cannot attach excel files :(
You can go to Vietnamese forum to download.

www.giaiphapexcel.com

Share source code VBA client/server sử dụng thư viện wsoc32.dll trên excel 64bit

Xin chào các bạn. Mình là newbie Sau 1 thời gian tìm hiểu cách thức tạo ứng dụng client/server trên excel 64 bit nhưng không thấy nơi nào có source. Thấy có nhiều bạn cũng đang tìm vấn đề giống mình nên mình post thành quả của mình lên đây. 2 file này mình dựa trên source VB trên mạng và sửa...
www.giaiphapexcel.com www.giaiphapexcel.com
Click to expand...
My client the same server, it have form, textbox, button with the same name too.
Here is code of client form
VBA Code: 
Option Explicit

 
    Private mlnghWnd As LongPtr
 
    Public Property Get hwnd() As LongPtr
        hwnd = mlnghWnd
    End Property

Private Sub Command1_Click()
    Dim frmhWnd As LongPtr
    frmhWnd = hwnd
    If Command1.Caption = "Disconnect" Then
        'Once you call shutdown then server will issue FD_CLOSE then
        'u can call closesocket to fully close the connection
        shutdown lSocket, SD_SEND

        Command1.Caption = "Connect"
        'Timer1.Enabled = False
    Else
        lSocket = ConnectSock(SERVER_TO_CONNECT, PORT_TO_CONNECT, 0, frmhWnd, False)
        'lSocket = ConnectSock("www.google.com", 80, 0, Me.hwnd, True) 'Blocking
        'lSocket = ConnectSock("www.google.com", 80, 0, Me.hwnd, False) 'Non Blocking
        
        If lSocket = INVALID_SOCKET Then
            ShowLog "Error : " & Err.LastDllError
        Else
            Command1.Caption = "Disconnect"
            'Timer1.Enabled = True
        End If
        
    End If
End Sub

'This project needs a TextBox
'-> (Name)=Text1
'-> MultiLine=True
'in a form
Private Sub Form_Load()
    Set Obj = Me.Text1.Object
    Command1.Caption = "Connect"

    'Start subclassing
    HookForm
    'create a new winsock session
    StartWinsock
End Sub



Private Sub UserForm_Initialize()
    StorehWnd
    Call Form_Load
End Sub
Private Sub StorehWnd()
 
    Dim strCaption As String
    Dim strClass As String
 
    'class name changed in Office 2000
    If Val(Application.Version) >= 9 Then
        strClass = "ThunderDFrame"
    Else
        strClass = "ThunderXFrame"
    End If
 
    'remember the caption so we can
    'restore it when we're done
    strCaption = Me.Caption
 
    'give the userform a random
    'unique caption so we can reliably
    'get a handle to its window
    Randomize
    Me.Caption = CStr(Rnd)
 
    'store the handle so we can use
    'it for the userform's lifetime
    mlnghWnd = FindWindowA(strClass, Me.Caption)
 
    'set the caption back again
    Me.Caption = strCaption
 
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    If lSocket <> INVALID_SOCKET Then Call shutdown(lSocket, SD_BOTH): Call closesocket(lSocket)
    
    'end winsock session
    EndWinsock
    
    'stop subclassing
    UnHookForm
End Sub
Public Sub HookForm()
    
    PrevProc = SetWindowLongPtr(frmAPIDemo.hwnd, GWL_WNDPROC, AddressOf WindowProc)
End Sub
Public Sub UnHookForm()
    
    If PrevProc <> 0 Then
        SetWindowLongPtr frmAPIDemo.hwnd, GWL_WNDPROC, PrevProc
        PrevProc = 0
    End If
End Sub

And here is API and Function of client

VBA Code: 
Public Const SERVER_TO_CONNECT = "127.0.0.1"

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

Let 's get started.
Don't forget Run Excel As Administrator if you don't want to see ERR 10022 when run server.
 
Upvote 0
You must log in or register to reply here.

Similar threads

C
  • Question
Has anyone used OpenLinks or ActualTech drivers?
Replies
0
Views
144
chuckbo
C
R
  • Question
Using CountIfs but counting duplicates only once
Replies
4
Views
83
RoryA
RoryA
SanjayGMusafir
  • Solved
Filtering 2 columns that are 57 columns apart
2
Replies
13
Views
273
Fluff
Fluff
A
  • Solved
3 way use button to run macro
Replies
2
Views
229
Aleytha
A
M
  • Question
Passing SQL code to server and retrieve results
Replies
2
Views
116
Candyman8019
C

Forum statistics

Threads
1,217,897
Messages
6,139,274
Members
450,191
Latest member
mr_steveb

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top