CSocketMaster的问题 传文件部分数据丢失

Question

工作需要写了个ActiveX DLL控件工作目的是实现上传图片到网站由于无界面，放弃了WinSocket控件，使用CSocketMaster类POST到WEB的数据包用的string格式，SendData后，IIS接收到的文件有少量损坏文件长度一致，但是中间部分字节丢失（如86），末尾被00填充求明灯

Answer 1

CSocketMaster类
说实话，写的不错，但是不稳定。以前用过，后来就再也不用了。

Answer 2

建议你调试一下，发送端不变，接收端用WinSock接收一下看看。
如果还是有问题，就看看发送端的源码。
它是用API转发的，猜测有可能会过滤一些字符。

Answer 3

那有没有替代的东西？我看它的SendData函数，里面有分不同数据类型来处理但是第一次用VB，不知道VB怎么处理字节数据 byte类型

Answer 4

Public Sub SendData(data As Variant)Dim arrData() As Byte 'We store the data here before send itIf m_enmProtocol = sckTCPProtocol Then
    If m_enmState <> sckConnected Then
        Err.Raise sckBadState, "CSocketMaster.SendData", "Wrong protocol or connection state for the requested transaction or request"
        Exit Sub
    End If
Else 'If we use UDP we create a socket if there isn't one yet
    If Not SocketExists Then Exit Sub
    If Not BindInternal Then Exit Sub
    m_enmState = sckOpen: Debug.Print "STATE: sckOpen"
End If'We need to convert data variant into a byte array
Select Case varType(data)
        Case vbString
            Dim strdata As String
            strdata = CStr(data)
            If Len(strdata) = 0 Then Exit Sub
            ReDim arrData(Len(strdata) - 1)
            arrData() = StrConv(strdata, vbFromUnicode)
        Case vbArray + vbByte
            Dim strArray As String
            strArray = StrConv(data, vbUnicode)
            If Len(strArray) = 0 Then Exit Sub
            arrData() = StrConv(strArray, vbFromUnicode)
        Case vbBoolean
            Dim blnData As Boolean
            blnData = CBool(data)
            ReDim arrData(LenB(blnData) - 1)
            api_CopyMemory arrData(0), blnData, LenB(blnData)
        Case vbByte
            Dim bytData As Byte
            bytData = CByte(data)
            ReDim arrData(LenB(bytData) - 1)
            api_CopyMemory arrData(0), bytData, LenB(bytData)
        Case vbCurrency
            Dim curData As Currency
            curData = CCur(data)
            ReDim arrData(LenB(curData) - 1)
            api_CopyMemory arrData(0), curData, LenB(curData)
        Case vbDate
            Dim datData As Date
            datData = CDate(data)
            ReDim arrData(LenB(datData) - 1)
            api_CopyMemory arrData(0), datData, LenB(datData)
        Case vbDouble
            Dim dblData As Double
            dblData = CDbl(data)
            ReDim arrData(LenB(dblData) - 1)
            api_CopyMemory arrData(0), dblData, LenB(dblData)
        Case vbInteger
            Dim intData As Integer
            intData = CInt(data)
            ReDim arrData(LenB(intData) - 1)
            api_CopyMemory arrData(0), intData, LenB(intData)
        Case vbLong
            Dim lngData As Long
            lngData = CLng(data)
            ReDim arrData(LenB(lngData) - 1)
            api_CopyMemory arrData(0), lngData, LenB(lngData)
        Case vbSingle
            Dim sngData As Single
            sngData = CSng(data)
            ReDim arrData(LenB(sngData) - 1)
            api_CopyMemory arrData(0), sngData, LenB(sngData)
        Case Else
            Err.Raise sckUnsupported, "CSocketMaster.SendData", "Unsupported variant type."
    End Select'if there's already something in the buffer that means we are
'already sending data, so we put the new data in the buffer
'and exit silently
If Len(m_strSendBuffer) > 0 Then
    m_strSendBuffer = m_strSendBuffer + StrConv(arrData(), vbUnicode)
    Exit Sub
