cftpconnection.cls

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

    m_strPassword = NewValue
End Property

Public Property Get UserName() As String
'获得用户名属性
    UserName = m_strUserName
End Property

Public Property Let UserName(NewValue As String)
'设置用户名属性
    m_strUserName = NewValue
End Property

Public Function Connect() As Boolean
'********************************************************************************
'该函数的功能是连接ftp服务器
'modified by wxp
'Date   2000-11
'********************************************************************************

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
                    '如果是220，表示服务已经为新用户准备好
                        Select Case ProcessUSERCommand
                            Case FTP_RESPONSE_USER_LOGGED_IN
                             '如果为230，表示登录成功
                               Connect = True
                            Case FTP_RESPONSE_USER_NAME_OK_NEED_PASSWORD
                            '如果是需要密码验证，则下一步进行密码验证
                                If ProcessPASSCommand = FTP_RESPONSE_USER_LOGGED_IN Then
                                    Connect = True
                                End If
                        End Select
                        If Connect Then
                        '如果登陆成功，则获得当前工作目录
                            Call ProcessPWDCommand
                        End If
                    Case FTP_RESPONSE_SERVICE_READY_IN_MINUTES
                    '如果是120，表示服务器将在nnn分钟后准备好
                        m_LastError = ERROR_FTP_PROTOCOL_SERVICE_READY_IN_MINUTES
                    Case FTP_RESPONSE_SERVICE_NOT_AVAILABLE_CLOSING_CONTROL_CONNECTION
                    '如果是421表示服务不可用，关闭连接
                        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
    '产生错误
    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
            '产生错误，退出该函数
            'Exit Function
        End If
    End If
    '发送用户名
    wscControl.SendData "USER " & m_strUserName & vbCrLf
    Debug.Print "USER " & m_strUserName
    RaiseEvent ReplyMessage("USER " & m_strUserName & vbCrLf)
    
    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)
        '如果是230，表示用户登录成功，继续
        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
    RaiseEvent ReplyMessage("PASS " & "**********" & vbCrLf)
    
    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"
    RaiseEvent ReplyMessage("PWD" & 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
    '如果响应码为257，表示已经创建"PATHNAME"
        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
            '未知的响应格式
        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
'该事件为winsock对象的事件，用来获得从服务器端的数据,该控件主要是发送命令和接收返回码
Private Sub wscControl_DataArrival(ByVal bytesTotal As Long)
    On Error Resume Next
    Dim strData As String
    
    wscControl.GetData strData
    m_strWinsockBuffer = m_strWinsockBuffer & strData
    m_strLastServerResponse = strData
    '每次接收到数据的时候，计时器标记清0
    m_objTimeOut.Reset
    
    '返回码为426表示连接关闭,传输终止
    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)
    RaiseEvent ReplyMessage(Left(strData, Len(strData) - 2) & vbCrLf)
    
End Sub

Private Function ProcessPORTCommand() As Boolean
'该函数的功能是发送port命令，为数据连接指定一个ip地址和本地地址
    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
    '向服务器发送port命令
    Debug.Print Left(strSend, Len(strSend) - 2)
    RaiseEvent ReplyMessage(Left(strSend, Len(strSend) - 2) & vbCrLf)
    
    m_objTimeOut.StartTimer
    Do
        DoEvents
        '
        If m_objTimeOut.Timeout Then
            m_LastError = ERROR_FTP_USER_TIMEOUT
            Exit Do
        End If
        '