VB FTP操作类(可上传、下载、创建文件夹等等)

可实现FTP上传下载,建文件夹等功能,从网上找了一个类,对其进行修改和功能补充,正常使用,非常方便.

切记在使用FtpFindFirstFile 函数查找相应的文件或文件夹后,要使用InternetCloseHandle关闭查找的句柄,否则再次查找的话,会查找不到任何信息.

代码另存为FTP.cls 代码

Option Explicit
'Copyright Graham Daly December 2001

' ---------------------------------------------------------
' ------------------- API Functions --------------------
' ---------------------------------------------------------

'File time information
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type

'File information
Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * 260
cAlternate As String * 14
End Type

'Wininet.dll API's
Private Declare Function FtpFindFirstFile& Lib "wininet.dll" _
Alias "FtpFindFirstFileA" _
(ByVal hOutboundSession&, _
ByVal lpszSearchFile$, _
lpFindFileData As WIN32_FIND_DATA, _
ByVal dwFlags&, _
ByVal dwContent&)

Private Declare Function InternetFindNextFile& Lib "wininet.dll" _
Alias "InternetFindNextFileA" _
(ByVal hFind&, _
lpvFindData As WIN32_FIND_DATA)

Private Declare Function FtpGetFile Lib "wininet.dll" _
Alias "FtpGetFileA" _
(ByVal hOutboundSession&, _
ByVal lpszRemoteFile$, _
ByVal lpszNewFile$, _
ByVal fFailIfExists As Boolean, _
ByVal dwFlagsAndAttributes&, _
ByVal dwFlags&, _
ByVal dwContext&) As Boolean

Private Declare Function FtpPutFile Lib "wininet.dll" _
Alias "FtpPutFileA" _
(ByVal hOutboundSession&, _
ByVal lpszLocalFile$, _
ByVal lpszRemoteFile$, _
ByVal dwFlags&, _
ByVal dwContext&) As Boolean

Private Declare Function FtpRenameFile Lib "wininet.dll" _
Alias "FtpRenameFileA" _
(ByVal hOutboundSession&, _
ByVal sExistingName$, _
ByVal sNewName$) As Boolean

Private Declare Function FtpDeleteFile Lib "wininet.dll" _
Alias "FtpDeleteFileA" _
(ByVal hOutboundSession&, _
ByVal lpszFileName$) As Boolean

Private Declare Function FtpGetCurrentDirectory& Lib "wininet.dll" _
Alias "FtpGetCurrentDirectoryA" _
(ByVal hConnect&, _
ByVal lpszCurrentDirectory$, _
lpdwCurrentDirectory&)

Private Declare Function FtpSetCurrentDirectory Lib "wininet.dll" _
Alias "FtpSetCurrentDirectoryA" _
(ByVal hOutboundSession&, _
ByVal lpszDirectory$) As Boolean

Private Declare Function InternetConnect& Lib "wininet.dll" _
Alias "InternetConnectA" _
(ByVal hInternetSession&, _
ByVal sServerName$, _
ByVal nServerPort%, _
ByVal sUsername$, _
ByVal sPassword$, _
ByVal lService&, _
ByVal lFlags&, _
ByVal lContext&)

Private Declare Function FtpCreateDirectory Lib "wininet.dll" _
Alias "FtpCreateDirectoryA" _
(ByVal hFtpSession&, _
ByVal lpszDirectory$) As Boolean

Private Declare Function InternetOpen& Lib "wininet.dll" _
Alias "InternetOpenA" _
(ByVal sAgent$, _
ByVal lAccessType&, _
ByVal sProxyName$, _
ByVal sProxyBypass$, _
ByVal lFlags&)

Private Declare Function InternetCloseHandle& Lib "wininet.dll" _
(ByVal hInet&)

Private Declare Function InternetGetLastResponseInfo Lib "wininet.dll" _
Alias "InternetGetLastResponseInfoA" _
(lpdwError&, _
ByVal lpszBuffer$, _
lpdwBufferLength&) As Boolean