Else
    m_strSendBuffer = m_strSendBuffer + StrConv(arrData(), vbUnicode)
End If'send the data
SendBufferedDataEnd Sub这就是那个函数喽~~
你把 Public Sub SendData(data As Variant) 里面的 data 打印出来看看有没有问题。有问题的话就是代码处理的问题了

Answer 5

是的，我现在在用 Byte 类型来处理方便加您QQ么？  我的QQ 945881

Answer 6

Public Function SendBmp(x As Integer, y As Integer, w As Integer, h As Integer) As String    Dim Filedata() As Byte
    Dim HttpData() As Byte
    Dim DestUrl As URL
    Dim HttpHead As String
    
    ' 处理服务器地址
    DestUrl = ExtractUrl("http://s1.maiyu.net/test.asp")
    If DestUrl.Host = vbNullString Then
        SendBmp = "地址错误"
        Exit Function
    End If
    If DestUrl.Port = 0 Then  'URL中的端口为空则端口为80
        DestUrl.Port = 80
    End If
    
    '生产提交数据
    HttpHead = "POST " & DestUrl.URI & "?" & DestUrl.Query & " HTTP/1.0" & vbCrLf
    HttpHead = HttpHead & "Host: " & DestUrl.Host & vbCrLf
    HttpHead = HttpHead & "Content-Type: multipart/form-data, boundary=" & strBoundary & vbCrLf
    HttpHead = HttpHead & "Content-Length: " & lngLength & vbCrLf & vbCrLf
    
    'HTTP协议头转成字节数组
    Call StringToByte(HttpHead, HttpData)
    Dim OldLeng As Integer
    Dim AddLeng As Integer
    
    '屏幕截图
    Call CaptureScreen(x, y, w, h, Filedata)
    MsgBox "截图完成，图象大小:" & CStr(UBound(Filedata)), vbOKOnly, "Done"
    
    '合并HTTP数据
    OldLeng = UBound(HttpData)
    AddLeng = UBound(Filedata)
    ReDim Preserve HttpData(OldLeng + AddLeng)
    CopyMemory HttpData(OldLeng), Filedata(0), AddLeng
    MsgBox "HTTP构造完成，大小:" & CStr(UBound(HttpData)), vbOKOnly, "Done"    '实例化Socket
    Set Client = New CSocketMaster
            
    '建立连接
    Client.Connect DestUrl.Host, DestUrl.Port    '等待连接完成
    While Not c_Conn
        DoEvents
    Wend
    
    '发送构造好的HTTP协议数据包
    Client.SendData HttpData
    '返回结果未处理
    SendBmp = "1111"
End Function
现在麻烦大了，MsgBox "截图完成，图象大小:" & CStr(UBound(Filedata)), vbOKOnly, "Done"这个正常后面没提示了，应该是“合并HTTP数据”这里的问题因为之前直接POST文件是可以的

Answer 7

先在CSocketMaster.cls里增加这两个函数Private Function ArrToHex(Arr() As Byte) As String
    Dim C As Integer, I As Integer, CH As String, R As String
    C = UBound(Arr)
    For I = 0 To C
        CH = Hex(Arr(I))
        CH = String(2 - Len(CH), "0") & CH
        R = R & CH
    Next
    ArrToHex = R
End FunctionPrivate Function HexToArr(Str As String) As Byte()
    Dim C As Integer, I As Integer, Arr() As Byte, CH As String
    On Error GoTo hErr
    C = Len(Str) \ 2 - 1
    ReDim Arr(C)
    For I = 0 To C
        CH = Mid(Str, I * 2 + 1, 2)
        Arr(I) = CByte("&H" & CH)
    Next
    HexToArr = Arr
hErr:
End Function

Answer 8

HTTP头我已经处理过了的Private Sub StringToByte(ByVal strIn As String, ByRef bytOut() As Byte)
  Dim i As Long
  Dim lngLen As Long
  lngLen = Len(strIn)
  ReDim bytOut(lngLen)
  For i = 0 To lngLen - 1
  bytOut(i) = CByte(Asc(Mid(strIn, i + 1, 1)))
  Next
