VB6.0 通过 wininet.dll 来实现 FTP 的访问

最近在写一段访问FTP服务器的代码，网上找了一堆资料，借鉴修改后完成了一个类模块的开发，

在这里记录一下。感谢互联网提供的便利。

主要功能有：

Connect        连接FTP服务器
Disconnect    断开FTP服务器
GetFile        获取FTP服务器上的文件
PutFile        将文件上送到FTP服务器
GetDirListing    获得FTP服务器当前目录下的所有文件/目录
RenameFile    重命名FTP服务器上的文件
DeleteFile        删除FTP服务器上文件
DeleteFtpDirectory    删除FTP服务器上的目录，要求目录下没有文件了
CreateDirectory    FTP服务器上创建一个目录
GetDirName    获取FTP服务器上当前的目录
ChangeDir    改变FTP服务器上的当前目录

Option Explicit
'Copyright Graham Daly December 2001
'Modify hzdl001 May 2024

' ---------------------------------------------------------
' -------------------   API Functions  --------------------
' ---------------------------------------------------------
'File information
Private Type WIN32_FIND_DATA
    dwFileAttributes As Long
    ftCreationTime As Currency
    ftLastAccessTime As Currency
    ftLastWriteTime As Currency
    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 SafeArrayGetDim Lib "oleaut32.dll" (ByRef saArray() As Any) As Long   '判断数组是否为空

Private Declare Function FtpFindFirstFile Lib "wininet.dll" Alias "FtpFindFirstFileA" (ByVal hFtpSession As Long, _
        ByVal lpszSearchFile As String, lpFindFileData As WIN32_FIND_DATA, ByVal dwFlags As Long, ByVal dwContent As Long) As Long

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

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

Private Declare Function FtpPutFile Lib "wininet.dll" Alias "FtpPutFileA" (ByVal hFtpSession As Long, ByVal lpszLocalFile As String, _
        ByVal lpszRemoteFile As String, ByVal dwFlags As Long, ByVal dwContext As Long) As Boolean
        
Private Declare Function FtpRenameFile Lib "wininet.dll" Alias "FtpRenameFileA" (ByVal hOutboundSession As Long, ByVal sExistingName As String, ByVal sNewName As String) As Boolean

Private Declare Function FtpDeleteFile Lib "wininet.dll" Alias "FtpDeleteFileA" (ByVal hFtpSession As Long, ByVal lpszFileName As String) As Boolean

Private Declare Function FtpGetCurrentDirectory Lib "wininet.dll" Alias "FtpGetCurrentDirectoryA" (ByVal hFtpSession As Long, _
        ByVal lpszCurrentDirectory As String, lpdwCurrentDirectory As Long) As Boolean
        
Private Declare Function FtpSetCurrentDirectory Lib "wininet.dll" Alias "FtpSetCurrentDirectoryA" (ByVal hFtpSession As Long, ByVal lpszDirectory As String) As Boolean

Private Declare Function InternetConnect Lib "wininet.dll" Alias "InternetConnectA" (ByVal hInternetSession As Long, ByVal sServerName As String, ByVal nServerPort As Integer, _
        ByVal sUsername As String, ByVal sPassword As String, ByVal lService As Long, ByVal lFlags As Long, ByVal lContext As Long) As Long
        
Private Declare Function FtpCreateDirectory Lib "wininet.dll" Alias "FtpCreateDirectoryA" (ByVal hFtpSession As Long, ByVal lpszDirectory As String) As Boolean

Private Declare Function FtpRemoveDirectory Lib "wininet.dll " Alias "FtpRemoveDirectoryA" (ByVal hFtpSession As Long, ByVal lpszName As String) As Boolean

Private Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" (ByVal sAgent As String, ByVal lAccessType As Long, _
        ByVal sProxyName As String, ByVal sProxyBypass As String, ByVal lFlags As Long) As Long
        
Private Declare Function InternetCloseHandle Lib "wininet.dll" (ByVal hInet As Long) As Long

Private Declare Function InternetGetLastResponseInfo Lib "wininet.dll" Alias "InternetGetLastResponseInfoA" (ByRef lpdwError As Long, _
        ByVal lpszErrorBuffer As String, ByRef lpdwErrorBufferLength As Long) As Boolean