' ---------------------------------------------------------
' ---------------- Module-level Constants -----------------
' ---------------------------------------------------------

Private Const FAILURE& = 0
Private Const SUCCESS& = 1

'Error messages
Private Const ERR_CHANGE_DIR$ = "Cannot change directory to <%s>. It either doesn't exist, or is protected"
Private Const ERR_CONNECT_ERROR$ = "Cannot connect to FTP server <%s> using User and Password Parameters"
Private Const ERR_ALREADY_CONNECTED$ = "Cannot change property while connected to FTP server"
Private Const ERR_NO_CONNECTION$ = "Cannot connect to FTP server"
Private Const ERR_DOWNLOAD$ = "Cannot get file <%s> from FTP server"
Private Const ERR_RENAME$ = "Cannot rename file <%s>"
Private Const ERR_DELETE$ = "Cannot delete file <%s> from FTP server"
Private Const ERR_CRITICAL$ = "Cannot get connection to WinInet.dll!"
Private Const ERR_CREATEDIRECOTRY$ = "Cannot CreateDirectory <%s> to FTP server"

'Type of service to access
Private Const INTERNET_SERVICE_FTP = 1

'Flags
Private Const INTERNET_FLAG_RELOAD = &H80000000
Private Const INTERNET_FLAG_KEEP_CONNECTION = &H400000
Private Const INTERNET_FLAG_MULTIPART = &H200000
Private Const INTERNET_FLAG_PASSIVE = &H8000000
Private Const INTERNET_FLAG_NO_CACHE_WRITE = &H4000000
Private Const INTERNET_FLAG_EXISTING_CONNECT = &H20000000

'File Transfer modes
Private Const FTP_TRANSFER_TYPE_UNKNOWN = &H0
Private Const FTP_TRANSFER_TYPE_ASCII = &H1
Private Const FTP_TRANSFER_TYPE_BINARY = &H2

'Other
Private Const INTERNET_OPEN_TYPE_DIRECT = 1
Private Const INET_SESSION_NAME$ = "ICB FTP Sesh"
Private Const ERROR_INTERNET_EXTENDED_ERROR = 12003
Private Const NO_CONNECTION& = FAILURE&
Private Const FWDSLASH$ = "/"
Private Const BACKSLASH$ = "\"

' ---------------------------------------------------------
' ---------------- Module-level Variables -----------------
' ---------------------------------------------------------

'Our INET handle
Private m_hInet&

'Our FTP connection Handle
Private m_hSession&

'Standard FTP properties
Private m_HostAddr$
Private m_HostPort&
Private m_User$
Private m_Password$
Private m_Dir$

' ---------------------------------------------------------
' ------------------ User-defined Types -------------------
' ---------------------------------------------------------

Public Enum FtpError
ERR_CANNOT_CONNECT = vbObjectError + 2001
ERR_NO_DIR_CHANGE = vbObjectError + 2002
ERR_CANNOT_RENAME = vbObjectError + 2003
ERR_CANNOT_DELETE = vbObjectError + 2004
ERR_NOT_CONNECTED_TO_SITE = vbObjectError + 2005
ERR_CANNOT_GET_FILE = vbObjectError + 2006
ERR_INVALID_PROPERTY = vbObjectError + 2007
ERR_FATAL = vbObjectError + 2008
ERR_CANNNOT_CREATEDIRECTORY = vbObjectError + 2009
End Enum

'File Transfer types
Public Enum FileTransferType
fttUnknown = FTP_TRANSFER_TYPE_UNKNOWN
fttAscii = FTP_TRANSFER_TYPE_ASCII
fttBinary = FTP_TRANSFER_TYPE_BINARY
End Enum
'________________________________________________________________________

Private Sub Class_Initialize()

'Initialise variables
m_hSession& = NO_CONNECTION&
m_hInet& = NO_CONNECTION&
m_HostAddr$ = vbNullString
m_HostPort& = FAILURE&
m_User$ = vbNullString
m_Password$ = vbNullString
m_Dir$ = vbNullString