End Sub

Answer 9

然后改写后边这几个函数
SendData
SendBufferedDataUDP
SendBufferedDataTCP
RecvDataToBuffer
BuildArray
Accept
后边我可能贴不完,Public Sub SendData(data As Variant)Dim arrData() As Byte 'We store the data here before send itIf m_enmProtocol = sckTCPProtocol Then
    If m_enmState <> sckConnected Then
        Err.Raise sckBadState, "CSocketMaster.SendData", "Wrong protocol or connection state for the requested transaction or request"
        Exit Sub
    End If
Else 'If we use UDP we create a socket if there isn't one yet
    If Not SocketExists Then Exit Sub
    If Not BindInternal Then Exit Sub
    m_enmState = sckOpen: '★★★★★★★★★★debug.print "STATE: sckOpen"
End If'We need to convert data variant into a byte array
Select Case varType(data)
        Case vbString
            Dim strdata As String
            strdata = CStr(data)
            If Len(strdata) = 0 Then Exit Sub
            ReDim arrData(Len(strdata) - 1)
            arrData() = StrConv(strdata, vbFromUnicode)
        Case vbArray + vbByte
'            Dim strArray As String
'            strArray = StrConv(data, vbUnicode)
'            If Len(strArray) = 0 Then Exit Sub
'            arrData() = StrConv(strArray, vbFromUnicode)
            Dim I As Integer 'Bingo
            ReDim arrData(UBound(data)) As Byte 'Bingo
            For I = 0 To UBound(data) 'Bingo
                arrData(I) = CByte(data(I)) 'Bingo
            Next 'Bingo
        Case vbBoolean
            Dim blnData As Boolean
            blnData = CBool(data)
            ReDim arrData(LenB(blnData) - 1)
            api_CopyMemory arrData(0), blnData, LenB(blnData)
        Case vbByte
            Dim bytData As Byte
            bytData = CByte(data)
            ReDim arrData(LenB(bytData) - 1)
            api_CopyMemory arrData(0), bytData, LenB(bytData)
        Case vbCurrency
            Dim curData As Currency
            curData = CCur(data)
            ReDim arrData(LenB(curData) - 1)
            api_CopyMemory arrData(0), curData, LenB(curData)
        Case vbDate
            Dim datData As Date
            datData = CDate(data)
            ReDim arrData(LenB(datData) - 1)
            api_CopyMemory arrData(0), datData, LenB(datData)
        Case vbDouble
            Dim dblData As Double
            dblData = CDbl(data)
            ReDim arrData(LenB(dblData) - 1)
            api_CopyMemory arrData(0), dblData, LenB(dblData)
        Case vbInteger
            Dim intData As Integer
            intData = CInt(data)
            ReDim arrData(LenB(intData) - 1)
            api_CopyMemory arrData(0), intData, LenB(intData)
        Case vbLong
            Dim lngData As Long
            lngData = CLng(data)
            ReDim arrData(LenB(lngData) - 1)
            api_CopyMemory arrData(0), lngData, LenB(lngData)
        Case vbSingle
            Dim sngData As Single
            sngData = CSng(data)
            ReDim arrData(LenB(sngData) - 1)
            api_CopyMemory arrData(0), sngData, LenB(sngData)
        Case Else
            Err.Raise sckUnsupported, "CSocketMaster.SendData", "Unsupported variant type."
    End Select'if there's already something in the buffer that means we are
'already sending data, so we put the new data in the buffer
'and exit silently
If Len(m_strSendBuffer) > 0 Then
'    m_strSendBuffer = m_strSendBuffer & StrConv(arrData(), vbUnicode)
    m_strSendBuffer = m_strSendBuffer & ArrToHex(arrData)
    Exit Sub
Else
'    m_strSendBuffer = m_strSendBuffer + StrConv(arrData(), vbUnicode)
    m_strSendBuffer = m_strSendBuffer & ArrToHex(arrData)
