cftpconnection.cls

用vb开发的ftp客服端

End Sub

Private Sub wscData_DataArrival(ByVal bytesTotal As Long)
    
    Dim strData As String
    
    wscData.GetData strData
    
    If m_bTransferInProgress Then
        If m_bFileIsOpened Then
            '
            'write data to local file
            '
            Put m_intLocalFileID, , strData
            '
            'raise DownloadProgress event
            '
            m_lDownloadedBytes = m_lDownloadedBytes + bytesTotal
            RaiseEvent DownloadProgress(m_lDownloadedBytes)
        End If
    Else
        m_strDataBuffer = m_strDataBuffer & strData
'        Debug.Print strData
    End If
    
    m_objTimeOut.Reset

End Sub

Public Function RenameFile(strOldFileName As String, strNewFileName As String) As Boolean
    
    m_bBusy = True
    If ProcessRNFRCommand(strOldFileName) Then
        If ProcessRNTOCommand(strNewFileName) Then
            RenameFile = True
        End If
    End If
    m_bBusy = False

End Function

Public Function DeleteFile(strFileName As String) As Boolean
    
    m_bBusy = True
    DeleteFile = ProcessDELECommand(strFileName)
    m_bBusy = False

End Function

Public Function RemoveDirectory(strDirName As String) As Boolean
    
    m_bBusy = True
    RemoveDirectory = ProcessRMDCommand(strDirName)
    m_bBusy = False
    
End Function

Public Function CreateDirectory(strDirName As String) As Boolean
    
    m_bBusy = True
    CreateDirectory = ProcessMKDCommand(strDirName)
    m_bBusy = False
    
End Function

Private Function GetFileList(strListing As String) As CFtpFiles
    '
    Dim vFiles      As Variant
    Dim vFile       As Variant
    Dim vComponents As Variant
    Dim oFtpFile    As CFtpFile
    Dim oFtpFiles   As New CFtpFiles
    
    On Error Resume Next
    '
    Set GetFileList = Nothing
    '
    vFiles = Split(strListing, vbCrLf)
    '
    For Each vFile In vFiles
        Set oFtpFile = New CFtpFile
        '
        'replace multiple whitespaces with single whitespace
        '
        For i = 15 To 2 Step -1
            vFile = Replace(vFile, Space(i), " ")
        Next
        '
        If Len(vFile) > 0 Then
            If Not LCase(Left(vFile, 5)) = "total" Then
                vComponents = Split(vFile, " ")
                If UBound(vComponents) > 7 Then
                    With oFtpFile
                        If Left(vComponents(0), 1) = "d" Then
                            oFtpFile.IsDirectory = True
                        ElseIf Left(vFile, 1) = "l" Then
                            .FilePath = vComponents(10)
                            If Not CBool(InStr(InStrRev(vComponents(10), "/") + 1, vComponents(10), ".")) Then
                                .IsDirectory = True
                            End If
                        End If
                        .FileSize = vComponents(4)
                        .FileName = vComponents(8)
                        .LastWriteTime = GetDate(vComponents(6), vComponents(5), vComponents(7))
                        If Not (.FileName = "." Or .FileName = "..") Then
                            oFtpFiles.Add oFtpFile, oFtpFile.FileName
                        End If
                    End With
                Else
                    With oFtpFile
                        If vComponents(2) = "<DIR>" Then
                            .IsDirectory = True
                        Else
                            .FileSize = CLng(vComponents(2))
                        End If
                        If UBound(vComponents) > 3 Then
                            Dim strFile As String
                            For i = 3 To UBound(vComponents)
                               strFile = strFile & " " & vComponents(i)
                            Next i
                            strFile = Mid$(strFile, 2)
                        Else
                            strFile = vComponents(3)
                        End If
                        .FileName = strFile
                        .LastWriteTime = CDate(vComponents(0) & " " & vComponents(1))
                        oFtpFiles.Add oFtpFile, oFtpFile.FileName
                    End With
                End If
                Set oFtpFile = Nothing
            End If
        End If
        strFile = ""
    Next
    
    Set GetFileList = oFtpFiles
    Set oFtpFiles = Nothing
    
End Function

Private Function GetDate(vDay, vMonth, vYear) As Date

    vYear = IIf(InStr(1, vYear, ":"), Year(Now), vYear)
    
    Select Case vMonth
        Case "Jan": vMonth = 1
        Case "Feb": vMonth = 2
        Case "Mar": vMonth = 3
        Case "Apr": vMonth = 4
        Case "May": vMonth = 5
        Case "Jun": vMonth = 6
        Case "Jul": vMonth = 7
        Case "Aug": vMonth = 8
        Case "Sep": vMonth = 9
        Case "Oct": vMonth = 10
        Case "Nov": vMonth = 11
        Case "Dec": vMonth = 12
    End Select
    
    GetDate = DateSerial(CInt(vYear), CInt(vMonth), CInt(vDay))