End Sub
'________________________________________________________________________

Private Sub Class_Terminate()

'Kill off connection
If m_hSession& Then InternetCloseHandle m_hSession&

'Kill off API Handle
If m_hInet& Then InternetCloseHandle m_hInet&

m_hSession& = NO_CONNECTION&
m_hInet& = NO_CONNECTION&

End Sub
'________________________________________________________________________

' ---------------------------------------------------------
' ------------------- Class Properties --------------------
' ---------------------------------------------------------

Public Property Let Host(ByVal HostAddr$)
'Set the host address - only if un-connected

If m_hSession& = NO_CONNECTION& Then
m_HostAddr$ = HostAddr$
Else
Err.Raise ERR_INVALID_PROPERTY, "clsFTP:Host [Let]", ERR_ALREADY_CONNECTED$
End If

End Property
'________________________________________________________________________

Public Property Get Host$()
'Get host address

Host = m_HostAddr$

End Property
'________________________________________________________________________

Public Property Let Port(ByVal HostPort&)
'Set the host port - only if un-connected

If m_hSession& = NO_CONNECTION& Then
m_HostPort& = HostPort&
Else
Err.Raise ERR_INVALID_PROPERTY, "clsFTP:Port [Let]", ERR_ALREADY_CONNECTED$
End If

End Property
'________________________________________________________________________

Public Property Get Port&()
'Get host port

Port& = m_HostPort&

End Property
'________________________________________________________________________

Public Property Let User(ByVal UserName$)
'Set the user - only if un-connected

If m_hSession& = NO_CONNECTION& Then
m_User$ = UserName$
Else
Err.Raise ERR_INVALID_PROPERTY, "clsFTP:User [Let]", ERR_ALREADY_CONNECTED$
End If

End Property
'________________________________________________________________________

Public Property Get User$()
'Get user

User$ = m_User$

End Property
'________________________________________________________________________

Public Property Let Password(ByVal Pwd$)
'Set the password - only if un-connected

If m_hSession& = NO_CONNECTION& Then
m_Password$ = Pwd$
Else
Err.Raise ERR_INVALID_PROPERTY, "clsFTP:Password [Let]", ERR_ALREADY_CONNECTED$
End If

End Property
'________________________________________________________________________

Public Property Get Password$()
'Get the password

Password = m_Password$

End Property
'________________________________________________________________________

Public Property Get Directory$()
'Get directory
Dim TempDir$

If (GetDirName&(TempDir$) <> SUCCESS&) Then
TempDir$ = ""
End If

Directory$ = TempDir$

End Property
'________________________________________________________________________

Public Property Let Directory(ByVal Folder$)
'Set the directory - only if connected

If m_hSession& = NO_CONNECTION& Then
Err.Raise ERR_NOT_CONNECTED_TO_SITE, "clsFTP:Directory [Let]", ERR_NO_CONNECTION$
Else
ChangeDir Folder$
End If

End Property
'________________________________________________________________________

Public Property Get IsConnected() As Boolean
'Are we connected? Read-only
Dim Temp$

IsConnected = (GetDirName&(Temp$) = SUCCESS&)

End Property
'________________________________________________________________________

' ---------------------------------------------------------
' --------------- Exposed Class Methods -------------------
' ---------------------------------------------------------

Public Function Connect&( _
Optional ByVal Host$ = vbNullString, _
Optional ByVal Port& = 0, _
Optional ByVal User$ = vbNullString, _
Optional ByVal Password$ = vbNullString)

'Attempt to connect to FTP server
On Local Error GoTo Handler
Dim ErrMsg$

Connect& = FAILURE&

If m_hInet& = FAILURE& Then
'Create internet session handle
m_hInet& = InternetOpen(INET_SESSION_NAME$, _
INTERNET_OPEN_TYPE_DIRECT, _
vbNullString, _
vbNullString, 0)
If m_hInet& = FAILURE& Then
Err.Raise ERR_FATAL, "clsFTP:Class [Initialize]", ERR_CRITICAL$
End If
End If