Private Declare Function FtpOpenFile Lib "wininet.dll" Alias "FtpOpenFileA" (ByVal hFtpSession As Long, _
        ByVal sBuff As String, ByVal Access As Long, ByVal flags As Long, ByVal Context As Long) As Long

Private Declare Function InternetWriteFile Lib "wininet.dll" (ByVal hFile As Long, ByRef sBuffer As Byte, ByVal lNumBytesToWite As Long, dwNumberOfBytesWritten As Long) As Integer

Private Declare Function FileTimeToLocalFileTime Lib "kernel32" (lpFileTime As Any, lpLocalFileTime As Any) As Long

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

'Error messages
Private Const ERR_CHANGE_DIR As String = "Cannot change directory to <%s>. It either doesn't exist, or is protected"
Private Const ERR_CONNECT_ERROR As String = "Cannot connect to FTP server <%s> using User and Password Parameters"
Private Const ERR_ALREADY_CONNECTED As String = "Cannot change property while connected to FTP server"
Private Const ERR_NO_CONNECTION As String = "Cannot connect to FTP server"
Private Const ERR_DOWNLOAD As String = "Cannot get file <%s> from FTP server"
Private Const ERR_RENAME As String = "Cannot rename file <%s>"
Private Const ERR_DELETE As String = "Cannot delete file <%s> from FTP server"
Private Const ERR_CRITICAL As String = "Cannot get connection to WinInet.dll!"
Private Const ERR_CREATEDIRECOTRY As String = "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_NO_CACHE_WRITE = &H4000000
Private Const INTERNET_FLAG_PASSIVE = &H8000000
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
Private Const FILE_ATTRIBUTE_READONLY = &H1
Private Const FILE_ATTRIBUTE_HIDDEN = &H2
Private Const FILE_ATTRIBUTE_SYSTEM = &H4
Private Const FILE_ATTRIBUTE_DIRECTORY = &H10
Private Const FILE_ATTRIBUTE_ARCHIVE = &H20
Private Const FILE_ATTRIBUTE_NORMAL = &H80
Private Const FILE_ATTRIBUTE_TEMPORARY = &H100
Private Const FILE_ATTRIBUTE_COMPRESSED = &H800
Private Const FILE_ATTRIBUTE_OFFLINE = &H1000
'Other
Private Const INTERNET_OPEN_TYPE_PRECONFIG = 0  '搜索windows的代理设置，按设置进行连接INTERNET
Private Const INTERNET_OPEN_TYPE_DIRECT = 1 '直接连接INTERNET
Private Const INET_SESSION_NAME As String = "hzdl001 FTP Sesh"
Private Const ERROR_INTERNET_EXTENDED_ERROR = 12003
Private Const NO_CONNECTION = 0
Private Const FWDSLASH As String = "/"
Private Const BACKSLASH As String = "/"
Private Const rDayZeroBias As Double = 109205#   ' Abs(CDbl(#01-01-1601#))
Private Const rMillisecondPerDay As Double = 10000000# * 60# * 60# * 24# / 10000#

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

'Our INET handle
Private m_hInet As Long

'Our FTP connection Handle
Private m_hSession As Long

'Standard FTP properties
Private m_HostAddr As String
Private m_HostPort As Long
Private m_User As String
Private m_Password As String
Private m_Dir As String
Private m_ErrMsg As String '用于存放错误代码

' ---------------------------------------------------------
' ------------------ User-defined Types -------------------
' ---------------------------------------------------------
Private Type DirListType
    fileName As String
    Type As String  '类型分两种 "path" 和 "file"
    size As String '单位是 byte
    datetime As String
End Type

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 = 0
    m_hInet = 0
    m_HostAddr = ""
    m_HostPort = 0
    m_User = ""
    m_Password = ""
    m_Dir = ""
End Sub
'________________________________________________________________________

Private Sub Class_Terminate()
    'Kill off connection
    If m_hSession <> 0 Then InternetCloseHandle m_hSession
    'Kill off API Handle
    If m_hInet <> 0 Then InternetCloseHandle m_hInet&

    m_hSession = 0
    m_hInet = 0
End Sub
'________________________________________________________________________

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

