This code uses windows DLL to perform FTP.
Const MAX_PATH = 260
' Set Constants
Const FTP_TRANSFER_TYPE_ASCII = &H1
Const FTP_TRANSFER_TYPE_BINARY = &H2
Const INTERNET_DEFAULT_FTP_PORT = 21
Const INTERNET_SERVICE_FTP = 1
Const INTERNET_FLAG_PASSIVE = &H8000000
Const GENERIC_WRITE = &H40000000
Const BUFFER_SIZE = 100
Const PassiveConnection As Boolean = True
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 * MAX_PATH
cAlternate As String * 14
End Type
' Declare wininet.dll API Functions
Public Declare Function FtpSetCurrentDirectory Lib "wininet.dll" Alias
"FtpSetCurrentDirectoryA" _
(ByVal hFtpSession As Long, ByVal lpszDirectory As String) As Boolean
Public Declare Function FtpGetCurrentDirectory Lib "wininet.dll" Alias
"FtpGetCurrentDirectoryA" _
(ByVal hFtpSession As Long, ByVal lpszCurrentDirectory As String,
lpdwCurrentDirectory As Long) As Boolean
Public Declare Function InternetWriteFile Lib "wininet.dll" _
(ByVal hFile As Long, ByRef sBuffer As Byte, ByVal lNumBytesToWite As Long, _
dwNumberOfBytesWritten As Long) As Integer
Public 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
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 InternetCloseHandle Lib "wininet.dll" _
(ByVal hInet As Long) As Long
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 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
Declare Function InternetGetLastResponseInfo Lib "wininet.dll" _
Alias "InternetGetLastResponseInfoA" _
(ByRef lpdwError As Long, _
ByVal lpszErrorBuffer As String, _
ByRef lpdwErrorBufferLength As Long) As Boolean
Public Declare Function FtpFindFirstFile Lib "wininet.dll" Alias
"FtpFindFirstFileA" _
(ByVal hInternetSession As Long, ByVal lpszSearchFile As String, _
ByRef lpFindFileData As WIN32_FIND_DATA, ByVal dwFlags As Long, _
ByVal dwContext As Long) As Long
Public Declare Function InternetFindNextFile Lib "wininet.dll" Alias
"InternetFindNextFileA" _
(ByVal hInternetSession As Long, ByRef lpvFindData As WIN32_FIND_DATA) As Long
Function FTPFile(ByVal HostName As String, _
ByVal UserName As String, _
ByVal Password As String, _
ByVal LocalFileName As String, _
ByVal RemoteFileName As String, _
ByVal sDir As String, _
ByVal sMode As String) As Boolean
On Error GoTo Err_Function
' Declare variables
Dim hConnection, hOpen, hFile As Long ' Used For Handles
Dim iSize As Long ' Size of file for upload
Dim Retval As Variant ' Used for progress meter
Dim iWritten As Long ' Used by InternetWriteFile to report bytes uploaded
Dim iLoop As Long ' Loop for uploading chuncks
Dim iFile As Integer ' Used for Local file handle
Dim FileData(BUFFER_SIZE - 1) As Byte ' buffer array of BUFFER_SIZE (100)
elements 0 to 99
' Open Internet Connecion
hOpen = InternetOpen("FTP", 1, "", vbNullString, 0)
' Connect to FTP
hConnection = InternetConnect(hOpen, HostName, INTERNET_DEFAULT_FTP_PORT,
UserName, Password, INTERNET_SERVICE_FTP, IIf(PassiveConnection,
INTERNET_FLAG_PASSIVE, 0), 0)
' Change Directory
Call FtpSetCurrentDirectory(hConnection, sDir)
' Open Remote File
hFile = FtpOpenFile(hConnection, RemoteFileName, GENERIC_WRITE, IIf(sMode =
"Binary", FTP_TRANSFER_TYPE_BINARY, FTP_TRANSFER_TYPE_ASCII), 0)
' Check for successfull file handle
If hFile = 0 Then
MsgBox "Internet - Failed!"
ShowError
FTPFile = False
GoTo Exit_Function
End If
' Set Upload Flag to True
FTPFile = True
' Get next file handle number
iFile = FreeFile
' Open local file
Open LocalFileName For Binary Access Read As iFile
' Set file size
iSize = LOF(iFile)
' Iinitialise progress meter
Retval = SysCmd(acSysCmdInitMeter, "Uploading File (" & RemoteFileName &
")", iSize / 1000)
' Loop file size
For iLoop = 1 To iSize \ BUFFER_SIZE
' Update progress meter
Retval = SysCmd(acSysCmdUpdateMeter, (BUFFER_SIZE * iLoop) / 1000)
'Get file data
Get iFile, , FileData
' Write chunk to FTP checking for success
If InternetWriteFile(hFile, FileData(0), BUFFER_SIZE, iWritten) = 0 Then
MsgBox "Upload - Failed!"
ShowError
FTPFile = False
GoTo Exit_Function
Else
' Check buffer was written
If iWritten <> BUFFER_SIZE Then
MsgBox "Upload - Failed!"
ShowError
FTPFile = False
GoTo Exit_Function
End If
End If
Next iLoop
' Handle remainder using MOD
' Update progress meter
Retval = SysCmd(acSysCmdUpdateMeter, iSize / 1000)
' Get file data
Get iFile, , FileData
' Write remainder to FTP checking for success
If InternetWriteFile(hFile, FileData(0), iSize Mod BUFFER_SIZE,
iWritten) = 0 Then
MsgBox "Upload - Failed!"
ShowError
FTPFile = False
GoTo Exit_Function
Else
' Check buffer was written
If iWritten <> iSize Mod BUFFER_SIZE Then
MsgBox "Upload - Failed!"
ShowError
FTPFile = False
GoTo Exit_Function
End If
End If
Exit_Function:
' remove progress meter
Retval = SysCmd(acSysCmdRemoveMeter)
'close remote file
Call InternetCloseHandle(hFile)
'close local file
Close iFile
' Close Internet Connection
Call InternetCloseHandle(hOpen)
Call InternetCloseHandle(hConnection)
Exit Function
Err_Function:
MsgBox "Error in FTPFile : " & Err.Description
GoTo Exit_Function
End Function
Function FTPGetDir(ByVal HostName As String, ByVal User As String, _
ByVal PassWd As String, ByVal Folder As String)
' Declare variables
Dim hConnection, hOpen As Long ' Used For Handles
Dim lpszCurrentDirectory As String
Dim lpdwCurrentDirectory As Long
Dim lpFindFileData As WIN32_FIND_DATA
Dim hfind As Long
lpszCurrentDirectory = String(1024, Chr(0))
lpdwCurrentDirectory = 1024
' Open Internet Connecion
hOpen = InternetOpen("FTP", 1, "", vbNullString, 0)
' Connect to FTP
hConnection = InternetConnect(hOpen, HostName, INTERNET_DEFAULT_FTP_PORT,
UserName, Password, INTERNET_SERVICE_FTP, IIf(PassiveConnection,
INTERNET_FLAG_PASSIVE, 0), 0)
Status = FtpGetCurrentDirectory(hConnection, _
lpszCurrentDirectory, lpdwCurrentDirectory)
hfind = FtpFindFirstFile(hConnection, lpszCurrentDirectory, _
lpFindFileData, IIf(PassiveConnection, _
INTERNET_FLAG_PASSIVE, 0), 0)
If hfind <> 0 Then
Range("A1") = lpFindFileData.cFileName
RowCount = 2
Do While lpFindFileData.cFileName <> ""
lpFindFileData.cFileName = String(MAX_PATH, 0)
Status = InternetFindNextFile(hfind, lpFindFileData)
If Status = 0 Then
Exit Do
Else
Range("A" & RowCount) = lpFindFileData.cFileName
RowCount = RowCount + 1
End If
Loop
End If
End Function
Sub ShowError()
Dim lErr As Long, sErr As String, lenBuf As Long
'get the required buffer size
InternetGetLastResponseInfo lErr, sErr, lenBuf
'create a buffer
sErr = String(lenBuf, 0)
'retrieve the last respons info
InternetGetLastResponseInfo lErr, sErr, lenBuf
'show the last response info
MsgBox "Last Server Response : " + sErr, vbOKOnly + vbCritical
End Sub
Sub FTP()
' Upload file
If FTPFile("ftp.domain.com", "myUserName", "myPassword", "Full path and
Filename of local file", "Target Filename without path", "Directory on FTP
server", "Upload Mode - Binary or ASCII") Then
MsgBox "Upload - Complete!"
End If
End Sub
Sub test_GetDirectory()
HostName = "ftp.microsoft.com"
User = "FTP"
PassWd = "(e-mail address removed)" 'enter email account
Folder = ""
Call FTPGetDir(HostName, _
User, _
PassWd, _
Folder)
End Sub
