使用ExcelVba使用API调用TCP，为什么无法正常关闭Server端

Question

'这部分是所有通讯代码
Option Explicit
'--------------------------------------------------------------------------------
Private Declare Function WSAStartup Lib "wsock32.dll" (ByVal wVersionRequested As Integer, lpWSAData As wsadata) As Long
Private Declare Function socket Lib "wsock32.dll" (ByVal af As Long, ByVal socktype As Long, ByVal protocol As Long) As Long
Private Declare Function bind Lib "wsock32.dll" (ByVal s As Long, name As sockaddr, ByVal namelen As Long) As Long
Private Declare Function listen Lib "wsock32.dll" (ByVal s As Long, ByVal backlog As Long) As Long
Private Declare Function accept Lib "wsock32.dll" (ByVal s As Long, addr As sockaddr, addrlen As Long) As Long
Private Declare Function closesocket Lib "wsock32.dll" (ByVal s As Long) As Long
Private Declare Function WSACleanup Lib "wsock32.dll" () As Long
Private Declare PtrSafe Function send Lib "wsock32.dll" (ByVal s As Long, buf As Any, ByVal buflen As Long, ByVal flags As Long) As Long
Private Declare PtrSafe Function recv Lib "wsock32.dll" (ByVal s As Long, buf As Any, ByVal buflen As Long, ByVal flags As Long) As Long
'--------------------------------------------------------------------------------
Private Type wsadata
    wVersion As Integer
    wHighVersion As Integer
    szDescription(0 To 255) As Byte
    szSystemStatus(0 To 127) As Byte
    iMaxSockets As Integer
    iMaxUdpDg As Integer
    lpVendorInfo As Long
End Type

Private Type sockaddr
    sin_family As Integer
    sin_port As Integer
    sin_addr As Long
    sin_zero(0 To 7) As Byte
End Type
Dim serverSocket As Long
Dim clientSocket As Long
Dim serverAddr As sockaddr
Dim clientAddr As sockaddr
Dim clientAddrLen As Long
    
Dim wsadata As wsadata
Dim result As Long
    
Public Sub StartTCPServer()
    ' 初始化 Windows Sockets
    result = WSAStartup(&H202, wsadata)
    If result <> 0 Then
        MsgBox "WSAStartup failed!"
        Exit Sub
    End If
    
    ' 创建套接字
    serverSocket = socket(2, 1, 0) ' AF_INET, SOCK_STREAM, IPPROTO_TCP
    If serverSocket = 0 Then
        MsgBox "Socket creation failed!"
        Exit Sub
    End If
    
    ' 设置服务器地址和端口
    serverAddr.sin_family = 2 ' AF_INET
    serverAddr.sin_port = htons(12346) ' 设置端口号
    
    ' 绑定套接字
    result = bind(serverSocket, serverAddr, Len(serverAddr))
        ' 监听连接
        result = listen(serverSocket, 5) ' 允许最多5个连接
        DoEvents
        If result = 0 Then '可连接
            ' 等待客户端连接
            clientAddrLen = Len(clientAddr)
            DoEvents
            clientSocket = accept(serverSocket, clientAddr, clientAddrLen)
            DoEvents
            If clientSocket <> 0 Then
                ' 在这里处理客户端数据
                Dim buffer(2000) As Byte
                Dim bytesRead As Long
                Dim data As String
                Dim Rown As Integer
                Rown = 1
                DoEvents
100:            bytesRead = recv(clientSocket, buffer(0), UBound(buffer) + 1, 0)
                If bytesRead > 0 Then
                    ' 从缓冲区中提取接收到的数据
                    data = VBA.StrConv(buffer, vbUnicode) 'VBA.Left$(buffer, bytesRead)
                    Sheets("数据").Cells(Rown, 1) = data ' 将数据附加到工作表或进行其他操作---
                    Erase buffer '清空缓存区数据，防止下次接收重复
                    Rown = Rown + 1
                    'If MultiSelectDropdownForm.ExitSub Then Exit Sub
            '-----------------------------------------------------------------------------------
                    ' 回复客户端，使用 send 函数发送响应
                    Dim response As String
                    response = "Hello, Alredy Recieved!" ' 你的响应消息
                                    
                    ' 将响应消息转换为字节数组
                    Dim responseBytes() As Byte
                    responseBytes = VBA.StrConv(response, vbFromUnicode)
                                    
                    ' 使用 send 函数发送响应
                    Dim sentBytes As Long
                    sentBytes = send(clientSocket, responseBytes(0), UBound(responseBytes) + 1, 0)
                                   
                    If sentBytes < 0 Then
                    ' 发送出现错误
                        MsgBox "send failed with error " & Err.LastDllError
                    End If
                ElseIf bytesRead = 0 Then
                    ' 客户端关闭了连接
                    CloseTCPServer
                Else
                    ' 错误处理
                    MsgBox "recv failed with error " & Err.LastDllError
                    CloseTCPServer
                End If
                            
                DoEvents: GoTo 100 '循环接收
            End If
        End If
    
    ' 关闭服务器套接字和清理
    'closesocket serverSocket
    'WSACleanup
