用WinINet Api 开发FTP客户端

网搜的

Option Explicit

Public Const MAX_PATH = 260                            ' 是由MFC定义的不要更改

Public Const INTERNET_OPEN_TYPE_PRECONFIG = 0
Public Const INTERNET_OPEN_TYPE_DIRECT = 1
Public Const INTERNET_OPEN_TYPE_PROXY = 3

Public Const INTERNET_INVALID_PORT_NUMBER = 0

Public Const INTERNET_FLAG_PASSIVE = &H8000000          ' 被动模式
Public Const INTERNET_FLAG_PORT = &O0                   ' 主动模式

Public Const INTERNET_SERVICE_FTP = 1
Public Const INTERNET_SERVICE_GOPHER = 2
Public Const INTERNET_SERVICE_HTTP = 3

Public Const ERROR_NO_MORE_FILES = 18

Public Const FTP_TRANSFER_TYPE_ASCII = &H1
Public Const FTP_TRANSFER_TYPE_BINARY = &H1

Public Const INTERNET_FLAG_RELOAD = &H80000000
Public Const INTERNET_FLAG_KEEP_CONNECTION = &H400000
Public Const INTERNET_FLAG_MULTIPART = &H200000

Type FILETIME
        dwLowDateTime As Long
        dwHighDateTime As Long
End Type

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 * MAX_PATH
        cAlternate As String * 16                            ' 是由MFC定义的不要更改
End Type

' 连接和初始化
' **********************************************************************************************************
Public 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

Public 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

Public Declare Function InternetCloseHandle Lib "wininet.dll" _
    (ByVal hInet As Long) As Integer


' Ftp目录操作命令
' **********************************************************************************************************
Public Declare Function FtpGetCurrentDirectory Lib "wininet.dll" Alias "FtpGetCurrentDirectoryA" _
    (ByVal hFtpSession As Long, lpszCurrentDirectory As String, ByRef lpdwCurrentDirectory As Long) As Boolean

Public Declare Function FtpSetCurrentDirectory Lib "wininet.dll" Alias "FtpSetCurrentDirectoryA" _
    (ByVal hFtpSession As Long, ByVal lpszCurrentDirectory As String) As Boolean

Public Declare Function FtpCreateDirectory Lib "wininet.dll" Alias "FtpCreateDirectoryA" _
    (ByVal hFtpSession As Long, ByVal lpszDirectory As String) As Boolean
    
Public Declare Function FtpRemoveDirectory Lib "wininet.dll" Alias "FtpRemoveDirectoryA" _
    (ByVal hFtpSession As Long, ByVal lpszDirectory As String) As Boolean

' Ftp文件操作命令
' **********************************************************************************************************
' 查找文件或目录
Public 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
' 查找下一个文件或目录
Public Declare Function InternetFindNextFile Lib "wininet.dll" Alias "InternetFindNextFileA" _
    (ByVal hFind As Long, lpvFindData As WIN32_FIND_DATA) As Long
' 下载文件
Public 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
' 上传文件
Public 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
' 删除文件
Public Declare Function FtpDeleteFile Lib "wininet.dll" _
    Alias "FtpDeleteFileA" (ByVal hFtpSession As Long, _
    ByVal lpszFileName As String) As Boolean
' 文件改名
Public Declare Function FtpRenameFile Lib "wininet.dll" _
    Alias "FtpRenameFileA" (ByVal hFtpSession As Long, _
    ByVal lpszExisting As String, ByVal lpszNew As String) As Boolean


