cftpconnection.cls

本书源码主要针对目前流行的FTP、HTTP、E-mail、Telnet、ICMP、Modem串口通信编程、拨号网络编程等内容进行详细的讲解

                    If Left$(GetLastServerResponse, 3) = "426" Then
                        m_LastError = FTP_RESPONSE_CONNECTION_CLOSED_TRANSFER_ABORTED
                        Call ProcessFtpResponse(FTP_RESPONSE_CONNECTION_CLOSED_TRANSFER_ABORTED)
                        DownloadFile = False
                    Else
                        DownloadFile = True
                    End If
                    Exit Do
                End If
            Loop
            m_objTimeOut.StopTimer
        Else
            DownloadFile = False
            m_bTransferInProgress = False
            Close #m_intLocalFileID
        End If
    End If
    
    m_bBusy = False

End Function

Private Function ProcessRETRCommand(strFileName As String, lStartPoint As Long) As Boolean
'该函数的命令是向服务器发送retr命令，让服务器给客户传送一份在路径名中指定的文件的副本
    Dim strResponse As String
    Dim strData     As String
    
    
    On Error GoTo ProcessRETRCommand_Err_Handler
    
    m_strDataBuffer = ""

    wscControl.SendData "RETR " & strFileName & vbCrLf
    Debug.Print "RETR " & strFileName
    RaiseEvent ReplyMessage("RETR " & strFileName & vbCrLf)
    m_objTimeOut.StartTimer
    AllBytes = 0
    Do
        DoEvents
        '
        If m_objTimeOut.Timeout Then
            m_LastError = ERROR_FTP_USER_TIMEOUT
            Exit Do
        End If
        '
        If Not m_bTransferInProgress Then
            strData = m_strWinsockBuffer
            Exit Do
        End If
        '
        
        If InStr(1, m_strWinsockBuffer, vbCrLf) > 0 Then
            If GetResponseCode(m_strWinsockBuffer) = 150 Or _
                GetResponseCode(m_strWinsockBuffer) = 125 Then
                If lStartPoint = 0 And FileExists(m_strLocalFilePath) Then
                    Kill m_strLocalFilePath
                End If
                
                '如果文件没有打开,则打开文件
                If Not m_bFileIsOpened Then
                    m_intLocalFileID = FreeFile
                    If m_bFileIsOpened Then
                        Open m_strLocalFilePath For Binary As m_intLocalFileID
                    End If
                    If lStartPoint > 0 Then
                        Seek m_intLocalFileID, lStartPoint + 1
                    End If
                    m_bFileIsOpened = True
                    m_lDownloadedBytes = 0
                End If
                
                m_strWinsockBuffer = Mid$(m_strWinsockBuffer, InStr(1, m_strWinsockBuffer, vbCrLf) + 2)
                RaiseEvent StateChanged(FTP_TRANSFER_STARTING)
            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
        ProcessRETRCommand = True
    Else
        ProcessFtpResponse GetResponseCode(strData)
        ProcessRETRCommand = False
    End If
    Debug.Print GetResponseCode(strData)
Exit_Label:
    Exit Function

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

