cftpconnection.cls

vb网络通信协议,参考例程

        End If
    Loop
    m_objTimeOut.StopTimer

    If GetResponseCode(strData) = FTP_RESPONSE_REQUESTED_FILE_ACTION_PENDING_FURTHER_INFO Then
        ProcessRNFRCommand = True
    Else
        ProcessFtpResponse GetResponseCode(strData)
    End If

Exit_Label:
    Exit Function

ProcessRNFRCommand_Err_Handler:
    If Not ProcessWinsockError(Err.Number, Err.Description) Then
        Err.Raise vbObjectError + 1000 + Err.Number, "CFtpConnection.ProcessRNFRCommand", Err.Description
    End If
    GoTo Exit_Label
    
End Function

Private Function ProcessRNTOCommand(strFileName As String) As Boolean
'该函数的功能是向服务器发送rnto命令
    Dim strResponse As String
    Dim strData     As String
    
    On Error GoTo ProcessRNTOCommand_Err_Handler
    
    wscControl.SendData "RNTO " & strFileName & vbCrLf
    Debug.Print "RNTO " & strFileName
    RaiseEvent ReplyMessage("RNTO " & strFileName & vbCrLf)
    
    m_objTimeOut.StartTimer
    Do
        DoEvents
        '
        If m_objTimeOut.Timeout Then
            m_LastError = ERROR_FTP_USER_TIMEOUT
            Exit Do
        End If
        '
        If InStr(1, m_strWinsockBuffer, vbCrLf) > 0 Then
            strData = m_strWinsockBuffer
            m_strWinsockBuffer = ""
            Exit Do
        End If
    Loop
    m_objTimeOut.StopTimer

    If GetResponseCode(strData) = FTP_RESPONSE_REQUESTED_FILE_ACTION_OK_COMPLETED Then
        ProcessRNTOCommand = True
    Else
        ProcessFtpResponse GetResponseCode(strData)
    End If
    
Exit_Label:
    Exit Function

ProcessRNTOCommand_Err_Handler:
    If Not ProcessWinsockError(Err.Number, Err.Description) Then
        Err.Raise vbObjectError + 1000 + Err.Number, "CFtpConnection.ProcessRNTOCommand", Err.Description
    End If
    GoTo Exit_Label

End Function

Public Function UploadFile(strLocalFileName As String, strRemoteFileName As String, vTransferMode As FtpTransferModes, Optional lStartPoint As Long) As Boolean
'该函数的功能是向服务器上传数据
    Dim bDataConnectionEstablished As Boolean
        
    m_bBusy = True
        
    If Not (vTransferMode = m_TransferMode) Then
        If ProcessTYPECommand(vTransferMode) Then
            m_TransferMode = vTransferMode
        Else
            Exit Function
        End If
    End If
    
    If m_bPassiveMode Then
        bDataConnectionEstablished = ProcessPASVCommand
    Else
        bDataConnectionEstablished = ProcessPORTCommand
    End If
    
    If bDataConnectionEstablished Then
        '
        If Not IsMissing(lStartPoint) Then
            If Not ProcessRESTCommand(lStartPoint) Then
                UploadFile = False
                Exit Function
            End If
        End If
        '
        m_strLocalFilePath = strLocalFileName
        m_bUploadFile = True
        If ProcessSTORCommand(strLocalFileName, strRemoteFileName, lStartPoint) Then
            m_objTimeOut.StartTimer
            Do
                DoEvents
                '
                If m_objTimeOut.Timeout Then
                    m_LastError = ERROR_FTP_USER_TIMEOUT
                    Exit Do
                End If
                '
                If wscData.State = sckClosing Or _
                    wscData.State = sckClosed Then
                    'clear winsock buffer
                    RaiseEvent StateChanged(FTP_TRANSFER_COMLETED)
                    Exit Do
                End If
            Loop
            m_objTimeOut.StopTimer
            UploadFile = True
        End If
    End If
    
    m_bBusy = False
    
End Function

