How do I FTP files to a remote server in MS Access

Option Explicit

' Set Constants
Const FTP_TRANSFER_TYPE_ASCII = &H1
Const FTP_TRANSFER_TYPE_BINARY = &H2
Const INTERNET_DEFAULT_FTP_PORT = 21
Const INTERNET_DEFAULT_HTTP_PORT = 80
Const INTERNET_SERVICE_FTP = 1
Const INTERNET_SERVICE_HTTP = 80
Const INTERNET_FLAG_PASSIVE = &H8000000
Const GENERIC_WRITE = &H40000000
Const GENERIC_READ = &H80000000
Const BUFFER_SIZE = 300
Const PassiveConnection As Boolean = True
Const MAX_PATH = 260

Public Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type

Public 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 * 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 FtpGetFileSize Lib "wininet.dll" _
(ByVal hFile As Long, ByRef lpdwFileSizeHigh As Long) As Long
   
Public Declare Function InternetWriteFile Lib "wininet.dll" _
(ByVal hFile As Long, ByRef sBuffer As Byte, ByVal lNumBytesToWite As Long, _
dwNumberOfBytesWritten As Long) As Integer

Declare Function InternetReadFile Lib "wininet.dll" _
(ByVal hFile As Long, ByRef sBuffer As Byte, ByVal lNumBytesToRead As Long, _
dwNumberOfBytesRead 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
      
Public Declare Function FTPCommand Lib "wininet.dll" Alias "FtpCommandA" _
    (ByVal hInet As Long, ByVal fExpectResponse As Boolean, ByVal dwFlags As Long, _
   ByVal lpszCommand As String, ByVal dwContext As Long, ByRef phFtpCommand As Long) As Boolean

Public 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 FtpRemoveDirectory Lib "wininet.dll" Alias "FtpRemoveDirectoryA" (ByVal hFtpSession As Long, _
ByVal lpszDirectory As String) As Boolean
       
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

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, Optional ByRef iCnt As Integer = 1, Optional ByRef iTot As Integer = 1) 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

' 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)

' Initialise progress meter
Retval = SysCmd(acSysCmdInitMeter, "Uploading File '" & RemoteFileName & "' - " & iCnt & " of " & iTot, (iSize / 1000))

' Loop file size
For iLoop = 1 To iSize \ BUFFER_SIZE
        
    ' Update progress meter
    Retval = SysCmd(acSysCmdUpdateMeter, ((BUFFER_SIZE * iLoop) / 1000))
        
    ' do events to enable progress meter to update
    DoEvents
    
    '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 if exists
If iSize Mod BUFFER_SIZE > 0 Then

    ' 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
               
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
Resume Exit_Function

End Function

Public 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 response info
   InternetGetLastResponseInfo lErr, sErr, lenBuf
   'show the last response info
   MsgBox "Last Server Response : " + sErr, vbOKOnly + vbCritical
End Sub
Function FTPDel(ByVal HostName As String, _
    ByVal Username As String, _
    ByVal Password As String, _
    ByVal RemoteFileName As String, _
    ByVal sDir As String) As Boolean
    
    On Error GoTo Err_Function
        
    ' Declare variables
    Dim hConnection, hOpen, hFile  As Long ' Used For Handles
    
    FTPDel = True
    
    ' 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
    FTPDel = FtpSetCurrentDirectory(hConnection, sDir)
    
    ' Delete Remote File
    FTPDel = FtpDeleteFile(hConnection, RemoteFileName)
    
Exit_FTPDel:
    
    ' Close Internet Connection
    Call InternetCloseHandle(hOpen)
    Call InternetCloseHandle(hConnection)
    
    Exit Function
    
Err_Function:
    MsgBox "Error in FTPDel : " & err.Description
    ShowError
    FTPDel = False
    Resume Exit_FTPDel

End Function
Function FTPGet(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, Optional ByRef iCnt As Integer = 1, Optional ByRef iTot As Integer = 1) 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 download
Dim iMaxSize As Long
Dim Retval As Variant ' Used for progress meter
Dim iRead As Long ' Used by InternetReadFile to report bytes downloaded
Dim iLoop As Long ' Loop for downloading chunks
Dim iFile As Integer ' Used for Local file handle
Dim FileData(BUFFER_SIZE - 1) As Byte ' buffer array of BUFFER_SIZE (300) elements 0 to 299

' 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_READ, 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
    FTPGet = False
    GoTo Exit_Function
End If

' Set Download Flag to True
FTPGet = True

' Set file size
iSize = FtpGetFileSize(hFile, iMaxSize)

' Get next file handle number
iFile = FreeFile

' Open local file
Open LocalFileName For Binary Access Write As iFile

' Initialise progress meter
Retval = SysCmd(acSysCmdInitMeter, "Downloading File '" & RemoteFileName & "' - " & iCnt & " of " & iTot, (iSize / 1000))