Private Function ProcessRESTCommand(lStartPoint As Long) As Boolean
'该函数的的功能是向服务器发送rest命令，表示将从lstartpoint点开始传输文件
    Dim strResponse As String
    Dim strData     As String
    
    On Error GoTo ProcessRESTCommand_Err_Handler
    
    wscControl.SendData "REST " & lStartPoint & vbCrLf
    Debug.Print "REST " & lStartPoint
    RaiseEvent ReplyMessage("REST " & lStartPoint & 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_PENDING_FURTHER_INFO Then
        ProcessRESTCommand = True
    Else
        ProcessFtpResponse GetResponseCode(strData)
    End If
    
Exit_Label:
    Exit Function

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

Public Sub BreakeConnection()
    
    On Error Resume Next
    
    If wscData <> sckClosed Then
        wscData.Close
    Else
        wscControl.Close
    End If
    
    If m_bTransferInProgress Or m_bUploadFile Then
        Close m_intLocalFileID
        m_strDataBuffer = ""
        m_lDownloadedBytes = 0
        m_lUploadedBytes = 0
        m_bTransferInProgress = False
        m_bUploadFile = False
    End If
    m_bFileIsOpened = False
    m_bBusy = False
    m_objTimeOut.StopTimer
    
End Sub

Private Function ProcessTYPECommand(vType As FtpTransferModes) As Boolean
'该函数的功能是向服务器发送type命令，表示传输模式
    Dim strResponse As String
    Dim strData     As String
    
    On Error GoTo ProcessTYPECommand_Err_Handler
    
    wscControl.SendData "TYPE " & IIf(vType = FTP_ASCII_MODE, "A", "I") & vbCrLf
    Debug.Print "TYPE " & IIf(vType = FTP_ASCII_MODE, "A", "I")
    RaiseEvent ReplyMessage("TYPE " & IIf(vType = FTP_ASCII_MODE, "A", "I") & 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_COMMAND_OK Then
        ProcessTYPECommand = True
    Else
        ProcessFtpResponse GetResponseCode(strData)
    End If
    
Exit_Label:
    Exit Function

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

End Function

Private Function FileExists(strFileName As String) As Boolean
    
    On Error GoTo ERROR_HANDLER
    
    FileExists = (GetAttr(strFileName) And vbDirectory) = 0

ERROR_HANDLER:
    
End Function

Private Function ProcessDELECommand(strFileName As String) As Boolean
'该函数的功能是删除指定的文件
    Dim strResponse As String
    Dim strData     As String
    '
    On Error GoTo ProcessDELECommand_Err_Handler
    
    wscControl.SendData "DELE " & strFileName & vbCrLf
    Debug.Print "DELE " & strFileName
    RaiseEvent ReplyMessage("DELE " & 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
        ProcessDELECommand = True
    Else
        ProcessFtpResponse (GetResponseCode(strData))
    End If
    
Exit_Label:
    Exit Function
    
ProcessDELECommand_Err_Handler:
    If Not ProcessWinsockError(Err.Number, Err.Description) Then
        Err.Raise vbObjectError + 1000 + Err.Number, "CFtpConnection.ProcessDELECommand", Err.Description
    End If
    GoTo Exit_Label

End Function

Private Function ProcessMKDCommand(strDirName As String) As Boolean
'该函数的功能是创建新的目录
    Dim strResponse As String
    Dim strData     As String
    '
    On Error GoTo ProcessMKDCommand_Err_Handler
    
    wscControl.SendData "MKD " & strDirName & vbCrLf
    Debug.Print "MKD " & strDirName
    RaiseEvent ReplyMessage("MKD " & strDirName & 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_PATHNAME_CREATED Then
        ProcessMKDCommand = True
    Else
        ProcessFtpResponse GetResponseCode(strData)
    End If

Exit_Label:
    Exit Function

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

Private Function ProcessRMDCommand(strDirName As String) As Boolean
'该函数的功能是向服务器发送rmd命令，表示要删除一个目录
    Dim strResponse As String
    Dim strData     As String
    
    On Error GoTo ProcessRMDCommand_Err_Handler
    
    wscControl.SendData "RMD " & strDirName & vbCrLf
    Debug.Print "RMD " & strDirName
    RaiseEvent ReplyMessage("RMD " & strDirName & 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
        ProcessRMDCommand = True
    Else
        ProcessFtpResponse GetResponseCode(strData)
    End If
    
Exit_Label:
    Exit Function

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

End Function


Private Function ProcessRNFRCommand(strFileName As String) As Boolean
'该函数的功能是向服务器发送rnfr命令，表示要重新命名一个文件名
    Dim strResponse As String
    Dim strData     As String
    
    On Error GoTo ProcessRNFRCommand_Err_Handler
    
    wscControl.SendData "RNFR " & strFileName & vbCrLf
    Debug.Print "RNFR " & strFileName
    RaiseEvent ReplyMessage("RNFR " & 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