Public Property Let Host(ByVal HostAddr As String)
    'Set the host address - only if un-connected
    
    m_ErrMsg = ""
    
    If m_hSession = 0 Then
        m_HostAddr = HostAddr
    Else
        m_ErrMsg = "Cannot change property while connected to FTP server"
    End If

End Property
'________________________________________________________________________

Public Property Get Host() As String
    'Get host address
    Host = m_HostAddr

End Property
'________________________________________________________________________

Public Property Let Port(ByVal HostPort As Long)
    'Set the host port - only if un-connected
    
    m_ErrMsg = ""
    
    If m_hSession = 0 Then
        m_HostPort = HostPort
    Else
        m_ErrMsg = "Cannot change property while connected to FTP server"
    End If

End Property
'________________________________________________________________________

Public Property Get Port() As Long
    'Get host port
    Port& = m_HostPort&

End Property
'________________________________________________________________________

Public Property Let User(ByVal UserName As String)
    'Set the user - only if un-connected
    
    m_ErrMsg = ""
    
    If m_hSession = 0 Then
        m_User = UserName
    Else
        m_ErrMsg = "Cannot change property while connected to FTP server"
    End If

End Property
'________________________________________________________________________

Public Property Get User() As String
    'Get user
    User$ = m_User$

End Property
'________________________________________________________________________

Public Property Let Password(ByVal Pwd As String)
    'Set the password - only if un-connected
    
    m_ErrMsg = ""

    If m_hSession = 0 Then
        m_Password = Pwd
    Else
        m_ErrMsg = "Cannot change property while connected to FTP server"
    End If

End Property
'________________________________________________________________________

Public Property Get Password() As String
    'Get the password

    Password = m_Password

End Property
'________________________________________________________________________

Public Property Let Directory(ByVal Folder As String)
    'Set the directory - only if connected
    
    m_ErrMsg = ""

    If m_hSession = 0 Then
        m_ErrMsg = "Cannot change Directory while disconnected to FTP server"
    Else
        ChangeDir Folder
    End If

End Property
'________________________________________________________________________

Public Property Get Directory() As String
    'Get directory
    Dim TempDir As String

    If (GetDirName(TempDir) <> 1) Then
        TempDir = "<Unknown>"
    End If
    Directory = TempDir
    
End Property
'________________________________________________________________________

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

    IsConnected = (GetDirName(Temp) = 1)

End Property
'________________________________________________________________________

Public Property Get ErrMsg() As String
    'Get the ErrMsg

    ErrMsg = m_ErrMsg

End Property
'______________

' ---------------------------------------------------------
' --------------- Exposed Class Methods -------------------
' ---------------------------------------------------------
'连接成功 返回1，否则0
Public Function Connect(Optional ByVal Host As String = "", Optional ByVal Port As Long = 0, Optional ByVal User As String = "", Optional ByVal Password As String = "") As Long

    'Attempt to connect to FTP server
    Dim ErrMsg As String
    Dim hFindConnect As Long
    Dim hFind As Long
    Dim WFD As WIN32_FIND_DATA
    
    m_ErrMsg = ""
    Connect = 0

    If m_hInet = 0 Then
        'Create internet session handle
        m_hInet = InternetOpen("hzdl001 FTP Sesh", INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0)
        If m_hInet = 0 Then
            m_ErrMsg = "Cannot get connection to WinInet.dll!"
            Exit Function
        End If
    End If

    'If we already have an FTP session open then raise error
    If m_hSession <> 0 Then
        m_ErrMsg = "You are already connected to FTP Server " & m_HostAddr
        Exit Function
    End If

    'Overwrite any existing properties if they were supplied in the
    'arguments to this method
    If Host <> "" Then m_HostAddr = Host
    If Port <> 0 Then m_HostPort = Port
    If User <> "" Then m_User = User
    If Password <> "" Then m_Password = Password
    
    '连接FTP服务器有两种模式，Direct模式和Passive模式，这要根据服务器的配置来选择
    '这里通过联通服务器后，检查是否能正常调取文件来判断服务器使用的是那种模式。
    m_hSession& = InternetConnect(m_hInet, m_HostAddr, m_HostPort, m_User, m_Password, INTERNET_SERVICE_FTP, 0, 0)
    
    '先用Direct模式进行连接，进行调取文件进行尝试,如果hFind是0则调取失败，再用Passive模式连接
    hFind& = FtpFindFirstFile(m_hSession, "*.*", WFD, INTERNET_FLAG_RELOAD Or INTERNET_FLAG_NO_CACHE_WRITE, 0&)
    If hFind = 0 Then
        m_hSession& = InternetConnect(m_hInet, m_HostAddr, m_HostPort, m_User, m_Password, INTERNET_SERVICE_FTP, INTERNET_FLAG_PASSIVE, 0)
    End If
    InternetCloseHandle hFind&
    'Check for connection errors
    If m_hSession = 0 Then
        ErrMsg = "Cannot connect to FTP server " & m_HostAddr & " using User and Password Parameters"
        ErrMsg = ErrMsg$ & vbCrLf & GetINETErrorMsg(Err.LastDllError)
        m_ErrMsg = ErrMsg
        Exit Function
    End If

    Connect = 1
    
    '连接服务器成功后，设置m_Dir值
    GetDirName m_Dir