Private Function ProcessSTORCommand(strLocalFileName As String, strRemoteFileName As String, lStartPoint As Long) As Boolean
'该函数的功能是向服务器发送stor命令，让服务器准备接收一个来自数据连接的文件
    Dim strResponse As String
    Dim strData     As String
    
    On Error GoTo ProcessSTORCommand_Err_Handler
    
    m_strDataBuffer = ""

    wscControl.SendData "STOR " & strRemoteFileName & vbCrLf
    Debug.Print "STOR " & strRemoteFileName
    RaiseEvent ReplyMessage("STOR " & strRemoteFileName & vbCrLf)
    
    m_objTimeOut.StartTimer
    Do
        DoEvents
        '
        If m_objTimeOut.Timeout Then
            m_LastError = ERROR_FTP_USER_TIMEOUT
            Exit Do
        End If
        '
        If InStr(1, m_strWinsockBuffer, vbCrLf) > 0 Then
            If GetResponseCode(m_strWinsockBuffer) = 150 Or _
                GetResponseCode(m_strWinsockBuffer) = 125 Then

                m_strWinsockBuffer = ""
                RaiseEvent StateChanged(FTP_TRANSFER_STARTING)
                m_strLocalFilePath = strLocalFileName
                Call UploadData(lStartPoint)
            Else
                strData = m_strWinsockBuffer
                m_strWinsockBuffer = ""
                Exit Do
            End If
        End If
    Loop
    m_objTimeOut.StopTimer

    If GetResponseCode(strData) = FTP_RESPONSE_CLOSING_DATA_CONNECTION Or _
        GetResponseCode(strData) = FTP_RESPONSE_REQUESTED_FILE_ACTION_OK_COMPLETED Then
        ProcessSTORCommand = True
    Else
        ProcessFtpResponse GetResponseCode(strData)
    End If
    
Exit_Label:
    Exit Function

ProcessSTORCommand_Err_Handler:
    If Not ProcessWinsockError(Err.Number, Err.Description) Then
        Err.Raise vbObjectError + 1000 + Err.Number, "CFtpConnection.ProcessSTORCommand", Err.Description
    End If
    GoTo Exit_Label

End Function

Private Sub wscData_SendComplete()
    
    If m_bUploadFile Then
        Call UploadData(0)
    End If
    
    m_objTimeOut.Reset
    
End Sub

Private Sub wscData_SendProgress(ByVal bytesSent As Long, ByVal bytesRemaining As Long)

    m_lUploadedBytes = m_lUploadedBytes + bytesSent
    
    RaiseEvent UploadProgress(m_lUploadedBytes)

End Sub

