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

[kafly]

工作需要写了个ActiveX DLL

控件工作目的是实现上传图片到网站

由于无界面，放弃了WinSocket控件，使用CSocketMaster类

POST到WEB的数据包用的string格式，SendData后，IIS接收到的文件有少量损坏

文件长度一致，但是中间部分字节丢失（如86），末尾被00填充

求明灯

[笨狗先飞]

把字符串转成数组传送

[笨狗先飞]

先在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 Function

Private 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

[kafly]

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

[笨狗先飞]

然后改写后边这几个函数
SendData
SendBufferedDataUDP
SendBufferedDataTCP
RecvDataToBuffer
BuildArray
Accept
后边我可能贴不完,

Public Sub SendData(data As Variant)

Dim arrData() As Byte 'We store the data here before send it

If 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
SendBufferedData

End Sub

[笨狗先飞]

'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 Long

Do 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 If

Loop

End 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 If

With 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

[笨狗先飞]

'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 String

ReDim 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 If

End 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 String

If 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 If

Else '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 Function

Public Sub Accept(requestID As Long)
If m_enmState <> sckClosed Then
    Err.Raise sckInvalidOp, "CSocketMaster.Accept", "Invalid operation at current state"
End If

Dim lngResult As Long
Dim udtSockAddr As sockaddr_in
Dim lngErrorCode As Long

m_lngSocketHandle = requestID
m_enmProtocol = sckTCPProtocol
ProcessOptions

If 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 If

Dim clsSocket As CSocketMaster
Set clsSocket = GetAcceptClass(requestID)
modSocketMaster.UnregisterAccept requestID

lngResult = 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 If

GetRemoteInfo 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 If

modSocketMaster.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) 'Bingo

If clsSocket.State = sckClosing Then
    m_enmState = sckClosing: '★★★★★★★★★★debug.print "STATE: sckClosing"
    RaiseEvent CloseSck
End If

Set clsSocket = Nothing
End Sub

因为要转化,通讯效率不高,而且速度会变慢

[kafly]

UDP我不用，

只用TCP/IP实现HTTP协议

[咸清]

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

[咸清]

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

[kafly]

发包端我截包下来看就是和接收到的一样，缺字节，末尾被补0

[kafly]

[Quote=引用 1 楼 ybh37 的回复:]
CSocketMaster类
说实话，写的不错，但是不稳定。以前用过，后来就再也不用了。
[/Quote]

那有没有替代的东西？

我看它的SendData函数，里面有分不同数据类型来处理

但是第一次用VB，不知道VB怎么处理字节数据 byte类型

[咸清]

Public Sub SendData(data As Variant)

Dim arrData() As Byte 'We store the data here before send it

If 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
SendBufferedData

End Sub

这就是那个函数喽~~
你把 Public Sub SendData(data As Variant) 里面的 data 打印出来看看有没有问题。有问题的话就是代码处理的问题了

[kafly]

是的，我现在在用 Byte 类型来处理

方便加您QQ么？ 我的QQ 945881

[kafly]

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文件是可以的

[kafly]

我的合并数组有问题

'合并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

[笨狗先飞]

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