End If'send the data
SendBufferedDataEnd Sub

Answer 10

'Send buffered data if we are using TCP protocol.
Private Sub SendBufferedDataTCP()Dim arrData()       As Byte
Dim lngBufferLength As Long
Dim lngResult    As Long
Dim lngTotalSent As LongDo Until lngResult = SOCKET_ERROR Or Len(m_strSendBuffer) = 0'    lngBufferLength = Len(m_strSendBuffer)
    lngBufferLength = Len(m_strSendBuffer) / 2    If lngBufferLength > m_lngSendBufferLen Then
        lngBufferLength = m_lngSendBufferLen
'        arrData() = StrConv(Left$(m_strSendBuffer, m_lngSendBufferLen), vbFromUnicode)
        arrData = HexToArr(Left(m_strSendBuffer, m_lngSendBufferLen * 2))
    Else
'        arrData() = StrConv(m_strSendBuffer, vbFromUnicode)
        arrData = HexToArr(m_strSendBuffer)
    End If    lngResult = api_send(m_lngSocketHandle, arrData(0), lngBufferLength, 0&)    If lngResult = SOCKET_ERROR Then
        Dim lngErrorCode As Long
        lngErrorCode = Err.LastDllError
    
        If lngErrorCode = WSAEWOULDBLOCK Then
            '★★★★★★★★★★debug.print "WARNING: Send buffer full, waiting..."
'            If lngTotalSent > 0 Then RaiseEvent SendProgress(lngTotalSent, Len(m_strSendBuffer))
            If lngTotalSent > 0 Then RaiseEvent SendProgress(lngTotalSent, Len(m_strSendBuffer) / 2)
        Else
            m_enmState = sckError: '★★★★★★★★★★debug.print "STATE: sckError"
            Dim blnCancelDisplay As Boolean
            blnCancelDisplay = True
            RaiseEvent Error(lngErrorCode, GetErrorDescription(lngErrorCode), 0, "CSocketMaster.SendBufferedData", "", 0, blnCancelDisplay)
            If blnCancelDisplay = False Then MsgBox GetErrorDescription(lngErrorCode), vbOKOnly, "CSocketMaster.SendBufferedData"
        End If    Else
        '★★★★★★★★★★debug.print "OK Bytes sent: " & lngResult
        lngTotalSent = lngTotalSent + lngResult
'        If Len(m_strSendBuffer) > lngResult Then
        If Len(m_strSendBuffer) / 2 > lngResult Then
'            m_strSendBuffer = Mid$(m_strSendBuffer, lngResult + 1)
            m_strSendBuffer = Mid$(m_strSendBuffer, 2 * (lngResult + 1))
        Else
            '★★★★★★★★★★debug.print "OK Finished SENDING"
            m_strSendBuffer = ""
            Dim lngTemp As Long
            lngTemp = lngTotalSent
            lngTotalSent = 0
            RaiseEvent SendProgress(lngTemp, 0)
            RaiseEvent SendComplete
        End If
    End IfLoopEnd Sub'Send buffered data if we are using UDP protocol.
Private Sub SendBufferedDataUDP()
Dim lngAddress As Long
Dim udtSockAddr As sockaddr_in
Dim arrData() As Byte
Dim lngBufferLength As Long
Dim lngResult As Long
Dim lngErrorCode As Long   
Dim strTemp As String
lngAddress = ResolveIfHostnameSync(m_strRemoteHost, strTemp, lngErrorCode)
    
If lngErrorCode <> 0 Then
    m_strSendBuffer = ""
    
    If lngErrorCode = WSAEAFNOSUPPORT Then
        Err.Raise lngErrorCode, "CSocketMaster.SendBufferedDataUDP", GetErrorDescription(lngErrorCode)
    Else
        Err.Raise sckInvalidArg, "CSocketMaster.SendBufferedDataUDP", "Invalid argument"
    End If
