cftpconnection.cls

用vb开发的ftp客服端

'********************************************************************************

On Error GoTo Connect_Err_Handler

Dim strData     As String

m_strWinsockBuffer = ""
m_bBusy = True

If Len(m_varFtpServer) > 0 Then
    With wscControl
        .Close
        .LocalPort = 0
        .Connect m_varFtpServer, 21
        m_objTimeOut.StartTimer
        Do
            DoEvents
            '
            If m_objTimeOut.Timeout Then
                m_LastError = ERROR_FTP_USER_TIMEOUT
                Exit Do
            End If
            '
            If .State = sckConnected Then
                m_objTimeOut.StopTimer
                RaiseEvent StateChanged(FTP_CONNECTION_CONNECTED)
                m_objTimeOut.StartTimer
                Do
                    DoEvents
                    '
                    If m_objTimeOut.Timeout Then
                        m_LastError = ERROR_FTP_USER_TIMEOUT
                        Exit Do
                    End If
                    '
                    If Len(m_strWinsockBuffer) > (RESPONSE_CODE_LENGHT - 1) Then
                        strData = m_strWinsockBuffer
                        m_strWinsockBuffer = ""
                        Exit Do
                    End If
                Loop
                m_objTimeOut.StopTimer
                Select Case GetResponseCode(strData)
                    Case FTP_RESPONSE_SERVICE_READY_FOR_NEW_USER
                        Select Case ProcessUSERCommand
                            Case FTP_RESPONSE_USER_LOGGED_IN
                                Connect = True
                            Case FTP_RESPONSE_USER_NAME_OK_NEED_PASSWORD
                                If ProcessPASSCommand = FTP_RESPONSE_USER_LOGGED_IN Then
                                    Connect = True
                                End If
                        End Select
                        'Get working directory
                        If Connect Then
                            Call ProcessPWDCommand
                        End If
                    Case FTP_RESPONSE_SERVICE_READY_IN_MINUTES
                        '120 Service ready in nnn minutes.
                        m_LastError = ERROR_FTP_PROTOCOL_SERVICE_READY_IN_MINUTES
                    Case FTP_RESPONSE_SERVICE_NOT_AVAILABLE_CLOSING_CONTROL_CONNECTION
                        '421 Service not available, closing control connection.
                        m_LastError = ERROR_FTP_PROTOCOL_SERVICE_NOT_AVAILABLE_CLOSING_CONTROL_CONNECTION
                End Select
                Exit Do
            ElseIf .State = sckConnectAborted Then
                m_LastError = ERROR_FTP_WINSOCK_ConnectAborted
            ElseIf .State = sckResolvingHost Then
                RaiseEvent StateChanged(FTP_CONNECTION_RESOLVING_HOST)
            ElseIf .State = sckHostResolved Then
                RaiseEvent StateChanged(FTP_CONNECTION_HOST_RESOLVED)
            End If
        Loop
        m_objTimeOut.StopTimer
    End With
Else
    'raise error
    Connect = False
    Exit Function
End If

Exit_Label:
    If Connect Then RaiseEvent StateChanged(FTP_USER_LOGGED)
    m_bBusy = False
    Exit Function

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

Private Sub Class_Initialize()

    Set wscControl = New MSWinsockLib.Winsock
    Set wscData = New MSWinsockLib.Winsock
    Set m_objTimeOut = New CTimeout

End Sub

Private Function GetResponseCode(strResponse As String) As Integer

    If Len(strResponse) > (RESPONSE_CODE_LENGHT - 1) Then
        GetResponseCode = CInt(Left$(strResponse, 3))
    End If
        
End Function

Private Function ProcessUSERCommand() As FTP_RESPONSE_CODES

    Dim strData     As String
    
    On Error GoTo ProcessUSERCommand_Err_Handler
    
    RaiseEvent StateChanged(FTP_CONNECTION_AUTHENTICATION)

    m_strUserName = IIf(Len(m_strUserName) > 0, m_strUserName, "anonymous")
    
    If Len(m_strPassword) = 0 Then
        If m_strUserName = "anonymous" Then
            m_strPassword = "[e-mail]"
        Else
            'raise error
            Exit Function
        End If
    End If
    
    wscControl.SendData "USER " & m_strUserName & vbCrLf
    Debug.Print "USER " & m_strUserName
    
    m_objTimeOut.StartTimer
    Do
        DoEvents
        '
        If m_objTimeOut.Timeout Then
            m_LastError = ERROR_FTP_USER_TIMEOUT
            Exit Do
        End If
        '
        If Len(m_strWinsockBuffer) > RESPONSE_CODE_LENGHT Then
            strData = m_strWinsockBuffer
            m_strWinsockBuffer = ""
            Exit Do
        End If
    Loop
    m_objTimeOut.StopTimer
    
    Select Case GetResponseCode(strData)
        Case FTP_RESPONSE_USER_LOGGED_IN
            ProcessUSERCommand = FTP_RESPONSE_USER_LOGGED_IN
        Case FTP_RESPONSE_USER_NAME_OK_NEED_PASSWORD
            ProcessUSERCommand = FTP_RESPONSE_USER_NAME_OK_NEED_PASSWORD
        Case Else
            ProcessFtpResponse GetResponseCode(strData)
    End Select
    
