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