End IfWith udtSockAddr
    .sin_addr = lngAddress
    .sin_family = AF_INET
    .sin_port = api_htons(modSocketMaster.UnsignedToInteger(m_lngRemotePort))
End With
    
lngBufferLength = Len(m_strSendBuffer)
    
'arrData() = StrConv(m_strSendBuffer, vbFromUnicode)
arrData = HexToArr(m_strSendBuffer) 'Bingo##################################################################m_strSendBuffer = ""lngResult = api_sendto(m_lngSocketHandle, arrData(0), lngBufferLength, 0&, udtSockAddr, LenB(udtSockAddr))
    
If lngResult = SOCKET_ERROR Then
    lngErrorCode = Err.LastDllError
    m_enmState = sckError: '★★★★★★★★★★debug.print "STATE: sckError"
    Dim blnCancelDisplay As Boolean
    blnCancelDisplay = True
    RaiseEvent Error(lngErrorCode, GetErrorDescription(lngErrorCode), 0, "CSocketMaster.SendBufferedDataUDP", "", 0, blnCancelDisplay)
    If blnCancelDisplay = False Then MsgBox GetErrorDescription(lngErrorCode), vbOKOnly, "CSocketMaster.SendBufferedDataUDP"
End If
    
End Sub

Answer 11

'This function retrieves data from the Winsock buffer
'into the class local buffer. The function returns number
'of bytes retrieved (received).
Private Function RecvDataToBuffer() As Long
Dim arrBuffer() As Byte
Dim lngBytesReceived As Long
Dim strBuffTemporal As StringReDim arrBuffer(m_lngRecvBufferLen - 1)lngBytesReceived = api_recv(m_lngSocketHandle, arrBuffer(0), m_lngRecvBufferLen, 0&)If lngBytesReceived = SOCKET_ERROR Then
    
    m_enmState = sckError: '★★★★★★★★★★debug.print "STATE: sckError"
    Dim lngErrorCode As Long
    lngErrorCode = Err.LastDllError
    Err.Raise lngErrorCode, "CSocketMaster.RecvDataToBuffer", GetErrorDescription(lngErrorCode)
    
ElseIf lngBytesReceived > 0 Then
    
'    strBuffTemporal = StrConv(arrBuffer(), vbUnicode)
    strBuffTemporal = ArrToHex(arrBuffer) 'Bingo
'    m_strRecvBuffer = m_strRecvBuffer & Left$(strBuffTemporal, lngBytesReceived)
    m_strRecvBuffer = m_strRecvBuffer & Left$(strBuffTemporal, lngBytesReceived * 2) 'Bingo
    RecvDataToBuffer = lngBytesReceived
    
End IfEnd Function'Returns a byte array of Size bytes filled with incoming buffer data.
Private Function BuildArray(ByVal Size As Long, ByVal blnPeek As Boolean, ByRef lngErrorCode As Long) As Byte()
Dim strdata As StringIf m_enmProtocol = sckTCPProtocol Then
        
'    strdata = Left$(m_strRecvBuffer, CLng(Size))
'    BuildArray = StrConv(strdata, vbFromUnicode)
    strdata = Left$(m_strRecvBuffer, 2 * CLng(Size)) 'Bingo
    BuildArray = HexToArr(m_strRecvBuffer) 'Bingo
                
    If Not blnPeek Then
'        m_strRecvBuffer = Mid$(m_strRecvBuffer, Size + 1)
        m_strRecvBuffer = Mid$(m_strRecvBuffer, 2 * (Size + 1)) 'Bingo
    End IfElse 'UDP protocol
    Dim arrBuffer() As Byte
    Dim lngResult As Long
    Dim udtSockAddr As sockaddr_in
    Dim lngFlags As Long
    
    If blnPeek Then lngFlags = MSG_PEEK
    
    ReDim arrBuffer(Size - 1)
    
    lngResult = api_recvfrom(m_lngSocketHandle, arrBuffer(0), Size, lngFlags, udtSockAddr, LenB(udtSockAddr))
    
    If lngResult = SOCKET_ERROR Then
        lngErrorCode = Err.LastDllError
    End If
    
    BuildArray = arrBuffer
    GetRemoteInfoFromSI udtSockAddr, m_lngRemotePort, m_strRemoteHostIP, m_strRemoteHost
    