End Function
'________________________________________________________________________

Public Function Disconnect() As Long
    'Attempt to disconnect
    
    m_ErrMsg = ""
    Disconnect& = 0

    'Kill off API Handles
    If m_hInet <> 0 Then InternetCloseHandle m_hInet
    If m_hSession <> 0 Then InternetCloseHandle m_hSession

    m_hSession = 0
    m_hInet = 0
    m_Dir = ""

    Disconnect = 1

End Function
'________________________________________________________________________

Public Function GetFile(ByVal HostFile As String, Optional ByVal ToLocalFile As String = vbNullString, Optional ByVal TT As FileTransferType = FTP_TRANSFER_TYPE_ASCII Or INTERNET_FLAG_RELOAD) As Long
    'Get the specified file and move to the desired location using
    '[optional] specified file transfer type

    Dim ReturnVal As Long
    Dim RemoteFile, LocalFile, ErrMsg As String
    Dim RemoteDir As String
    Dim k As Integer
    
    m_ErrMsg = ""
    GetFile = 0
    
    'If not connected, raise an error
    If m_hSession = 0 Then
         m_ErrMsg = "Cannot GetFile while disconnected to FTP server"
         Exit Function
    End If

    'Get the file,
    '先判断HostFile是否是带路径的文件名，如果不带路径表示使用当前路径，把当前路径补充完整
    k = InStrRev(HostFile, "/")
    If k = 0 Then '不带路径
        RemoteDir = m_Dir
        AddRemSlash RemoteDir, 1
        RemoteFile = RemoteDir & HostFile
    Else
        RemoteFile = HostFile
    End If
    
    '如果ToLocalFile为空，则用服务器端的文件名
    If ToLocalFile = "" Then
        k = InStrRev(RemoteFile, "/")
        LocalFile = Right(RemoteFile, Len(RemoteFile) - k)
    Else
        LocalFile = ToLocalFile
    End If
        
    ReturnVal = FtpGetFile(m_hSession, RemoteFile, LocalFile, False, FILE_ATTRIBUTE_NORMAL, TT, 0)

    If ReturnVal = 0 Then
        ErrMsg = "Cannot get file " & RemoteFile & " from FTP server"
        m_ErrMsg = ErrMsg
        Exit Function
    End If

    GetFile = 1

End Function
'________________________________________________________________________