'If we already have an FTP session open then raise error
If m_hSession& Then
Err.Raise ERR_INVALID_PROPERTY, "clsFTP:Connect", "You are already connected to FTP Server " & m_HostAddr$
End If

'Overwrite any existing properties if they were supplied in the
'arguments to this method
If Host$ <> vbNullString Then m_HostAddr$ = Host$
If Port& <> 0 Then m_HostPort& = Port&
If User$ <> vbNullString Then m_User$ = User$
If Password$ <> vbNullString Then m_Password$ = Password$

m_hSession& = InternetConnect(m_hInet&, m_HostAddr$, m_HostPort&, _
m_User$, m_Password$, INTERNET_SERVICE_FTP, 0, 0)

'Check for connection errors
If m_hSession& = NO_CONNECTION& Then
ErrMsg$ = Replace(ERR_CONNECT_ERROR$, "%s", m_HostAddr$)
ErrMsg$ = ErrMsg$ & vbCrLf & GetINETErrorMsg$(Err.LastDllError)
Err.Raise ERR_CANNOT_CONNECT, "clsFTP:Connect", ErrMsg$
End If

Connect& = SUCCESS&

ExitProc:
Exit Function

Handler:
Connect& = Err.Number
Resume ExitProc

End Function
'________________________________________________________________________

Public Function Disconnect&()
'Attempt to disconnect

On Local Error GoTo Handler

Disconnect& = FAILURE&

'Kill off API Handles
If m_hInet& Then InternetCloseHandle m_hInet&
If m_hSession& Then InternetCloseHandle m_hSession&

m_hSession& = NO_CONNECTION&
m_hInet& = NO_CONNECTION&

m_HostAddr$ = vbNullString
m_User$ = vbNullString
m_Password$ = vbNullString
m_Dir$ = vbNullString

Disconnect& = SUCCESS&

ExitProc:
Exit Function

Handler:
Disconnect& = Err.Number
Resume ExitProc

End Function
'________________________________________________________________________

Public Function GetFile&(ByVal HostFile$, _
ByVal ToLocalFile$, _
Optional tt As FileTransferType = fttUnknown)
'Get the specified file and move to the desired location using
'[optional] specified file transfer type

On Local Error GoTo Handler
Dim ReturnVal&
Dim remotefile$
Dim RemoteDir$
Dim LocalFile$
Dim Pos&
Dim ErrMsg$

GetFile& = FAILURE&

'If not connected, raise an error
If m_hSession& = NO_CONNECTION& Then
Err.Raise ERR_NOT_CONNECTED_TO_SITE, "clsFTP:GetFile", ERR_NO_CONNECTION$
End If

'Get the file
ReturnVal& = FtpGetFile(m_hSession&, HostFile$, _
ToLocalFile$, False, INTERNET_FLAG_RELOAD, tt, 0)

If ReturnVal& = FAILURE& Then
ErrMsg$ = Replace(ERR_DOWNLOAD$, "%s", HostFile$)
Err.Raise ERR_CANNOT_GET_FILE, "clsFTP:GetFile", ErrMsg$
End If

GetFile& = SUCCESS&

ExitProc:
Exit Function

Handler:
GetFile& = Err.Number
Resume ExitProc

End Function
'________________________________________________________________________

Public Function PutFile&(ByVal LocalFile$, _
ByVal ToHostFile$, _
Optional tt As FileTransferType = fttUnknown)

On Local Error GoTo Handler
Dim ReturnVal&
Dim Pos&
Dim ErrMsg$

PutFile& = FAILURE&

'If not connected, raise an error
If m_hSession& = NO_CONNECTION& Then
Err.Raise ERR_NOT_CONNECTED_TO_SITE, "clsFTP:PutFile", ERR_NO_CONNECTION$
End If

ReturnVal& = FtpPutFile(m_hSession&, LocalFile$, _
ToHostFile$, tt, 0)