End If
End FunctionPublic Sub Accept(requestID As Long)
If m_enmState <> sckClosed Then
    Err.Raise sckInvalidOp, "CSocketMaster.Accept", "Invalid operation at current state"
End IfDim lngResult As Long
Dim udtSockAddr As sockaddr_in
Dim lngErrorCode As Longm_lngSocketHandle = requestID
m_enmProtocol = sckTCPProtocol
ProcessOptionsIf Not modSocketMaster.IsAcceptRegistered(requestID) Then
    If IsSocketRegistered(requestID) Then
        Err.Raise sckBadState, "CSocketMaster.Accept", "Wrong protocol or connection state for the requested transaction or request"
    Else
        m_blnAcceptClass = True
        m_enmState = sckConnected: '★★★★★★★★★★debug.print "STATE: sckConnected"
        modSocketMaster.RegisterSocket m_lngSocketHandle, ObjPtr(Me), False
        Exit Sub
    End If
End IfDim clsSocket As CSocketMaster
Set clsSocket = GetAcceptClass(requestID)
modSocketMaster.UnregisterAccept requestIDlngResult = api_getsockname(m_lngSocketHandle, udtSockAddr, LenB(udtSockAddr))If lngResult = SOCKET_ERROR Then
    
    lngErrorCode = Err.LastDllError
    Err.Raise lngErrorCode, "CSocketMaster.Accept", GetErrorDescription(lngErrorCode)
    
Else    m_lngLocalPortBind = IntegerToUnsigned(api_ntohs(udtSockAddr.sin_port))
    m_strLocalIP = StringFromPointer(api_inet_ntoa(udtSockAddr.sin_addr))
    
End IfGetRemoteInfo m_lngSocketHandle, m_lngRemotePort, m_strRemoteHostIP, m_strRemoteHost
m_enmState = sckConnected: '★★★★★★★★★★debug.print "STATE: sckConnected"If clsSocket.BytesReceived > 0 Then
'    clsSocket.GetData m_strRecvBuffer
    Dim Arr() As Byte 'Bingo
    clsSocket.GetData Arr   'Bingo
    m_strRecvBuffer = ArrToHex(Arr) 'Bingo
End IfmodSocketMaster.Subclass_ChangeOwner requestID, ObjPtr(Me)'If Len(m_strRecvBuffer) > 0 Then RaiseEvent DataArrival(Len(m_strRecvBuffer))
If Len(m_strRecvBuffer) > 0 Then RaiseEvent DataArrival(Len(m_strRecvBuffer) / 2) 'BingoIf clsSocket.State = sckClosing Then
    m_enmState = sckClosing: '★★★★★★★★★★debug.print "STATE: sckClosing"
    RaiseEvent CloseSck
End IfSet clsSocket = Nothing
End Sub
因为要转化,通讯效率不高,而且速度会变慢

Answer 12

UDP我不用，只用TCP/IP实现HTTP协议

Answer 13

我的合并数组有问题
    '合并HTTP数据
    Dim OldLeng As Long
    Dim AddLeng As Long
    OldLeng = UBound(HttpData)
    AddLeng = UBound(Filedata)
    ReDim PostData(OldLeng + AddLeng + 1)
    For i = 0 To OldLeng
        PostData(i) = HttpData(i)
    Next
    
    For j = i To AddLeng + i
        PostData(j) = Filedata(j - i)
    Next
'原来直接内存复制的方法有问题
    'ReDim Preserve HttpData(OldLeng + AddLeng)
    'CopyMemory HttpData(OldLeng), Filedata(0), AddLeng

Answer 14

把我这里的几个函数替换掉原来的,然后就按winsock的用法用就行了,只不过速度会慢一些
你只是数据转换问题的话,建议用strconv函数来处理好了