Public Function PutFile(ByVal LocalFile As String, Optional ByVal ToHostFile As String = vbNullString, Optional TT As FileTransferType = FTP_TRANSFER_TYPE_ASCII) As Long

    Dim ReturnVal As Long
    Dim ErrMsg As String
    Dim FtpFile As String
    Dim k As Integer

    m_ErrMsg = ""
    PutFile& = 0&

    'If not connected, raise an error
    If m_hSession = 0 Then
         m_ErrMsg = "Cannot PutFile while disconnected to FTP server"
         Exit Function
    End If
    
    If ToHostFile = "" Then
        k = InStrRev(LocalFile, "\")
        If k = 0 Then
            FtpFile = LocalFile
        Else
            FtpFile = Right(LocalFile, Len(LocalFile) - k)
        End If
    Else
        FtpFile = ToHostFile
    End If
    ReturnVal = FtpPutFile(m_hSession, LocalFile, FtpFile, TT, 0)

    If ReturnVal& = 0& Then
        ErrMsg = "Cannot put file " & LocalFile & " to FTP server"
        ErrMsg = ErrMsg & vbCrLf & GetINETErrorMsg(Err.LastDllError)
        m_ErrMsg = ErrMsg
        Exit Function
    End If

    PutFile& = 1

End Function
'________________________________________________________________________

Public Function GetDirListing(Optional ByVal SubDir As String = vbNullString) As String()
    '返回一个二维数组，第二维ubound是3，其中(0)是文件名，(1)是文件类型 分为 path 和 file，(2)是文件大小 单位是byte，(3)是日期。
    Dim DirList() As DirListType
    Dim WFD As WIN32_FIND_DATA
    Dim OutStr() As String
    Dim TempFileName As String
    Dim hFind, hFindConnect, TempFileSize As Long
    Dim i, k As Integer

    m_ErrMsg = ""
    
    Screen.MousePointer = vbHourglass

    'If not connected, raise an error
    If m_hSession = 0 Then
         m_ErrMsg = "Cannot GetDirListing while disconnected to FTP server"
         Exit Function
    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, "*.*", WFD, INTERNET_FLAG_RELOAD Or INTERNET_FLAG_NO_CACHE_WRITE, 0)

    If hFind <> 0 Then
        i = 0
        Do
            TempFileName = ClipNull(WFD.cFileName)
            If Len(TempFileName) > 0 And TempFileName <> "." And TempFileName <> ".." Then
                ReDim Preserve DirList(i)
                If WFD.dwFileAttributes And vbDirectory Then
                    DirList(i).Type = "path"
                    TempFileSize = "0"
                Else
                    DirList(i).Type = "file"
                    TempFileSize = Trim(str(WFD.nFileSizeLow))
                End If
                DirList(i).fileName = TempFileName
                DirList(i).size = TempFileSize
                DirList(i).datetime = Win32ToVbTime(WFD.ftLastWriteTime)
                i = i + 1
            End If
            'Continue while valid
        Loop While InternetFindNextFile(hFind, WFD)
        If SafeArrayGetDim(DirList) = 0 Then ReDim DirList(0) '如果数组DirList为空，则ReDim
        ReDim OutStr(UBound(DirList), 3)
        For k = 0 To UBound(DirList)
            OutStr(k, 0) = DirList(k).fileName
            OutStr(k, 1) = DirList(k).Type
            OutStr(k, 2) = DirList(k).size
            OutStr(k, 3) = DirList(k).datetime
        Next
    Else
        ReDim OutStr(0, 3)
    End If

'注意，这里必须关闭hFind，不然下次再查询就是空结果了
    InternetCloseHandle hFind

    Screen.MousePointer = vbDefault
    
    GetDirListing = OutStr
    
End Function
'________________________________________________________________________

Public Function RenameFile(ByVal FileNameOld As String, ByVal FileNameNew As String) As Long

    '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 As Long
    Dim ErrMsg As String
    
    m_ErrMsg = ""
    RenameFile = 0

    'If not connected, raise an error
    If m_hSession = 0 Then
         m_ErrMsg = "Cannot RenameFile while is disconnected to FTP server"
         Exit Function
    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 = 0 Then
        ErrMsg = "Cannot rename file " & FileNameOld & " from FTP server"
        ErrMsg = ErrMsg & vbCrLf & GetINETErrorMsg(Err.LastDllError)
        m_ErrMsg = ErrMsg
        Exit Function
    End If

    RenameFile = 1

End Function
'________________________________________________________________________

Public Function DeleteFile(ByVal FileToDelete As String) As Long
    Dim ReturnVal As Long
    Dim ErrMsg As String
    Dim k As Integer

    m_ErrMsg = ""
    DeleteFile = 0

    'If not connected, raise an error
    If m_hSession = 0 Then
         m_ErrMsg = "Cannot DeleteFile while is disconnected to FTP server"
         Exit Function
    End If
    
    ReturnVal = FtpDeleteFile(m_hSession, FileToDelete)

    'Raise an error if the file couldn't be deleted
    If ReturnVal& = 0& Then
        ErrMsg = "Cannot delete file " & FileToDelete & " from FTP server"
        ErrMsg = ErrMsg & vbCrLf & GetINETErrorMsg(Err.LastDllError)
        m_ErrMsg = ErrMsg
        Exit Function
    End If

    DeleteFile = 1