If ReturnVal& = FAILURE& Then
ErrMsg$ = Replace(ERR_DOWNLOAD$, "%s", ToHostFile$)
ErrMsg$ = ErrMsg$ & vbCrLf & GetINETErrorMsg(Err.LastDllError)
Err.Raise ERR_CANNOT_RENAME, "clsFTP:PutFile", ErrMsg$
End If

PutFile& = SUCCESS&

ExitProc:
Exit Function

Handler:
PutFile& = Err.Number
Resume ExitProc

End Function
'________________________________________________________________________

Public Function GetDirListing&(FileNames$(), FileSizes&(), Optional ByVal SubDir$ = vbNullString)
On Local Error GoTo Handler

Dim WFD As WIN32_FIND_DATA
Dim Filter$
Dim hFind&, hFindConnect&
Dim FileSize&
Dim TempFileName$, TempFileSize&
Dim FullDir$
Dim i%

GetDirListing& = FAILURE&

Screen.MousePointer = vbHourglass

'Obtain the current FTP path
Filter$ = "*.*"

FullDir$ = m_Dir$ & SubDir$

AddRemFwdSlash FullDir$, 1

'If not connected, raise an error
If m_hSession& = NO_CONNECTION& Then
Err.Raise ERR_NOT_CONNECTED_TO_SITE, "clsFTP:PutFile", ERR_NO_CONNECTION$
End If

'Connection handles used by the FtpFindFirstFile
'API go out of scope once the files are
'listed, therefore it can not be reused.
'This restriction is handled by obtaining
'a fresh connection handle each time a call
'to FtpFindFirstFile is required, and releasing
'it once finished.
hFindConnect& = GetInternetConnectHandle()

hFind& = FtpFindFirstFile(m_hSession&, _
FullDir$ & Filter$, WFD, _
INTERNET_FLAG_RELOAD Or _
INTERNET_FLAG_NO_CACHE_WRITE, 0&)

If hFind& Then
i% = 0
Do
ReDim Preserve FileNames$(i%)
ReDim Preserve FileSizes&(i%)
TempFileName$ = ClipNull(WFD.cFileName)
If Len(TempFileName$) Then
If WFD.dwFileAttributes And vbDirectory Then
TempFileName$ = TempFileName$ & FWDSLASH$
TempFileSize& = 0
Else
TempFileSize& = WFD.nFileSizeLow
End If
FileNames$(i%) = TempFileName$
FileSizes&(i%) = TempFileSize&
End If
'Continue while valid
i% = i% + 1
Loop While InternetFindNextFile(hFind&, WFD)

End If 'If hFind&

InternetCloseHandle hFindConnect&
InternetCloseHandle hFind&

Screen.MousePointer = vbDefault
GetDirListing& = SUCCESS&

ExitProc:
Exit Function

Handler:
GetDirListing& = Err.Number
Resume ExitProc

End Function
'________________________________________________________________________

Public Function RenameFile&(ByVal FileNameOld$, ByVal FileNameNew$)

On Local Error GoTo Handler

'The FTP rename command can be thought of as being more than just a simple host
'file renaming facility. When invoking a rename command on a file in a sub-folder from
'the current FTP folder, the file is essentially 'moved' to its new location
'in one simple step. Actually, the file is NOT physically copied to a new location
'and the old one deleted. Because the file on the FTP server is being renamed to
'a target directory in the same file system, FTP is clever enough just
'to change the file's directory pointer so the file never gets recopied. This
'is critical in preserving file integity, and is of significant importance to
'us in our use of buffer directories.

Dim ReturnVal&
Dim ErrMsg$

RenameFile& = FAILURE&

'If not connected, raise an error
If m_hSession& = NO_CONNECTION& Then
Err.Raise ERR_NOT_CONNECTED_TO_SITE, "clsFTP:RenameFile", ERR_NO_CONNECTION$
End If

ReturnVal& = FtpRenameFile(m_hSession&, FileNameOld$, FileNameNew$)

