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