End Function

'将FTP服务器上的目录删除
Public Function DeleteFtpDirectory(ByVal DirectoryToDelete As String) As Long
    Dim ReturnVal As Long
    Dim ErrMsg As String
    
    m_ErrMsg = ""
    DeleteFtpDirectory = 0

    'If not connected, raise an error
    If m_hSession = 0 Then
         m_ErrMsg = "Cannot DeleteFtpDirectory while is disconnected to FTP server"
         Exit Function
    End If
    
    ReturnVal = FtpRemoveDirectory(m_hSession, DirectoryToDelete)
    
    'Raise an error if the file couldn't be deleted
    If ReturnVal& = 0& Then
        ErrMsg = "Cannot delete Directory " & DirectoryToDelete & " from FTP server"
        ErrMsg = ErrMsg & vbCrLf & GetINETErrorMsg(Err.LastDllError)
        m_ErrMsg = ErrMsg
        Exit Function
    End If
    
    DeleteFtpDirectory = 1
    
End Function
'________________________________________________________________________
'在当前目录下，创建子目录
Public Function CreateDirectory(ByVal PathName As String) As Long
    Dim hFind, ReturnVal As Long
    Dim ErrMsg, TempPath, Directory As String
    Dim pData As WIN32_FIND_DATA
    
    m_ErrMsg = ""
    CreateDirectory = 0
    
    'If not connected, raise an error
    If m_hSession = 0 Then
         m_ErrMsg = "Cannot CreateDirectory while is disconnected to FTP server"
         Exit Function
    End If
    
    Directory = m_Dir
    AddRemSlash Directory, 1
    TempPath = Directory & PathName
   ' 检查目录是否存在
    hFind = FtpFindFirstFile(m_hSession, TempPath, pData, 0, 0)     ' 查找第一个文件或目录
    If hFind = 0 Then ' 没有找到
        InternetCloseHandle hFind
        Err.Clear
        ' 创建目录
        ReturnVal = FtpCreateDirectory(m_hSession, PathName)
        'Raise an error if the file couldn't be deleted
        If ReturnVal& = 0& Then
            ErrMsg = "Cannot Create Directory " & TempPath & " from FTP server"
            ErrMsg = ErrMsg & vbCrLf & GetINETErrorMsg(Err.LastDllError)
            m_ErrMsg = ErrMsg
            Exit Function
        End If
        
        CreateDirectory = 1
        
    End If
    
    InternetCloseHandle hFind
    
End Function
'------------------------------------------------------------------------------

'________________________________________________________________________

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

Private Function GetDirName(ByRef FTPDir As String) As Long
    Dim BufferLen As Long
    Dim ReturnVal As Long
    Dim BufferStr As String
    Dim ErrMsg As String

    m_ErrMsg = ""
    GetDirName = 0
    FTPDir = vbNullString
    m_Dir = vbNullString


    'If not connected, raise an error
    If m_hSession = 0 Then
         m_ErrMsg = "Cannot GetDirectoryName while is disconnected to FTP server"
         Exit Function
    End If
    
    BufferStr$ = Space$(256)
    BufferLen& = Len(BufferStr$)

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

    If ReturnVal = 1 Then
        'return a properly qualified path
        BufferStr = ClipNull(BufferStr)

        m_Dir = BufferStr
        FTPDir = m_Dir
        GetDirName = 1
    Else:
        ErrMsg = "Cannot Get Directory Name from FTP server"
        ErrMsg = ErrMsg & vbCrLf & GetINETErrorMsg(Err.LastDllError)
        m_ErrMsg = ErrMsg
        Exit Function
    End If

End Function
'________________________________________________________________________

Public Function ChangeDir(ByVal HostDir As String) As Long
    Dim ReturnVal As Long
    Dim ToChangeDir As String
    Dim ErrMsg As String

    m_ErrMsg = ""
    ChangeDir = 0

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

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

    'If not connected, raise an error
    If m_hSession = 0 Then
         m_ErrMsg = "Cannot ChangeDir while is disconnected to FTP server"
         Exit Function
    End If

    ReturnVal = FtpSetCurrentDirectory(m_hSession, ToChangeDir)

    'If we can't change directory - raise an error
    If ReturnVal& = 0& Then
        ErrMsg$ = "Cannot change directory to " & ToChangeDir & ". It either doesn't exist, or is protected"
        ErrMsg = ErrMsg & vbCrLf & GetINETErrorMsg(Err.LastDllError)
        m_ErrMsg = ErrMsg
        Exit Function
    End If

    ChangeDir = 1
    
    '更改目录成功后，设置m_Dir值
    GetDirName m_Dir