'Raise an error if we couldn't rename the file (most likely that
'a file with the new name already exists
If ReturnVal& = FAILURE& Then
ErrMsg$ = Replace(ERR_RENAME$, "%s", FileNameOld$)
ErrMsg$ = ErrMsg$ & vbCrLf & GetINETErrorMsg(Err.LastDllError)
Err.Raise ERR_CANNOT_RENAME, "clsFTP:RenameFile", ErrMsg$
End If

RenameFile& = SUCCESS&

ExitProc:
Exit Function

Handler:
RenameFile& = Err.Number
Resume ExitProc

End Function
'________________________________________________________________________

Public Function DeleteFile&(ByVal FileToDelete$)
On Local Error GoTo Handler

Dim ReturnVal&
Dim ErrMsg$

DeleteFile& = FAILURE&

'Check for a connection
If m_hSession& = NO_CONNECTION& Then
Err.Raise ERR_NOT_CONNECTED_TO_SITE, "clsFTP:DeleteFile", ERR_NO_CONNECTION$
End If

ReturnVal& = FtpDeleteFile(m_hSession&, FileToDelete$)

'Raise an error if the file couldn't be deleted
If ReturnVal& = FAILURE& Then
ErrMsg$ = Replace(ERR_DELETE$, "%s", FileToDelete$)
Err.Raise ERR_CANNOT_DELETE, "clsFTP:DeleteFile", ErrMsg$
End If

DeleteFile& = SUCCESS&

ExitProc:
Exit Function

Handler:
DeleteFile& = Err.Number
Resume ExitProc

End Function

Public Function CreateDirectory&(ByVal PathName$)
On Local Error GoTo Handler


Dim ReturnVal&
Dim ErrMsg$
Dim pData As WIN32_FIND_DATA
Dim oldpath$
Dim newpath$
Dim nfind&
Dim temppath$

oldpath$ = Directory
newpath$ = PathName$
If InStr(1, newpath$, oldpath$) = 1 Then
newpath$ = Right(newpath$, Len(newpath$) - Len(oldpath$))
End If

pData.cFileName = String(260, 0)
CreateDirectory& = FAILURE&

'Check for a connection
If m_hSession& = NO_CONNECTION& Then
Err.Raise ERR_NOT_CONNECTED_TO_SITE, "clsFTP:CreateDirectory", ERR_NO_CONNECTION$
End If

' 检查目录是否存在
Dim hFind As Long, nLastError As Long

Do

nfind = InStr(1, newpath$, "/")
If nfind > 0 Then
temppath$ = Left(newpath$, nfind - 1)
newpath$ = Right(newpath$, Len(newpath$) - nfind)
Else
temppath$ = newpath$
newpath$ = ""
End If


hFind = FtpFindFirstFile(m_hSession&, temppath$, pData, 0, 0) ' 查找第一个文件或目录
If hFind = 0 Then
' 没有找到
Err.Clear

' 创建目录
ReturnVal& = FtpCreateDirectory(m_hSession&, temppath$)

'Raise an error if the file couldn't be deleted
If ReturnVal& = FAILURE& Then
ErrMsg$ = Replace(ERR_CREATEDIRECOTRY$, "%s", temppath$)
Err.Raise ERR_CANNNOT_CREATEDIRECTORY, "clsFTP:CreateDirectory", ErrMsg$
End If
Else
' 已经存在
End If
InternetCloseHandle (hFind)
Directory = temppath$

Loop While Len(newpath$) > 0

Directory = oldpath$

CreateDirectory& = SUCCESS&

ExitProc:
Exit Function

Handler:
CreateDirectory& = Err.Number
Resume ExitProc

End Function

'________________________________________________________________________

' ---------------------------------------------------------
' ----------------- Private Functions ---------------------
' ---------------------------------------------------------

Private Function GetDirName&(FTPDir$)
On Local Error GoTo Handler

Dim BufferLen&
Dim BufferStr$
Dim ReturnVal&

GetDirName& = FAILURE&
FTPDir$ = vbNullString
m_Dir$ = vbNullString

'If not connected, raise an error
If m_hSession& = NO_CONNECTION& Then
Err.Raise ERR_NOT_CONNECTED_TO_SITE, "clsFTP:GetDirName", ERR_NO_CONNECTION$
End If

BufferStr$ = Space$(256)
BufferLen& = Len(BufferStr$)

ReturnVal& = FtpGetCurrentDirectory(m_hSession&, BufferStr$, BufferLen&)

If ReturnVal& = SUCCESS& Then
'return a properly qualified path
BufferStr$ = ClipNull(BufferStr$)

m_Dir$ = BufferStr$
FTPDir$ = m_Dir$
GetDirName& = SUCCESS&
End If

ExitProc:
Exit Function

Handler:
GetDirName& = Err.Number
Resume ExitProc

End Function
'________________________________________________________________________

Private Function ChangeDir&(ByVal HostDir$)
On Local Error GoTo Handler

Dim ReturnVal&
Dim ErrMsg$

ChangeDir& = FAILURE&

'Ensure that rightmost character is a backslash
AddRemSlash HostDir$, 1

'Replace all back-slashes with forward-slashes: Telnet standard
HostDir$ = Replace(HostDir$, BACKSLASH$, FWDSLASH$)

'Check for a connection
If m_hSession& = NO_CONNECTION& Then
Err.Raise ERR_NOT_CONNECTED_TO_SITE, "clsFTP:ChangeDir", ERR_NO_CONNECTION$
End If

ReturnVal& = FtpSetCurrentDirectory(m_hSession&, HostDir$)

'If we can't change directory - raise an error
If ReturnVal& = FAILURE& Then
ErrMsg$ = ERR_CHANGE_DIR$
ErrMsg$ = Replace(ErrMsg$, "%s", HostDir$)
Err.Raise ERR_CHANGE_DIR$, "clsFTP:ChangeDir", ErrMsg$
End If

ChangeDir& = SUCCESS&

ExitProc:
Exit Function

Handler:
ChangeDir& = Err.Number
Resume ExitProc

End Function
'________________________________________________________________________

Private Function GetINETErrorMsg$(ByVal ErrNum&)
Dim LenError&, LenBuffer&
Dim Buffer$

'Get extra info from the WinInet.DLL
If ErrNum& = ERROR_INTERNET_EXTENDED_ERROR Then
'Get message size and number
InternetGetLastResponseInfo LenError&, vbNullString, LenBuffer&
Buffer$ = String$(LenBuffer& + 1, vbNullChar)
'Get message
InternetGetLastResponseInfo LenError&, Buffer$, LenBuffer&
GetINETErrorMsg = vbCrLf & Buffer$
End If

End Function
'________________________________________________________________________

Private Function GetInternetConnectHandle&()
Dim sServerName As String
Dim H&

'Obtains a new handle expressly for use with the
'FtpFindFirstFile API.
'
'Care must be taken to close only the handle
'returned by this function once the listing
'of the directory has been obtained.

If m_hInet& Then
H& = InternetConnect(m_hInet&, _
m_HostAddr$, _
m_HostPort&, _
m_User$, _
m_Password$, _
INTERNET_SERVICE_FTP, _
INTERNET_FLAG_EXISTING_CONNECT Or INTERNET_FLAG_PASSIVE, _
&H0)
End If

GetInternetConnectHandle& = H&

End Function
'________________________________________________________________________

Private Function AddRemFwdSlash&(PathName$, ByVal IsSlash As Byte)
On Local Error GoTo Handler

AddRemFwdSlash& = FAILURE&

If IsSlash Then 'We want a "\" at end
If Right(PathName$, 1) <> FWDSLASH$ Then PathName$ = PathName$ & FWDSLASH$

Else 'We don't want a "\" at end
If Right(PathName$, 1) = FWDSLASH$ Then
PathName$ = Mid(PathName$, 1, Len(PathName$) - 1)
End If
End If

AddRemFwdSlash& = SUCCESS&

ExitProc:
Exit Function

Handler:
AddRemFwdSlash& = Err.Number
'MsgBox Err.Number & ": " & Err.Description, _
vbExclamation, "AddRemFwdSlash Error"
Resume ExitProc

End Function
'________________________________________________________________________

Public Function AddRemSlash&(PathName$, ByVal IsSlash As Byte)
On Local Error GoTo Handler

AddRemSlash& = FAILURE&

If IsSlash Then 'We want a "\" at end
If Right(PathName$, 1) <> BACKSLASH$ Then PathName$ = PathName$ & BACKSLASH$
Else 'We don't want a "\" at end
If Right(PathName$, 1) = BACKSLASH$ Then
PathName$ = Mid(PathName$, 1, Len(PathName$) - 1)
End If
End If

AddRemSlash& = SUCCESS&

ExitProc:
Exit Function

Handler:
AddRemSlash& = Err.Number
'MsgBox Err.Number & ": " & Err.Description, _
vbExclamation, "AddRemSlash Error"
Resume ExitProc

End Function
'________________________________________________________________________

Private Function ClipNull$(ByVal str$)
Dim Pos%

Pos% = InStr(1, str$, vbNullChar)
If Pos% > 0 Then
ClipNull$ = Left(str$, Pos% - 1)
End If

End Function

摘自：网络整理

---

相关文章参考：

※VB FTP操作类(可上传、下载、创建文件夹等等)

※VB 删除带子文件夹和文件的文件夹※

※用treeview遍历文件夹（vb）※

※VB 将文件夹复制到指定目录※

※VB 详细枚举指定目录、文件夹文件列表※

※VB删除带子文件夹和文件的文件夹

※VB 打开文件夹,并选中指定的文件

※得到指定文件夹下的文件列表

※VB选择文件夹并取文件夹名※

 ★VB部分相关文章推荐：★

---

※VB 释放资源文件到指定目录函数

※VB 读取资源文件里面的字符串

※VB中资源文件.res的使用方法详解

※VB6.0中创建和使用文本资源文件

※VB WindowsMediaPlayer 播放

※vb中WindowsMediaPlayer的常用属性和方法

※VB Environ系统环境变量函数大全

※VB 去除文本框粘贴功能

※VB LISTBOX

※VB 删除数组中的重复元素

※VB数组快速排序算法

※关于三个概念：ActiveX、OLE和COM

※VB 获得磁盘的文件系统

※VB中用API实现文件拖放

※加密算法-MD5算法

※VB中使用MD5算法

※VB 全局热键HOOK (不占系统资源版本)

※VB 小技巧自定义TextBox文本框右键菜单

※VB 写下载者代码

※VB 一行代码的诀窍

※VBS教程-wscript对象

※vb枚举进程

※在VB中如何让线程或进程在指定的CPU上运行

※VB判断指定的WORD文档是否被打开

※VB如何读取快捷方式的目标路径

※VB用API控制输入法状态

※为系统加载右键注册控件选项【VB 注册控件】

※VB如何根据窗口标题获得进程名称

※VB快速查找大型文件中包含的字符串

※VB实现可执行文件运行时自删除

※VB 打开txt,bat,jpg 任意后缀程序

※VB 写文件关联程序

※VB 自启动建立右键菜单

※VB 判断IP能否ping通

※VB FTP操作类(可上传、下载、创建文件夹等等)

※VB部分文件汇总B

※Vb 求素数最经典的方法也是最快的方法

※vb用数组方式快速导出MSFlexGrid表格数据到Excel表格中

※VB中MsFlexGrid控件的使用细则

※点击MSFlexGrid数据控件的标题进行数据排序

※VB 获取鼠标坐标

※VB中NEW的用法（申请内存空间）

※VB CreateObject函数

※VB中的New 与 CreateObject的区别

※VB ListBox 添加不重复的值

※VB 单击ListView控件某列表头进行排序

※VB 简单实现简体与繁体互转

※VB 阿拉伯数字转换为中文大写数值函数

※VB 获取Textbox文本框中的行数函数

---

更多精彩>>>