VB写的FTP客户端程序
'********************************************************************************
'CFtpConnection类
'********************************************************************************
' 在该类里面使用了以下几个类和模块
' CFtpFile 类
' CFtpFiles 类
' CTimeout 类
' MFtpSupport 模块
'
' 同时在该类中使用到了winsock对象，因此在工程的REFERENCES中加入对该对象的引用
'********************************************************************************
'winsock对象的声明
'********************************************************************************
'声明进行控制连接的winsock对象
Private WithEvents wscControl As MSWinsockLib.Winsock
'声明进行数据连接的winsock对象
Private WithEvents wscData As MSWinsockLib.Winsock
'********************************************************************************
'定义类模块的内部属性变量
'********************************************************************************
Private m_strUserName As String '定义连接ftp服务器用户名
Private m_strPassword As String '定义连接ftp服务器密码
Private m_varFtpServer As Variant '定义连接ftp服务器地址
Private m_strCurrentDirectory As String '服务器当前工作目录
Private m_bPassiveMode As Boolean '定义连接模式
Private m_bBusy As Boolean '定义程序是否正在传输连接
Private m_intTimeout As Integer '定义连接超时限制
Private m_TransferMode As FtpTransferModes '定义传输模式
'********************************************************************************
'公共枚举变量
'********************************************************************************
'连接ftp服务器时的各种状态
Public Enum FTP_CONNECTION_STATES
FTP_CONNECTION_RESOLVING_HOST
FTP_CONNECTION_HOST_RESOLVED
FTP_CONNECTION_CONNECTED
FTP_CONNECTION_AUTHENTICATION
FTP_USER_LOGGED
FTP_ESTABLISHING_DATA_CONNECTION
FTP_DATA_CONNECTION_ESTABLISHED
FTP_RETRIEVING_DIRECTORY_INFO
FTP_DIRECTORY_INFO_COMPLETED
FTP_TRANSFER_STARTING
FTP_TRANSFER_COMLETED
End Enum
'ftp服务器各种返回的响应码
Private Enum FTP_RESPONSE_CODES
FTP_RESPONSE_RESTATRT_MARKER_REPLY = 110
FTP_RESPONSE_SERVICE_READY_IN_MINUTES = 120
FTP_RESPONSE_DATA_CONNECTION_ALREADY_OPEN = 125
FTP_RESPONSE_FILE_STATUS_OK = 150
FTP_RESPONSE_COMMAND_OK = 200
FTP_RESPONSE_COMMAND_NOT_IMPLEMENTED_SUPERFLUOUS_AT_THIS_SITE = 202 'superfluous at this site
FTP_RESPONSE_SYSTEM_STATUS_OR_SYSTEM_HELP_REPLY = 211
FTP_RESPONSE_DIRECTORY_STATUS = 212
FTP_RESPONSE_FILE_STATUS = 213
FTP_RESPONSE_HELP_MESSAGE = 214
FTP_RESPONSE_NAME_SYSTEM_TYPE = 215
FTP_RESPONSE_SERVICE_READY_FOR_NEW_USER = 220
FTP_RESPONSE_SERVICE_CLOSING_CONTROL_CONNECTION = 221
FTP_RESPONSE_DATA_CONNECTION_OPEN = 225
FTP_RESPONSE_CLOSING_DATA_CONNECTION = 226
FTP_RESPONSE_ENTERING_PASSIVE_MODE = 227
FTP_RESPONSE_USER_LOGGED_IN = 230
FTP_RESPONSE_REQUESTED_FILE_ACTION_OK_COMPLETED = 250
FTP_RESPONSE_PATHNAME_CREATED = 257
FTP_RESPONSE_USER_NAME_OK_NEED_PASSWORD = 331
FTP_RESPONSE_NEED_ACCOUNT_FOR_LOGIN = 332
FTP_RESPONSE_REQUESTED_FILE_ACTION_PENDING_FURTHER_INFO = 350
FTP_RESPONSE_SERVICE_NOT_AVAILABLE_CLOSING_CONTROL_CONNECTION = 421
FTP_RESPONSE_CANNOT_OPEN_DATA_CONNECTION = 425
FTP_RESPONSE_CONNECTION_CLOSED_TRANSFER_ABORTED = 426
FTP_RESPONSE_REQUESTED_FILE_ACTION_NOT_TAKEN = 450
FTP_RESPONSE_REQUESTED_ACTION_ABORTED = 451
FTP_RESPONSE_REQUESTED_ACTION_NOT_TAKEN = 452
FTP_RESPONSE_SYNTAX_ERROR_COMMAND_UNRECOGNIZED = 500
FTP_RESPONSE_SYNTAX_ERROR_IN_PARAMETERS_OR_ARGUMENTS = 501
FTP_RESPONSE_COMMAND_NOT_IMPLEMENTED = 502
FTP_RESPONSE_BAD_SEQUENCE_OF_COMMANDS = 503
FTP_RESPONSE_COMMAND_NOT_IMPLEMENTED_FOR_THAT_PARAMETER = 504
FTP_RESPONSE_NOT_LOGGED_IN = 530
FTP_RESPONSE_NEED_ACCOUNT_FOR_STORING_FILES = 532
FTP_RESPONSE_REQUESTED_ACTION_NOT_TAKEN_FILE_UNAVAILABLE = 550
FTP_RESPONSE_REQUESTED_ACTION_ABORTED_PAGE_TYPE_UNKNOWN = 551
FTP_RESPONSE_REQUESTED_FILE_ACTION_ABORTED_EXCEEDED_STORAGE_ALLOCATION = 552
FTP_RESPONSE_REQUESTED_ACTION_NOT_TAKEN_FILE_NAME_NOT_ALLOWED = 553
End Enum
'ftp传输模式
Public Enum FtpTransferModes
FTP_ASCII_MODE 'ASCII模式
FTP_IMAGE_MODE '二进制模式
End Enum
'********************************************************************************
'类错误
'********************************************************************************
Public Enum FtpErrors
ERROR_FTP_WINSOCK_AddressInUse
ERROR_FTP_WINSOCK_AddressNotAvailable
ERROR_FTP_WINSOCK_AlreadyComplete
ERROR_FTP_WINSOCK_AlreadyConnected
ERROR_FTP_WINSOCK_BadState
ERROR_FTP_WINSOCK_ConnectAborted
ERROR_FTP_WINSOCK_ConnectionRefused
ERROR_FTP_WINSOCK_ConnectionReset
ERROR_FTP_WINSOCK_GetNotSupported
ERROR_FTP_WINSOCK_HostNotFound
ERROR_FTP_WINSOCK_HostNotFoundTryAgain
ERROR_FTP_WINSOCK_InProgress
ERROR_FTP_WINSOCK_InvalidArg
ERROR_FTP_WINSOCK_InvalidArgument
ERROR_FTP_WINSOCK_InvalidOp
ERROR_FTP_WINSOCK_InvalidPropertyValue
ERROR_FTP_WINSOCK_MsgTooBig
ERROR_FTP_WINSOCK_NetReset
ERROR_FTP_WINSOCK_NetworkSubsystemFailed
ERROR_FTP_WINSOCK_NetworkUnreachable
ERROR_FTP_WINSOCK_NoBufferSpace
ERROR_FTP_WINSOCK_NoData
ERROR_FTP_WINSOCK_NonRecoverableError
ERROR_FTP_WINSOCK_NotConnected
ERROR_FTP_WINSOCK_NotInitialized
ERROR_FTP_WINSOCK_NotSocket
ERROR_FTP_WINSOCK_OpCanceled
ERROR_FTP_WINSOCK_OutOfMemory
ERROR_FTP_WINSOCK_OutOfRange
ERROR_FTP_WINSOCK_PortNotSupported
ERROR_FTP_WINSOCK_SetNotSupported
ERROR_FTP_WINSOCK_SocketShutdown
ERROR_FTP_WINSOCK_Success
ERROR_FTP_WINSOCK_Timedout
ERROR_FTP_WINSOCK_Unsupported
ERROR_FTP_WINSOCK_WouldBlock
ERROR_FTP_WINSOCK_WrongProtocol
ERROR_FTP_PROTOCOL_SERVICE_READY_IN_MINUTES
ERROR_FTP_PROTOCOL_USER_NAME_OK_NEED_PASSWORD
ERROR_FTP_PROTOCOL_NEED_ACCOUNT_FOR_LOGIN
ERROR_FTP_PROTOCOL_REQUESTED_FILE_ACTION_PENDING_FURTHER_INFO
ERROR_FTP_PROTOCOL_SERVICE_NOT_AVAILABLE_CLOSING_CONTROL_CONNECTION
ERROR_FTP_PROTOCOL_CANNOT_OPEN_DATA_CONNECTION
ERROR_FTP_PROTOCOL_CONNECTION_CLOSED_TRANSFER_ABORTED
ERROR_FTP_PROTOCOL_REQUESTED_FILE_ACTION_NOT_TAKEN
ERROR_FTP_PROTOCOL_REQUESTED_ACTION_ABORTED
ERROR_FTP_PROTOCOL_REQUESTED_ACTION_NOT_TAKEN
ERROR_FTP_PROTOCOL_SYNTAX_ERROR_COMMAND_UNRECOGNIZED
ERROR_FTP_PROTOCOL_SYNTAX_ERROR_IN_PARAMETERS_OR_ARGUMENTS
ERROR_FTP_PROTOCOL_COMMAND_NOT_IMPLEMENTED
ERROR_FTP_PROTOCOL_BAD_SEQUENCE_OF_COMMANDS
ERROR_FTP_PROTOCOL_COMMAND_NOT_IMPLEMENTED_FOR_THAT_PARAMETER
ERROR_FTP_PROTOCOL_NOT_LOGGED_IN
ERROR_FTP_PROTOCOL_NEED_ACCOUNT_FOR_STORING_FILES
ERROR_FTP_PROTOCOL_REQUESTED_ACTION_NOT_TAKEN_FILE_UNAVAILABLE
ERROR_FTP_PROTOCOL_REQUESTED_ACTION_ABORTED_PAGE_TYPE_UNKNOWN
ERROR_FTP_PROTOCOL_REQUESTED_FILE_ACTION_ABORTED_EXCEEDED_STORAGE_ALLOCATION
ERROR_FTP_PROTOCOL_REQUESTED_ACTION_NOT_TAKEN_FILE_NAME_NOT_ALLOWED
ERROR_FTP_USER_TIMEOUT
ERROR_FTP_USER_TRANSFER_IN_PROGRESS
End Enum
'********************************************************************************
'定义类事件
'********************************************************************************
Public Event StateChanged(State As FTP_CONNECTION_STATES)
Public Event DownloadProgress(lBytes As Long)
Public Event UploadProgress(lBytes As Long)
Public Event ReplyMessage(ByVal sMessage As String)
'********************************************************************************
'类模块内部的变量和常数
'********************************************************************************
Const RESPONSE_CODE_LENGHT = 3
Private m_LastError As FtpErrors
Private m_strLastErrorDesc As String
Private m_strWinsockBuffer As String
Private m_strDataBuffer As String
Private m_strLocalFilePath As String
Private m_intLocalFileID As Integer
Private m_bTransferInProgress As Boolean
Private m_lDownloadedBytes As Long
Private m_bUploadFile As Boolean
Private m_lUploadedBytes As Long
Private m_strLastServerResponse As String
Private m_objTimeOut As CTimeout
Private m_bFileIsOpened As Boolean
Public Function FtpGetLastError() As FtpErrors
'获得最近一次错误的函数
FtpGetLastError = m_LastError
End Function
Public Function CurrentDirectory() As String
'获得当前目录的函数
CurrentDirectory = m_strCurrentDirectory
End Function
Public Function GetLastServerResponse() As String
'获得最近一次服务器响应的函数
GetLastServerResponse = m_strLastServerResponse
End Function
Public Property Get TransferMode() As FtpTransferModes
'传输模式属性
TransferMode = m_TransferMode
End Property
Public Property Let TransferMode(NewValue As FtpTransferModes)
'改变传输模式属性
m_bBusy = True
If Not (NewValue = m_TransferMode) Then
If ProcessTYPECommand(NewValue) Then
m_TransferMode = NewValue
End If
End If
m_bBusy = False
End Property
Private Function ProcessLISTCommand() As Boolean
'********************************************************************************
'该函数的功能是向服务器发送LIST命令
'list的功能是获得指定目录中的字目录、文件列表或者是指定文件的信息
'modified by wxp
'Date 2000-11
'********************************************************************************
On Error GoTo ProcessLISTCommand_Err_Handler
Dim strResponse As String
Dim strData As String
wscControl.SendData "LIST" & vbCrLf
Debug.Print "LIST"
RaiseEvent ReplyMessage("LIST")
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
'忽略150返回码
m_strWinsockBuffer = Mid$(m_strWinsockBuffer, InStr(1, m_strWinsockBuffer, vbCrLf) 2)
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
ProcessLISTCommand = True
Else
ProcessFtpResponse GetResponseCode(strData)
End If
Exit_Label:
Exit Function
ProcessLISTCommand_Err_Handler:
If Not ProcessWinsockError(Err.Number, Err.Description) Then
Err.Raise vbObjectError 1000 Err.Number, "CFtpConnection.ProcessLISTCommand", Err.Description
End If
GoTo Exit_Label
End Function
Public Property Get PassiveMode() As Boolean
'获取连接模式属性
PassiveMode = m_bPassiveMode
End Property
Public Property Let PassiveMode(NewValue As Boolean)
'设置连接模式属性
m_bPassiveMode = NewValue
End Property
Public Function EnumFiles(oFiles As CFtpFiles) As Boolean
'********************************************************************************
'该函数的功能是获得当前目录下面的所有目录和文件
'modified by wxp
'Date 2000-10
'********************************************************************************
Dim bDataConnectionEstablished As Boolean
'On Error GoTo EnumFiles_Err_Handler
m_bBusy = True
If m_bPassiveMode Then
'如果是被动模式
bDataConnectionEstablished = ProcessPASVCommand
Else
'否则发送port命令
bDataConnectionEstablished = ProcessPORTCommand
End If
If bDataConnectionEstablished Then
RaiseEvent StateChanged(FTP_RETRIEVING_DIRECTORY_INFO)
If ProcessLISTCommand Then
m_objTimeOut.StartTimer
Do
DoEvents
'如果超时
If m_objTimeOut.Timeout Then
m_LastError = ERROR_FTP_USER_TIMEOUT
'如果已经从服务器获得全部信息
If GetResponseCode(Left(m_strLastServerResponse, 3)) = FTP_RESPONSE_CLOSING_DATA_CONNECTION Then
Set oFiles = GetFileList(m_strDataBuffer)
EnumFiles = True
RaiseEvent StateChanged(FTP_DIRECTORY_INFO_COMPLETED)
m_strDataBuffer = ""
End If
Exit Do
End If
'如果已经关闭连接，表示也已经成功得到信息
If wscData.State = sckClosing Or wscData.State = sckClosed Then
Set oFiles = Nothing
Set oFiles = GetFileList(m_strDataBuffer)
EnumFiles = True
RaiseEvent StateChanged(FTP_DIRECTORY_INFO_COMPLETED)
m_strDataBuffer = ""
Exit Do
End If
Loop
m_objTimeOut.StopTimer
Else
'产生错误，不能建立连接
End If
Else
'产生错误，不能建立连接
End If
Exit_Label:
m_bBusy = False
Exit Function
EnumFiles_Err_Handler:
Err.Raise vbObjectError 1000 Err.Number, "CFtpConnection.EnumFiles", Err.Description
GoTo Exit_Label
End Function
Public Function SetCurrentDirectory(strNewDirectory As String) As Boolean
'设置当前目录
m_bBusy = True
SetCurrentDirectory = ProcessCWDCommand(strNewDirectory)
m_bBusy = False
End Function
Public Property Get FtpServer() As Variant
'获得服务器地址属性
FtpServer = m_varFtpServer
End Property
Public Property Let FtpServer(NewValue As Variant)
'设定服务器地址属性
m_varFtpServer = NewValue
End Property
Public Property Get Password() As String
'获得密码属性
Password = m_strPassword
End Property
Public Property Let Password(NewValue As String)
'设置密码属性
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 = "guest@unknown.com"
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
'
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)
'如果采用port方式接受或者发送数据，该事件接受对方的连接
If wscData.State <> sckClosed Then wscData.Close
wscData.Accept (requestID)
End Sub
Private Sub wscData_DataArrival(ByVal bytesTotal As Long)
'wscData的DataArrival事件，同时得到服务器传来的数据
'该变量用来获得字符型的数据
Dim strData As String
'该变量用来获得从服务器上传来的二进制数据
Dim temparray() As Byte
On Error Resume Next
'如果传来的数据数为0，则退出该事件
If bytesTotal = 0 Then Exit Sub
'如果正在进行文件传输，主要是下载文件
If m_bTransferInProgress Then
'定义数组的大小为实际从服务器传来数据量的大小
ReDim temparray(bytesTotal)
wscData.GetData temparray(), vbByte
Else
'否则将数据存在字符型变量中
wscData.GetData strData
End If
'如果是文件传输而且不是上载
If m_bTransferInProgress And Not m_bUploadFile Then
'如果文件没有打开，则需要打开文件
If Not m_bFileIsOpened Then
'获得一个自由的文件号
m_intLocalFileID = FreeFile
'以二进制文件打开文件
Open m_strLocalFilePath For Binary As m_intLocalFileID
'标志文件已经打开
m_bFileIsOpened = True
'初始化下载字节数为0
m_lDownloadedBytes = 0
End If
'将数据写到文件中
Put m_intLocalFileID, , temparray
m_lDownloadedBytes = m_lDownloadedBytes bytesTotal
RaiseEvent DownloadProgress(m_lDownloadedBytes)
Else
'如果不是传输文件，则把信息加入缓冲区m_strDataBuffer
m_strDataBuffer = m_strDataBuffer & strData
End If
'计时器清0
m_objTimeOut.Reset
Exit Sub
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
'传来的数据项之间都是用回车换行符隔开的，所以通过split函数分出来
vFiles = Split(strListing, vbCrLf)
'
For Each vFile In vFiles
Set oFtpFile = New CFtpFile
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
.Permissions = vComponents(0)
.Owner = vComponents(2)
.Group = vComponents(3)
.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
Debug.Print "vComponents(2): " & vComponents(2), "vComponents(3): " & vComponents(3)
.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"
RaiseEvent ReplyMessage("PASV" & 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_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
'该函数是建立被动模式数据连接
'
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
RaiseEvent ReplyMessage("Connecting to: " & strIP & ":" & lPort & vbCrLf)
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 'Left(strLocalFileName, InStrRev(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 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
'该函数的命令是向服务器发送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 Not 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
'modify by xmxoxo 2007.9.25 及时关闭
If m_bFileIsOpened Then
Close #m_intLocalFileID
End If
Debug.Print GetResponseCode(strData)
Exit_Label:
Exit Function
ProcessRETRCommand_Err_Handler:
If Not ProcessWinsockError(Err.Number, Err.Description) Then
Err.Clear
'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
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_WINSOCK_AlreadyConnected
Case sckBadState
m_LastError = ERROR_FTP_WINSOCK_BadState
Case sckConnectAborted
m_LastError = ERROR_FTP_WINSOCK_ConnectAborted
Case sckConnectionRefused
m_LastError = ERROR_FTP_WINSOCK_ConnectionRefused
Case sckConnectionReset
m_LastError = ERROR_FTP_WINSOCK_ConnectionReset
Case sckGetNotSupported
m_LastError = ERROR_FTP_WINSOCK_GetNotSupported
Case sckHostNotFound
m_LastError = ERROR_FTP_WINSOCK_HostNotFound
Case sckHostNotFoundTryAgain
m_LastError = ERROR_FTP_WINSOCK_HostNotFoundTryAgain
Case sckInProgress
m_LastError = ERROR_FTP_WINSOCK_InProgress
Case sckInvalidArg
m_LastError = ERROR_FTP_WINSOCK_InvalidArg
Case sckInvalidArgument
m_LastError = ERROR_FTP_WINSOCK_InvalidArgument
Case sckInvalidOp
m_LastError = ERROR_FTP_WINSOCK_InvalidOp
Case sckInvalidPropertyValue
m_LastError = ERROR_FTP_WINSOCK_InvalidPropertyValue
Case sckMsgTooBig
m_LastError = ERROR_FTP_WINSOCK_MsgTooBig
Case sckNetReset
m_LastError = ERROR_FTP_WINSOCK_NetReset
Case sckNetworkSubsystemFailed
m_LastError = ERROR_FTP_WINSOCK_NetworkSubsystemFailed
Case sckNetworkUnreachable
m_LastError = ERROR_FTP_WINSOCK_NetworkUnreachable
Case sckNoBufferSpace
m_LastError = ERROR_FTP_WINSOCK_NoBufferSpace
Case sckNoData
m_LastError = ERROR_FTP_WINSOCK_NoData
Case sckNonRecoverableError
m_LastError = ERROR_FTP_WINSOCK_NonRecoverableError
Case sckNotConnected
m_LastError = ERROR_FTP_WINSOCK_NotConnected
Case sckNotInitialized
m_LastError = ERROR_FTP_WINSOCK_NotInitialized
Case sckNotSocket
m_LastError = ERROR_FTP_WINSOCK_NotSocket
Case sckOpCanceled
m_LastError = ERROR_FTP_WINSOCK_OpCanceled
Case sckOutOfMemory
m_LastError = ERROR_FTP_WINSOCK_OutOfMemory
Case sckOutOfRange
m_LastError = ERROR_FTP_WINSOCK_OutOfRange
Case sckPortNotSupported
m_LastError = ERROR_FTP_WINSOCK_PortNotSupported
Case sckSetNotSupported
m_LastError = ERROR_FTP_WINSOCK_SetNotSupported
Case sckSocketShutdown
m_LastError = ERROR_FTP_WINSOCK_SocketShutdown
Case sckSuccess
m_LastError = ERROR_FTP_WINSOCK_Success
Case sckTimedout
m_LastError = ERROR_FTP_WINSOCK_Timedout
Case sckUnsupported
m_LastError = ERROR_FTP_WINSOCK_Unsupported
Case sckWouldBlock
m_LastError = ERROR_FTP_WINSOCK_WouldBlock
Case sckWrongProtocol
m_LastError = ERROR_FTP_WINSOCK_WrongProtocol
Case Else
ProcessWinsockError = False
Exit Function
End Select
ProcessWinsockError = True
End Function
Private Function ProcessFtpResponse(intCode As FTP_RESPONSE_CODES) As Boolean
'该函数的功能是对各种响应码进行分析
Select Case intCode
Case FTP_RESPONSE_RESTATRT_MARKER_REPLY
Case FTP_RESPONSE_SERVICE_READY_IN_MINUTES
Case FTP_RESPONSE_DATA_CONNECTION_ALREADY_OPEN
Case FTP_RESPONSE_FILE_STATUS_OK
Case FTP_RESPONSE_COMMAND_OK
Case FTP_RESPONSE_COMMAND_NOT_IMPLEMENTED_SUPERFLUOUS_AT_THIS_SITE
Case FTP_RESPONSE_SYSTEM_STATUS_OR_SYSTEM_HELP_REPLY
Case FTP_RESPONSE_DIRECTORY_STATUS
Case FTP_RESPONSE_FILE_STATUS
Case FTP_RESPONSE_HELP_MESSAGE
Case FTP_RESPONSE_NAME_SYSTEM_TYPE
Case FTP_RESPONSE_SERVICE_READY_FOR_NEW_USER
Case FTP_RESPONSE_SERVICE_CLOSING_CONTROL_CONNECTION
Case FTP_RESPONSE_DATA_CONNECTION_OPEN
Case FTP_RESPONSE_CLOSING_DATA_CONNECTION
Case FTP_RESPONSE_ENTERING_PASSIVE_MODE
Case FTP_RESPONSE_USER_LOGGED_IN
Case FTP_RESPONSE_REQUESTED_FILE_ACTION_OK_COMPLETED
Case FTP_RESPONSE_PATHNAME_CREATED
Case FTP_RESPONSE_USER_NAME_OK_NEED_PASSWORD
m_LastError = ERROR_FTP_PROTOCOL_USER_NAME_OK_NEED_PASSWORD
Case FTP_RESPONSE_NEED_ACCOUNT_FOR_LOGIN
m_LastError = ERROR_FTP_PROTOCOL_NEED_ACCOUNT_FOR_LOGIN
Case FTP_RESPONSE_REQUESTED_FILE_ACTION_PENDING_FURTHER_INFO
m_LastError = ERROR_FTP_PROTOCOL_REQUESTED_FILE_ACTION_PENDING_FURTHER_INFO
Case FTP_RESPONSE_SERVICE_NOT_AVAILABLE_CLOSING_CONTROL_CONNECTION
m_LastError = ERROR_FTP_PROTOCOL_SERVICE_NOT_AVAILABLE_CLOSING_CONTROL_CONNECTION
m_strLastErrorDesc = "Service not available, closing control connection."
Case FTP_RESPONSE_CANNOT_OPEN_DATA_CONNECTION
m_strLastErrorDesc = "Can't open data connection."
m_LastError = ERROR_FTP_PROTOCOL_CANNOT_OPEN_DATA_CONNECTION
Case FTP_RESPONSE_CONNECTION_CLOSED_TRANSFER_ABORTED
m_strLastErrorDesc = "Connection closed; transfer aborted."
m_LastError = ERROR_FTP_PROTOCOL_CONNECTION_CLOSED_TRANSFER_ABORTED
Case FTP_RESPONSE_REQUESTED_FILE_ACTION_NOT_TAKEN
m_strLastErrorDesc = "Requested file action not taken."
m_LastError = ERROR_FTP_PROTOCOL_REQUESTED_ACTION_NOT_TAKEN
Case FTP_RESPONSE_REQUESTED_ACTION_ABORTED
m_strLastErrorDesc = "Requested action aborted: local error in processing."
m_LastError = ERROR_FTP_PROTOCOL_REQUESTED_ACTION_ABORTED
Case FTP_RESPONSE_REQUESTED_ACTION_NOT_TAKEN
m_LastError = ERROR_FTP_PROTOCOL_REQUESTED_ACTION_NOT_TAKEN
m_strLastErrorDesc = "Requested action not taken. Insufficient storage space in system."
Case FTP_RESPONSE_SYNTAX_ERROR_COMMAND_UNRECOGNIZED
m_strLastErrorDesc = "Syntax error, command unrecognized."
m_LastError = ERROR_FTP_PROTOCOL_SYNTAX_ERROR_COMMAND_UNRECOGNIZED
Case FTP_RESPONSE_SYNTAX_ERROR_IN_PARAMETERS_OR_ARGUMENTS
m_strLastErrorDesc = "Syntax error in parameters or arguments."
m_LastError = ERROR_FTP_PROTOCOL_SYNTAX_ERROR_IN_PARAMETERS_OR_ARGUMENTS
Case FTP_RESPONSE_COMMAND_NOT_IMPLEMENTED
m_strLastErrorDesc = "Command not implemented."
m_LastError = ERROR_FTP_PROTOCOL_COMMAND_NOT_IMPLEMENTED
Case FTP_RESPONSE_BAD_SEQUENCE_OF_COMMANDS
m_strLastErrorDesc = "Bad sequence of commands."
m_LastError = ERROR_FTP_PROTOCOL_BAD_SEQUENCE_OF_COMMANDS
Case FTP_RESPONSE_COMMAND_NOT_IMPLEMENTED_FOR_THAT_PARAMETER
m_strLastErrorDesc = "Command not implemented for that parameter."
m_LastError = ERROR_FTP_PROTOCOL_COMMAND_NOT_IMPLEMENTED_FOR_THAT_PARAMETER
Case FTP_RESPONSE_NOT_LOGGED_IN
m_strLastErrorDesc = "Not logged in."
m_LastError = ERROR_FTP_PROTOCOL_NOT_LOGGED_IN
Case FTP_RESPONSE_NEED_ACCOUNT_FOR_STORING_FILES
m_strLastErrorDesc = "Need account for storing files."
m_LastError = ERROR_FTP_PROTOCOL_NEED_ACCOUNT_FOR_STORING_FILES
Case FTP_RESPONSE_REQUESTED_ACTION_NOT_TAKEN_FILE_UNAVAILABLE
m_strLastErrorDesc = "Requested action not taken. File unavailable (e.g., file not found, no access)."
m_LastError = ERROR_FTP_PROTOCOL_REQUESTED_ACTION_NOT_TAKEN_FILE_UNAVAILABLE
Case FTP_RESPONSE_REQUESTED_ACTION_ABORTED_PAGE_TYPE_UNKNOWN
m_strLastErrorDesc = "Requested action aborted: page type unknown."
m_LastError = ERROR_FTP_PROTOCOL_REQUESTED_ACTION_ABORTED_PAGE_TYPE_UNKNOWN
Case FTP_RESPONSE_REQUESTED_FILE_ACTION_ABORTED_EXCEEDED_STORAGE_ALLOCATION
m_strLastErrorDesc = "Requested file action aborted. Exceeded storage allocation (for current directory or dataset)."
m_LastError = ERROR_FTP_PROTOCOL_REQUESTED_FILE_ACTION_ABORTED_EXCEEDED_STORAGE_ALLOCATION
Case FTP_RESPONSE_REQUESTED_ACTION_NOT_TAKEN_FILE_NAME_NOT_ALLOWED
m_strLastErrorDesc = "Requested action not taken. File name not allowed."
m_LastError = ERROR_FTP_PROTOCOL_REQUESTED_ACTION_NOT_TAKEN_FILE_NAME_NOT_ALLOWED
Case Else
ProcessFtpResponse = False
Exit Function
End Select
ProcessFtpResponse = True
End Function
Public Function GetCurrentDirectory() As String
m_bBusy = True
If ProcessPWDCommand Then
GetCurrentDirectory = m_strCurrentDirectory
End If
m_bBusy = False
End Function
Private Function ProcessQUITCommand() As Boolean
'该函数的功能是向服务器发送quit命令，终止连接、注销用户
Dim strResponse As String
Dim strData As String
On Error GoTo ProcessQUITCommand_Err_Handler
wscControl.SendData "QUIT" & vbCrLf
Debug.Print "QUIT"
RaiseEvent ReplyMessage("QUIT" & 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_SERVICE_CLOSING_CONTROL_CONNECTION Then
ProcessQUITCommand = True
Else
ProcessFtpResponse GetResponseCode(strData)
End If
Exit_Label:
Exit Function
ProcessQUITCommand_Err_Handler:
If Not ProcessWinsockError(Err.Number, Err.Description) Then
Err.Raise vbObjectError 1000 Err.Number, "CFtpConnection.ProcessQUITCommand", Err.Description
End If
GoTo Exit_Label
End Function
Private Function ProcessABORCommand() As Boolean
'该函数的功能是终止上一次ftp服务器命令及相关数据传输
Dim strResponse As String
Dim strData As String
On Error GoTo ProcessABORCommand_Err_Handler
wscControl.SendData "ABOR" & vbCrLf
Debug.Print "ABOR"
RaiseEvent ReplyMessage("ABOR" & 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 = "226" & vbCrLf
Exit Do
End If
Loop
m_objTimeOut.StopTimer
If GetResponseCode(strData) = 426 Then
ProcessABORCommand = True
Else
ProcessFtpResponse GetResponseCode(strData)
End If
Exit_Label:
Exit Function
ProcessABORCommand_Err_Handler:
If Not ProcessWinsockError(Err.Number, Err.Description) Then
Err.Raise vbObjectError 1000 Err.Number, "CFtpConnection.ProcessABORCommand", Err.Description
End If
GoTo Exit_Label
End Function
Public Function CancelTransfer() As Boolean
m_bBusy = True
If ProcessABORCommand Then
CancelTransfer = True
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_objTimeOut.StopTimer
' wscData.Close
m_bBusy = False
End Function
Public Function SetParentAsCurrentDirectory() As Boolean
m_bBusy = True
SetParentAsCurrentDirectory = ProcessCDUPCommand
m_bBusy = False
End Function
Private Function ProcessCDUPCommand() As Boolean
'该函数的功能是把当前目录改为远程文件系统的根目录而无需改变登录、帐号信息或传输参数
Dim strResponse As String
Dim strData As String
On Error GoTo ProcessCDUPCommand_Err_Handler
wscControl.SendData "CDUP" & vbCrLf
Debug.Print "CDUP"
RaiseEvent ReplyMessage("CDUP" & 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
ProcessCDUPCommand = True
Else
ProcessFtpResponse GetResponseCode(strData)
End If
Exit_Label:
Exit Function
ProcessCDUPCommand_Err_Handler:
If Not ProcessWinsockError(Err.Number, Err.Description) Then
Err.Raise vbObjectError 1000 Err.Number, "CFtpConnection.ProcessCDUPCommand", Err.Description
End If
GoTo Exit_Label
End Function
Private Function ProcessCWDCommand(strNewDir As String) As Boolean
'该函数的功能是改变当前目录为指定的目录
Dim strResponse As String
Dim strData As String
On Error GoTo ProcessCWDCommand_Err_Handler
wscControl.SendData "CWD " & strNewDir & vbCrLf
Debug.Print "CWD " & strNewDir
RaiseEvent ReplyMessage("CWD " & strNewDir & 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
ProcessCWDCommand = True
Else
ProcessFtpResponse GetResponseCode(strData)
End If
Exit_Label:
Exit Function
ProcessCWDCommand_Err_Handler:
If Not ProcessWinsockError(Err.Number, Err.Description) Then
Err.Raise vbObjectError 1000 Err.Number, "CFtpConnection.ProcessCWDCommand", Err.Description
End If
GoTo Exit_Label
End Function
Public Function GetFtpErrorDescription() As String
GetFtpErrorDescription = m_strLastErrorDesc
End Function
Public Function CloseConnection() As Boolean
m_bBusy = True
If m_bTransferInProgress Or m_bUploadFile Then
m_LastError = ERROR_FTP_USER_TRANSFER_IN_PROGRESS
m_strLastErrorDesc = "Can't close control connection. Transfer in progress."
Else
CloseConnection = ProcessQUITCommand
wscData.Close
wscControl.Close
End If
m_bBusy = False
End Function
评论