Exit_Label:
    Exit Function

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

Private Function ProcessPASSCommand() As FTP_RESPONSE_CODES

    Dim strResponse As String
    Dim strData     As String
    '
    On Error GoTo ProcessPASSCommand_Err_Handler

    wscControl.SendData "PASS " & m_strPassword & vbCrLf
    Debug.Print "PASS " & m_strPassword
    
    m_objTimeOut.StartTimer
    Do
        DoEvents
        '
        If m_objTimeOut.Timeout Then
            m_LastError = ERROR_FTP_USER_TIMEOUT
            Exit Do
        End If
        '
        If Len(m_strWinsockBuffer) > RESPONSE_CODE_LENGHT Then
            strData = m_strWinsockBuffer
            Exit Do
        End If
    Loop
    m_objTimeOut.StopTimer

    If GetResponseCode(strData) = FTP_RESPONSE_USER_LOGGED_IN Then
        Do
            DoEvents
            If InStr(1, m_strWinsockBuffer, "230 ") > 0 Then
                ProcessPASSCommand = FTP_RESPONSE_USER_LOGGED_IN
                m_strWinsockBuffer = ""
                Exit Function
            End If
        Loop
    Else
        ProcessFtpResponse GetResponseCode(strData)
    End If
    ProcessPASSCommand = GetResponseCode(strData)
    
Exit_Label:
    Exit Function

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

Private Function ProcessPWDCommand() As Boolean

    Dim strResponse As String
    Dim strData     As String
    
    On Error GoTo ProcessPWDCommand_Err_Handler

    wscControl.SendData "PWD" & vbCrLf
    Debug.Print "PWD"
    
    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
        Dim intPosA As Integer, intPosB As Integer
        intPosA = InStr(1, strData, Chr$(34)) + 1
        intPosB = InStr(intPosA, strData, Chr$(34))
        If intPosA > 1 And intPosB > 0 Then
            m_strCurrentDirectory = Mid$(strData, intPosA, intPosB - intPosA)
            ProcessPWDCommand = True
        Else
            'raise error - unknown response format
        End If
    Else
        ProcessFtpResponse GetResponseCode(strData)
    End If
    
Exit_Label:
    Exit Function

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

Private Sub Class_Terminate()
    
    Call BreakeConnection
    Set wscData = Nothing
    Set wscControl = Nothing
    
    m_objTimeOut.StopTimer
    Set m_objTimeOut = Nothing
    
End Sub

Private Sub wscControl_DataArrival(ByVal bytesTotal As Long)
    
    Dim strData As String
    
    wscControl.GetData strData
    m_strWinsockBuffer = m_strWinsockBuffer & strData
    m_strLastServerResponse = strData
    m_objTimeOut.Reset
    
    
    If GetResponseCode(strData) = 426 Then
        If m_bTransferInProgress Or m_bUploadFile Then
            wscData.Close
            Close m_intLocalFileID
            m_strDataBuffer = ""
            m_lDownloadedBytes = 0
            m_lUploadedBytes = 0
            m_bTransferInProgress = False
            m_bUploadFile = False
            m_bFileIsOpened = False
        End If
        wscControl.Close
        m_bBusy = False
    End If
    
    Debug.Print Left(strData, Len(strData) - 2)
    
End Sub

Private Function ProcessPORTCommand() As Boolean

    Dim intPort         As Integer
    Dim strIPAddress    As String
    Dim colIPAddresses  As New Collection
    Dim strSend         As String
    Dim strData         As String
    
    On Error Resume Next
    
    RaiseEvent StateChanged(FTP_ESTABLISHING_DATA_CONNECTION)
    
    Do
        intPort = GetFreePort
        If wscData.State <> sckClosed Then wscData.Close
        wscData.LocalPort = intPort
        wscData.Listen
        If Not Err Then Exit Do
    Loop
    
    On Error GoTo ProcessPORTCommand_Err_Handler
    '
    strIPAddress = CStr(wscControl.LocalIP)
    '
    strSend = "PORT " & Replace(strIPAddress, ".", ",")
    strSend = strSend & "," & intPort \ 256 & "," & (intPort Mod 256)
    '
    strSend = strSend & vbCrLf
    '
    wscControl.SendData strSend
    Debug.Print Left(strSend, Len(strSend) - 2)
    
    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
        ProcessPORTCommand = True
        RaiseEvent StateChanged(FTP_DATA_CONNECTION_ESTABLISHED)
    Else
        ProcessFtpResponse GetResponseCode(strData)
    End If
    
Exit_Label:
    Exit Function

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

Private Function GetFreePort() As Integer
    
    Static intPort As Integer
    
    If intPort = 0 Then
        intPort = 1100
    Else
        intPort = intPort + 1
    End If
    
    GetFreePort = intPort
    
End Function

Private Sub wscData_ConnectionRequest(ByVal requestID As Long)
    
    If wscData.State <> sckClosed Then wscData.Close
    
    wscData.Accept (requestID)