' Loop file size
For iLoop = 1 To iSize \ BUFFER_SIZE
        
    ' Update progress meter
    Retval = SysCmd(acSysCmdUpdateMeter, ((BUFFER_SIZE * iLoop) / 1000))

    ' do events to enable progress meter to update
    DoEvents

    ' Read chunk from FTP checking for success
    If InternetReadFile(hFile, FileData(0), BUFFER_SIZE, iRead) = 0 Then
        MsgBox "Download - Failed!"
        ShowError
        FTPGet = False
       GoTo Exit_Function
    Else
        ' Check buffer was read
        If iRead <> BUFFER_SIZE Then
            MsgBox "Download - Failed!"
            ShowError
            FTPGet = False
            GoTo Exit_Function
        End If
    End If
    
    'put file data
    Put iFile, , FileData
    
Next iLoop

' Handle remainder using MOD if exists
If iSize Mod BUFFER_SIZE > 0 Then

    ' Update progress meter
    Retval = SysCmd(acSysCmdUpdateMeter, (iSize / 1000))
    
    ' Write remainder to file checking for success
    If InternetReadFile(hFile, FileData(0), iSize Mod BUFFER_SIZE, iRead) = 0 Then
        MsgBox "Download - Failed!"
        ShowError
        FTPGet = False
        GoTo Exit_Function
    Else
        ' Check buffer was read
        If iRead <> iSize Mod BUFFER_SIZE Then
            MsgBox "Download - Failed!"
            ShowError
            FTPGet = False
            GoTo Exit_Function
        End If
    End If
               
    ' Put file data
    Put iFile, , FileData
    
End If

    
Exit_Function:

' remove progress meter
Retval = SysCmd(acSysCmdRemoveMeter)

'close local file
Close iFile

'close remote file
Call InternetCloseHandle(hFile)

' Close Internet Connection
Call InternetCloseHandle(hOpen)
Call InternetCloseHandle(hConnection)

Exit Function

Err_Function:
MsgBox "Error in FTPGet : " & err.Description
FTPGet = False
Resume Exit_Function

End Function

Function FTPList(ByVal HostName As String, ByVal Username As String, ByVal Password As String, ByVal sDir As String) As String()
    
    On Error GoTo Err_Function
    
    Dim pData As WIN32_FIND_DATA
    Dim hFind As Long, lRet As Long
    Dim hConnection, hOpen, hFile  As Long
    Dim sFiles() As String
    Dim sPath As String
    Dim sFilename As String
    
    sPath = String(MAX_PATH, 0)
    
    ' 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)

    ' get list of directory
    Call FtpGetCurrentDirectory(hConnection, sPath, Len(sPath))
    
    pData.cFileName = String(MAX_PATH, 0)
    
    'find the first file
    hFind = FtpFindFirstFile(hConnection, "*.*", pData, 0, 0)
    
    'if there are files
    If hFind <> 0 Then

        'set first file
        ReDim Preserve sFiles(0)
        
        sFilename = left(pData.cFileName, InStr(1, pData.cFileName, String(1, 0), vbBinaryCompare) - 1)
        sFiles(UBound(sFiles)) = sFilename

        Do
            'create a buffer
            pData.cFileName = String(MAX_PATH, 0)
            
            'find the next file
            lRet = InternetFindNextFile(hFind, pData)
            
            'if there's no next file, exit do
            If lRet = 0 Then Exit Do
        
            ' add index to array
            ReDim Preserve sFiles(UBound(sFiles) + 1)
            
            'add additional files
            sFilename = left(pData.cFileName, InStr(1, pData.cFileName, String(1, 0), vbBinaryCompare) - 1)
            sFiles(UBound(sFiles)) = sFilename

        Loop
        
    End If

Exit_Function:

    ' Close Internet Connection
    Call InternetCloseHandle(hOpen)
    Call InternetCloseHandle(hConnection)
    FTPList = sFiles
    Exit Function
    
Err_Function:
    MsgBox "Error in FTPList : " & err.Description
    Resume Exit_Function
    
End Function

Function FTPDelDir(ByVal HostName As String, _
    ByVal Username As String, _
    ByVal Password As String, _
    ByVal sParent As String, ByVal sDir As String) As Boolean
    
    On Error GoTo Err_Function
        
    ' Declare variables
    Dim hConnection, hOpen, hFile  As Long ' Used For Handles
    
    ' 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, sParent)
    
    ' Delete Directory
    Call FtpRemoveDirectory(hConnection, sDir)
    
    
Exit_FTPDelDir:
    ' Close Internet Connection
    Call InternetCloseHandle(hOpen)
    Call InternetCloseHandle(hConnection)
    
    FTPDelDir = True
    
    Exit Function
    
Err_Function:
    MsgBox "Error in FTPDelDir : " & err.Description
    Resume Exit_FTPDelDir

End Function

' 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",1,1) Then
    MsgBox "Upload - Complete!"
End If