Public Sub main()

    On Error GoTo Ftp_Err

    Dim bActiveSession As Boolean                       ' 用于标记当前是否有活动会话
    Dim hOpen As Long                                   ' 用于保存当前会话的句柄
    Dim hConnection As Long                             ' 用于保存活动连接的句柄
    Dim EnumItemNameBag As New Collection               ' 用于保存Ftp目录结构
    Dim EnumItemAttributeBag As New Collection

    ' 开始 FTP 会话。
    hOpen = InternetOpen("VB Wininet", INTERNET_OPEN_TYPE_DIRECT, vbNullString, vbNullString, 0)
    If hOpen = 0 Then
        ErrorOut Err.LastDllError, "InternetOpen"
        GoTo Exit_Sub
    End If
    
    ' 连接到 FTP 服务器。
    Dim strServer As String, strUser As String, strPassword As String
    Dim nFlag As Long
    strServer = "127.0.0.1"
    strUser = "test"
    strPassword = "test"
    nFlag = INTERNET_FLAG_PASSIVE
    
    hConnection = InternetConnect(hOpen, strServer, INTERNET_INVALID_PORT_NUMBER, _
        strUser, strPassword, INTERNET_SERVICE_FTP, nFlag, 0)
    If hConnection = 0 Then
        ErrorOut Err.LastDllError, "InternetConnect"
        GoTo Exit_Sub
    End If
    bActiveSession = True
    
    ' 更改为服务器上新的 FTP 目录。
    Dim strRemoteFolder As String
    Dim bRet As Boolean
    strRemoteFolder = "/"
    bRet = FtpSetCurrentDirectory(hConnection, strRemoteFolder)
    If bRet = False Then
        ErrorOut Err.LastDllError, "FtpPutFile"
        GoTo Exit_Sub
    End If
    
    ' 检查目录是否存在
    Dim pData As WIN32_FIND_DATA
    Dim hFind As Long, nLastError As Long
    strRemoteFolder = "test"
    pData.cFileName = String(MAX_PATH, 0)
    hFind = FtpFindFirstFile(hConnection, strRemoteFolder, pData, 0, 0)     ' 查找第一个文件或目录
    If hFind = 0 Then
        ' 没有找到
        Err.Clear
        
        ' 创建目录
        bRet = FtpCreateDirectory(hConnection, strRemoteFolder)
        If bRet = False Then
            ErrorOut Err.LastDllError, "FtpPutFile"
            GoTo Exit_Sub
        End If
        
    Else
        ' 已经存在
    End If
    
    ' 改变目录
    strRemoteFolder = "test"                    ' 使用相对目录和绝对目录都可以
    bRet = FtpSetCurrentDirectory(hConnection, strRemoteFolder)
    If bRet = False Then
        ErrorOut Err.LastDllError, "FtpPutFile"
        GoTo Exit_Sub
    End If
    
    strRemoteFolder = ".."                    ' 使用相对目录和绝对目录都可以
    bRet = FtpSetCurrentDirectory(hConnection, strRemoteFolder)
    If bRet = False Then
        ErrorOut Err.LastDllError, "FtpPutFile"
        GoTo Exit_Sub
    End If
    
    ' 目录改名
    ' Dim strNewFolder As String
    ' strNewFolder = "TTT"
    ' bRet = FtpRenameFile(hConnection, strRemoteFolder, strNewFolder)
    ' If bRet = False Then
    '     ErrorOut Err.LastDllError, "FtpRenameFile"
    '     GoTo Exit_Sub
    ' End If
    
    ' 删除目录
    strRemoteFolder = "test"
    bRet = FtpRemoveDirectory(hConnection, strRemoteFolder)
    If bRet = False Then
        ErrorOut Err.LastDllError, "FtpRemoveDirectory"
        GoTo Exit_Sub
    End If
    
    ' 获取 FTP 当前目录内容
    Dim strItem As String
    hFind = FtpFindFirstFile(hConnection, "", pData, 0, 0)     ' 查找第一个文件或目录
    nLastError = Err.LastDllError                                 ' 没有错误返回0
    If hFind = 0 Then
        If (nLastError = ERROR_NO_MORE_FILES) Then
            MsgBox "This directory is empty!"
        Else
            ErrorOut nLastError, "FtpFindFirstFile"
        End If
        GoTo Exit_Sub
    End If
    strItem = Left(pData.cFileName, InStr(1, pData.cFileName, String(1, 0)))
    EnumItemNameBag.Add strItem
    
    ' 查找 FTP 目录中的下一个文件。
    If hFind <> 0 Then bRet = True
    Do While bRet
        bRet = InternetFindNextFile(hFind, pData)
        If bRet Then
            strItem = Left(pData.cFileName, InStr(1, pData.cFileName, String(1, 0)))
            EnumItemNameBag.Add strItem
        End If
    Loop
    
    ' 上传文件
    Dim strFileLocal As String, strFileRemote As String, dwType As Long
    dwType = FTP_TRANSFER_TYPE_ASCII
    strFileLocal = "d:\ftpTest.rar"
    strFileRemote = "ftpTest.rar"
    bRet = FtpPutFile(hConnection, strFileLocal, strFileRemote, dwType, 0)
    If bRet = False Then
        ErrorOut Err.LastDllError, "FtpPutFile"
        GoTo Exit_Sub
    End If
    
    ' 下载文件
    strFileLocal = "c:\ftpTest.rar"
    strFileRemote = "ftpTest.rar"
    bRet = FtpGetFile(hConnection, strFileRemote, strFileLocal, False, _
        INTERNET_FLAG_RELOAD, dwType, 0)
    If bRet = False Then
        ErrorOut Err.LastDllError, "FtpGetFile"
        GoTo Exit_Sub
    End If
    
    ' 文件改名
    Dim strNewFile As String
    strNewFile = "TTT.rar"
    bRet = FtpRenameFile(hConnection, strFileRemote, strNewFile)
    If bRet = False Then
        ErrorOut Err.LastDllError, "FtpRenameFile"
        GoTo Exit_Sub
    End If
    
    ' 删除文件
    bRet = FtpDeleteFile(hConnection, strNewFile)
    If bRet = False Then
        ErrorOut Err.LastDllError, "FtpRemoveDirectory"
        GoTo Exit_Sub
    End If
   
Exit_Sub:
    ' 结束 FTP 会话。
    If hConnection <> 0 Then InternetCloseHandle hConnection
    hConnection = 0
    bActiveSession = False
    Exit Sub
Ftp_Err:
    MsgBox Err.LastDllError, vbCritical, "Test Ftp Client by WinInet.dll"
    GoTo Exit_Sub
End Sub

Function ErrorOut(dError As Long, szCallFunction As String)
    Dim strErrInf As String
    Select Case dError
        Case 12014
            strErrInf = "用户名或密码错"
        Case 12007
            strErrInf = ""
        Case 12003
            strErrInf = "目录操作错误"
        Case 12110
            strErrInf = "文件不存在"
    End Select
    
    MsgBox "错误编号:" & Str(dError) & vbCrLf & vbCrLf & strErrInf & vbCrLf & vbCrLf & szCallFunction, vbCritical, "WinINet FTP Client"
    Err.Clear
    
End Function