End Function
'________________________________________________________________________

Private Function GetINETErrorMsg(ByVal ErrNum As Long) As String
    Dim LenError, LenBuffer As Long
    Dim Buffer As String

    '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() As Long
    Dim sServerName As String
    Dim H As Long

    '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(ByRef PathName As String, ByVal IsSlash As Byte) As Long

    AddRemFwdSlash = 0
    
    If PathName <> vbNullString Then
        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
    Else
        PathName = "/"
    End If
    AddRemFwdSlash = 1

End Function
'________________________________________________________________________

Private Function AddRemSlash&(ByRef PathName As String, ByVal IsSlash As Byte)

    AddRemSlash = 0
    
    If PathName <> vbNullString Then
        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
    Else
        PathName = "/"
    End If

    AddRemSlash = 1

End Function
'________________________________________________________________________

Private Function ClipNull(ByVal str As String) As String
    Dim Pos As Integer

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

End Function
'________________________________________________________________________

Private Function Win32ToVbTime(ft As Currency) As String
    Dim ftl As Currency
    
    If FileTimeToLocalFileTime(ft, ftl) Then
        Win32ToVbTime = FormatDateTime(CDate((ftl / rMillisecondPerDay) - rDayZeroBias))
    Else
        Win32ToVbTime = ""
        m_ErrMsg = Err.LastDllError
    End If
End Function

具体使用的案例：

新建一个窗口Form1,Form1中建一个按钮（Command_ConnectFtp）、一个 ListBox、一个标签（Label_nowpath）

Dim WinFtp As wininet_ftp  '定义WinFtp 为一个 wininet_ftp 类
Private Declare Function GetTickCount Lib "kernel32" () As Long  '获取系统时间，获得的时间是毫秒级的

Private Sub Form_Load()
    
    Set WinFtp = New wininet_ftp
End Sub

Private Sub Command_ConnectFtp_Click() '连接FTP服务器
    Dim T1 As Long
    Dim ConnectOK As Boolean

    Screen.MousePointer = vbHourglass

    '先断开原先有的FTP连接
    WinFtp.Disconnect
    '设置FTP服务器
    WinFtp.Host = Text1.Text: WinFtp.Port = Text2.Text: 
    WinFtp.User = Text3.Text: WinFtp.Password = Text4.Text
    ConnectOK = False
    '连接服务器3次，3次都失败再判定为失败
    T1 = GetTickCount()
    For i = 1 To 3
        If GetTickCount() - T1 > 4000 Then '超过4秒还是连接不上，终止后面连接
            ConnectOK = False
            Exit For
        End If
        If WinFtp.Connect() = 1 Then
            ConnectOK = True
            Exit For
        End If
    Next
    
    If ConnectOK = False Then
        MsgBox "FTP连接失败" & vbCrLf & WinFtp.ErrMsg, vbOKOnly, "提示"
        Command2.Enabled = True
        Screen.MousePointer = vbDefault
        Exit Sub
    End If
    
    ReflashList1

    Screen.MousePointer = vbDefault

End Sub

Private Sub ReflashList1()
    Dim Files() As String
    Dim NowPath As String
    Dim i As Integer
    
    If WinFtp.IsConnected() Then
        List1.Clear
        Files = WinFtp.GetDirListing()
        NowPath = WinFtp.Directory
        If Trim(NowPath) <> "/" Then List1.AddItem "[..]"
        Label_nowpath.Caption = NowPath
        
        For i = 0 To UBound(Files, 1)
            If Files(i, 1) = "path" And Files(i, 0) <> "." And Files(i, 0) <> ".." And Files(i, 0) <> "#recycle" Then List1.AddItem "[" & Files(i, 0) & "]"
        Next
        For i = 0 To UBound(Files, 1)
            If Files(i, 1) = "file"  Then
                List1.AddItem Files(i, 0)
            End If
        Next
    End If
End Sub