End Function

Private Function ProcessPASVCommand() As Boolean

    Dim strResponse As String
    Dim strData     As String
    
    On Error GoTo ProcessPASVCommand_Err_Handler
    
    RaiseEvent StateChanged(FTP_ESTABLISHING_DATA_CONNECTION)

    wscControl.SendData "PASV" & vbCrLf
    Debug.Print "PASV"
    
    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_ENTERING_PASSIVE_MODE Then
        ProcessPASVCommand = MakePassiveDataConnection(strData)
    Else
        ProcessFtpResponse GetResponseCode(strData)
    End If

Exit_Label:
    Exit Function

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

End Function

Private Function MakePassiveDataConnection(sData As String) As Boolean
    '
    'Example of the string passed with sData argument
    '227 Entering Passive Mode (194,220,224,2,7,189)
    '
    Dim iPos            As Integer
    Dim iPos2           As Integer
    Dim strDataAddress  As String
    Dim strIP           As String
    Dim lPort           As Long
    '
    On Error GoTo MakePassiveDataConnection_Err_Handler
    '
    iPos = InStr(1, sData, "(") + 1
    If Not CBool(iPos) Then Exit Function
    strDataAddress = Mid$(sData, iPos, InStr(1, sData, ")") - iPos)
    strDataAddress = Replace(strDataAddress, ",", ".", 1, 3)
    iPos = InStr(1, strDataAddress, ",")
    strIP = Left$(strDataAddress, iPos - 1)
    lPort = CLng(Mid$(strDataAddress, iPos + 1, InStr(iPos + 1, strDataAddress, ",") - iPos))
    lPort = lPort * 256
    lPort = lPort + CLng(Mid$(strDataAddress, InStrRev(strDataAddress, ",") + 1))
    
    wscData.Close
    wscData.LocalPort = 0
    wscData.Connect strIP, lPort
    
    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
            MakePassiveDataConnection = True
            RaiseEvent StateChanged(FTP_DATA_CONNECTION_ESTABLISHED)
            Debug.Print "Connecting to: " & strIP & ":" & lPort
            Exit Do
        End If
    Loop
    m_objTimeOut.StopTimer
    
Exit_Label:
    Exit Function
    
MakePassiveDataConnection_Err_Handler:
    If Not ProcessWinsockError(Err.Number, Err.Description) Then
        Err.Raise vbObjectError + 1000 + Err.Number, "CFtpConnection.MakePassiveDataConnection", Err.Description
    End If
    GoTo Exit_Label
    
End Function

Public Function DownloadFile(strFileName As String, strLocalFileName As String, vTransferMode As FtpTransferModes, Optional lStartPoint As Long) As Boolean

    Dim bDataConnectionEstablished As Boolean
    
    m_bBusy = True
    
    If ProcessTYPECommand(vTransferMode) Then
        m_TransferMode = vTransferMode
    Else
        Exit Function
    End If
    
    If m_bPassiveMode Then
        bDataConnectionEstablished = ProcessPASVCommand
    Else
        bDataConnectionEstablished = ProcessPORTCommand
    End If
    
    If bDataConnectionEstablished Then
        If lStartPoint > 0 Then
            m_lDownloadedBytes = lStartPoint
            If Not ProcessRESTCommand(lStartPoint) Then
                'can't restart download
                DownloadFile = False
                Exit Function
            End If
        End If
        m_bTransferInProgress = True
        m_strLocalFilePath = strLocalFileName
        If ProcessRETRCommand(strFileName, 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 = sckClosed Or wscData.State = sckClosing Then
                    RaiseEvent StateChanged(FTP_TRANSFER_COMLETED)
                    'close file
                    Close #m_intLocalFileID
                    m_bFileIsOpened = False
                    m_bTransferInProgress = False
                    m_lDownloadedBytes = 0
                    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
    
    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
    
    m_objTimeOut.StartTimer
    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
                m_intLocalFileID = FreeFile
                Open m_strLocalFilePath For Binary As m_intLocalFileID
                If lStartPoint > 0 Then
                    Seek m_intLocalFileID, lStartPoint + 1
                End If
                'turn on flag m_bFileIsOpened
                m_bFileIsOpened = True
                'ignore 150 and 125 reply codes
                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)
    End If
    
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