End Sub
Private Sub CloseTCPServer()
    ' 关闭客户端连接
    closesocket clientSocket
    ' 关闭服务器套接字和清理
    closesocket serverSocket
    WSACleanup
End Sub
Private Function htons(value As Integer) As Integer
    ' 用于处理字节序问题
    If (ByteOrder() = 0) Then
        htons = value
    Else
        htons = ((value And &HFF) * 256) + ((value And &HFF00) / 256)
    End If
End Function
Private Function ByteOrder() As Integer
    ' 检查系统的字节序（大端或小端）
    Dim test As Integer
    test = &H1
    If (CVar(VBA.ChrB(test)) = 1) Then
        ByteOrder = 0 ' 小端
    Else
        ByteOrder = 1 ' 大端
    End If
End Function

我是用了两台电脑来测试这个通讯，连接和发送接收数据都没有问题，只是执行closeTCP，再重新连接无法连接，只有更换端口号才可以连接，请大家参考一下

Answer 1

【以下回答由 GPT 生成】

我可以为您提供一些可能解决您的问题的方法和建议。请注意，这些只是一些常见的解决方案，具体取决于您的环境和代码实现的细节。

解决方案1：使用Shutdown函数关闭套接字 尝试使用shutdown函数来关闭套接字，确保在调用closesocket函数之前使用shutdown函数。具体步骤如下：

Private Declare Function shutdown Lib "wsock32.dll" (ByVal s As Long, ByVal how As Long) As Long

在关闭服务器之前，通过调用shutdown函数来停止输入或输出流：

' 关闭输出流，仅接受输入
shutdown(s, 1)

然后再调用closesocket函数关闭套接字：

closesocket(s)

解决方案2：添加超时机制 在你的代码中添加一个超时机制可以确保在一段时间后强制关闭套接字。您可以使用SetTimer函数来设置一个定时器，在合适的时候关闭套接字。具体步骤如下：

Private Declare Function SetTimer Lib "user32.dll" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32.dll" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long

在需要的地方设置一个定时器，例如在接收连接的循环中：

Dim timerID As Long

Sub ReceiveConnections()
    ' 设置定时器，10000毫秒后调用关闭套接字函数
    timerID = SetTimer(0, 0, 10000, AddressOf CloseSocket)

    ' 接收连接的代码

    ' 关闭定时器
    KillTimer 0, timerID
End Sub

Sub CloseSocket(ByVal hwnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTime As Long)
    ' 关闭套接字的代码
    closesocket(s)
End Sub

这将在10秒钟后调用CloseSocket函数来关闭套接字。

解决方案3：调用Windows API中的其他函数 除了closesocket和WSACleanup函数外，您还可以尝试调用其他Windows API函数来强制关闭套接字。例如，您可以尝试使用Setsockopt函数来设置SO_LINGER选项，从而使套接字立即关闭：

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

在关闭套接字之前设置SO_LINGER选项：

Dim lingerOpt As Byte
lingerOpt = 1 ' 启用SO_LINGER选项
setsockopt(s, SOL_SOCKET, SO_LINGER, lingerOpt, Len(lingerOpt))

然后再调用closesocket函数关闭套接字：

closesocket (s)

请注意，这些解决方案只是一些常见的方法，具体取决于您的代码实现和环境。如果这些方法对您不起作用，可能需要进一步检查和调试您的代码，或者使用其他第三方库来处理网络连接。

如果你已经解决了该问题, 非常希望你能够分享一下解决方案, 写成博客, 将相关链接放在评论区, 以帮助更多的人 ^-^