Private Sub UploadData(lStartPoint As Long)
'--------------------------------------------------------------------------------
'该函数的功能是是打开一个文件，然后把数据上传到服务器，每次传送4k字节
'modified by wxp
'date 2000-11
'说明 :如果一次传送多于4k的字节，则有可能多次产生wscFtpData_SendComplete事件
'--------------------------------------------------------------------------------
    
    Const CHANK_SIZE As Integer = 4096
    
    Static bFileIsOpen  As Boolean  '标记变量
    Static lChanksCount As Long     '总共要传送的次数
    Static lCounter     As Long     '已经传送的次数
    Static intRemainder As Integer  '
    Dim strData()         As Byte   '用来存放被发送的数据
    
    On Error GoTo UploadData_Err_Handler
    '如果 bFileIsOpen = True,则表示文件已经被打开了
    If m_bFileIsOpened Then
        '上传下一个数据包
        If lCounter < lChanksCount And lCounter > 0 Then
            '首先开辟一个4k的缓存
            ReDim strData(CHANK_SIZE)
            '计数器加一
            lCounter = lCounter + 1
            '从文件中读去数据到strdata中
            Get m_intLocalFileID, , strData()
            '发送数据
            wscData.SendData strData()
        Else
            '所有的数据已经上载
            If lCounter = 0 Then
                '
                '关闭数据连接
                '连接已经完成
                '
                wscData.Close
                '
                '关闭本地文件
                '
                Close #m_intLocalFileID
                '
                RaiseEvent StateChanged(FTP_TRANSFER_COMLETED)
                '
                '初始化一些数据
                
                '
                m_lUploadedBytes = 0:       lChanksCount = 0: intRemainder = 0
                m_bFileIsOpened = False:        m_bUploadFile = False
                '
            Else
                '现在发送剩余的数据
                'now we have to send the remainder
                ReDim strData(intRemainder)
                '将计数器清0，下面是最后一批数据了
                lCounter = 0
                '从文件中读取数据
                Get m_intLocalFileID, , strData()
                '发送数据
                m_objTimeOut.StartTimer
                Do
                    DoEvents
                    '
                    If m_objTimeOut.Timeout Then
                        m_LastError = ERROR_FTP_USER_TIMEOUT
                        Exit Do
                    End If
                    '
                    If wscData.State = sckConnected Then
                        wscData.SendData strData
                        Exit Do
                    End If
                Loop
                m_objTimeOut.StopTimer
            End If
        End If
    Else
        '
        '以下是第一次发送数据，需要打开文件
        '
        m_bFileIsOpened = True  '做一个文件打开的标志
        '
        m_intLocalFileID = FreeFile
        '
        Open m_strLocalFilePath For Binary As m_intLocalFileID
        '如果开始上传的起始点大于0，则表示是发送剩余的数据，类似与断点续传
        If lStartPoint > 0 Then
            Seek m_intLocalFileID, lStartPoint + 1
            m_lUploadedBytes = lStartPoint
            '获得剩余文件大小，并计算需要分成几个数据包发送
            lChanksCount = CLng((FileLen(m_strLocalFilePath) - lStartPoint) \ CHANK_SIZE)
            '获得不完整数据包即最后一个数据包的大小
            intRemainder = (FileLen(m_strLocalFilePath) - lStartPoint) Mod CHANK_SIZE
        Else
            '
            '如果是上传整个文件,则计算完整的数据包的个数
            lChanksCount = CLng(FileLen(m_strLocalFilePath) \ CHANK_SIZE)
            '
            '获得剩余字节
            intRemainder = FileLen(m_strLocalFilePath) Mod CHANK_SIZE
        End If

        
        If lChanksCount = 0 Then
            '如果整个文件不足一个完整的数据包，即4k，则创建一个实际文件大小的缓存区
            
            ReDim strData(intRemainder)
        Else
            '
            '否则创建一个4k大小的内存空间
            ReDim strData(CHANK_SIZE)
            '将发送数据包的计数器设置为1
            lCounter = 1
        End If
        
        '从文件中读取数据
        Get m_intLocalFileID, , strData
        '发送数据
                Do
                    DoEvents
                    If wscData.State = sckConnected Then
                        wscData.SendData strData
                        Exit Do
                    End If
                Loop
        '
    End If
    
    Exit Sub
    
Exit_Label:
    Exit Sub

UploadData_Err_Handler:
    If Not ProcessWinsockError(Err.Number, Err.Description) Then
        Err.Raise vbObjectError + 1000 + Err.Number, "CFtpConnection.UploadData", Err.Description
    End If
    Close #intFile
    GoTo Exit_Label
    
End Sub

Private Function ShowTimeOut() As Boolean

    Dim intRetVal As Integer
    
    intRetVal = MsgBox("A time-out occurred while communicating with the server." & _
                "The server took too long to respond." & vbCrLf & vbCrLf & _
                "Would you like to wait for server response?", vbYesNo + vbQuestion, _
                "Time out")
    
    If intRetVal = vbYes Then
        m_objTimeOut.Reset
        m_objTimeOut.StartTimer
        ShowTimeOut = True
    End If
    
End Function

Public Property Let Timeout(NewValue As Integer)
    m_intTimeout = NewValue
    m_objTimeOut.TimeoutValue = NewValue
End Property

Public Property Get Timeout() As Integer
    Timeout = m_intTimeout
End Property

Public Property Get Busy() As Boolean
    Busy = m_bBusy
End Property

Private Function ProcessWinsockError(intError As ErrorConstants, strDesc As String) As Boolean
'该函数的功能处理winsock通讯时的错误
    m_strLastErrorDesc = strDesc
    
    Select Case intError
        Case sckAddressInUse
            m_LastError = ERROR_FTP_WINSOCK_AddressInUse
        Case sckAddressNotAvailable
            m_LastError = ERROR_FTP_WINSOCK_AddressNotAvailable
        Case sckAlreadyComplete
            m_LastError = ERROR_FTP_WINSOCK_AlreadyComplete
        Case sckAlreadyConnected
            m_LastError = ERROR_FTP_W