[VBA] FTP Upload And Download

https://github.com/walter426/VbaUtilities/blob/master/FileSysUtilities.bas

20140813:
- Add Error handling

20130905:
- Fix the current directory of the window shell is changed to the local ftp directory after ftp download/upload.

20130807:
- Fix do not delete temp files in FTPDownload
- Add Optional argument "Delay" to set a guard time after upload/download as the there are some cases that some files are still being transferred  after the ftp commands had been finished even the the shell command is set to do waiting.

Below code are modified from internet with proper variable declration for use in VBA.

Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

'Ftp upload file
Public Function FTPUpload(Site, sUsername, sPassword, sLocalFile, sRemotePath, Optional Delay As Integer = 1000) As String
    On Error GoTo Err_FTPUpload

    Dim FailedReason As String
    
    Dim oFTPScriptFSO As Object
    Dim oFTPScriptShell As Object
    
    Set oFTPScriptFSO = CreateObject("Scripting.FileSystemObject")
    Set oFTPScriptShell = CreateObject("WScript.Shell")
    
    sRemotePath = Trim(sRemotePath)
    sLocalFile = Trim(sLocalFile)
    
    
    '----------Path Checks---------
    'Here we willcheck the path, if it contains
    'spaces then we need to add quotes to ensure
    'it parses correctly.
    If InStr(sRemotePath, " ") > 0 Then
        If Left(sRemotePath, 1) <> """" And Right(sRemotePath, 1) <> """" Then
            sRemotePath = """" & sRemotePath & """"
        End If
    End If
    
    If InStr(sLocalFile, " ") > 0 Then
        If Left(sLocalFile, 1) <> """" And Right(sLocalFile, 1) <> """" Then
            sLocalFile = """" & sLocalFile & """"
        End If
    End If
    
    
    'Check to ensure that a remote path was
    'passed. If it's blank then pass a "\"
    If Len(sRemotePath) = 0 Then
        'Please note that no premptive checking of the
        'remote path is done. If it does not exist for some
        'reason. Unexpected results may occur.
        sRemotePath = "\"
    End If
    
    
    'Check the local path and file to ensure
    'that either the a file that exists was
    'passed or a wildcard was passed.
    If InStr(sLocalFile, "*") Then
        If InStr(sLocalFile, " ") Then
            FailedReason = "Error: Wildcard uploads do not work if the path contains a space." & vbCrLf
            FailedReason = FailedReason & "This is a limitation of the Microsoft FTP client."
            
            GoTo Exit_FTPUpload
        End If
        
    ElseIf Len(sLocalFile) = 0 Or Not oFTPScriptFSO.FileExists(sLocalFile) Then
        'nothing to upload
        FailedReason = "Error: File Not Found."
        GoTo Exit_FTPUpload
        
    End If
    '--------END Path Checks---------
    
    
    'build input file for ftp command
    Dim sFTPScript As String
    
    sFTPScript = sFTPScript & "USER " & sUsername & vbCrLf
    sFTPScript = sFTPScript & sPassword & vbCrLf
    sFTPScript = sFTPScript & "cd " & sRemotePath & vbCrLf
    sFTPScript = sFTPScript & "binary" & vbCrLf
    sFTPScript = sFTPScript & "prompt n" & vbCrLf
    sFTPScript = sFTPScript & "put " & sLocalFile & vbCrLf
    sFTPScript = sFTPScript & "quit" & vbCrLf & "quit" & vbCrLf & "quit" & vbCrLf
    
    
    Dim sFTPTemp As String
    Dim sFTPTempFile As String
    Dim sFTPResults As String
    
    sFTPTemp = oFTPScriptShell.ExpandEnvironmentStrings("%TEMP%")
    sFTPTempFile = sFTPTemp & "\" & oFTPScriptFSO.GetTempName
    sFTPResults = sFTPTemp & "\" & oFTPScriptFSO.GetTempName
    
    
    'Write the input file for the ftp command
    'to a temporary file.
    Dim fFTPScript As Object
    Set fFTPScript = oFTPScriptFSO.CreateTextFile(sFTPTempFile, True)
    
    fFTPScript.WriteLine (sFTPScript)
    fFTPScript.Close
    
    Set fFTPScript = Nothing
    
    oFTPScriptShell.Run "%comspec% /c FTP -n -s:" & sFTPTempFile & " " & Site & " > " & sFTPResults, 0, True
    Sleep Delay
    
    
    'Check results of transfer.
    Dim fFTPResults As Object
    Dim sResults As String
    
    Const OpenAsDefault = -2
    Const FailIfNotExist = 0
    Const ForReading = 1
    Const ForWriting = 2

    Set fFTPResults = oFTPScriptFSO.OpenTextFile(sFTPResults, ForReading, FailIfNotExist, OpenAsDefault)
    sResults = fFTPResults.ReadAll
    fFTPResults.Close
    
    
    If InStr(sResults, "226 Transfer complete.") > 0 Then
        FailedReason = ""
    ElseIf InStr(sResults, "File not found") > 0 Then
        FailedReason = "Error: File Not Found"
    ElseIf InStr(sResults, "cannot log in.") > 0 Then
        FailedReason = "Error: Login Failed."
    Else
        FailedReason = "Error: Unknown."
    End If
    
    
    oFTPScriptFSO.DeleteFile (sFTPTempFile)
    oFTPScriptFSO.DeleteFile (sFTPResults)
    
    Set oFTPScriptFSO = Nothing
    
    oFTPScriptShell.CurrentDirectory = sOriginalWorkingDirectory
    Set oFTPScriptShell = Nothing
    
    
Exit_FTPUpload:
    FTPUpload = FailedReason
    Exit Function
    
Err_FTPUpload:
    FailedReason = Err.Description
    Resume Exit_FTPDownload
    
End Function

'Ftp download file
Function FTPDownload(Site, sUsername, sPassword, sLocalPath, sRemotePath, sRemoteFile, Optional Delay As Integer = 1000) As String
    On Error GoTo Err_FTPDownload
    
    Dim FailedReason As String
    
    Dim oFTPScriptFSO As Object
    Dim oFTPScriptShell As Object
    
    Set oFTPScriptFSO = CreateObject("Scripting.FileSystemObject")
    Set oFTPScriptShell = CreateObject("WScript.Shell")
    
    
    sRemotePath = Trim(sRemotePath)
    sLocalPath = Trim(sLocalPath)
    
    '----------Path Checks---------
    If InStr(sRemotePath, " ") > 0 Then
        If Left(sRemotePath, 1) <> """" And Right(sRemotePath, 1) <> """" Then
            sRemotePath = """" & sRemotePath & """"
        End If
    End If
    
    
    If Len(sRemotePath) = 0 Then
        sRemotePath = "\"
    End If
    
    
    'If the local path was blank. Pass the current working direcory.
    If Len(sLocalPath) = 0 Then
        sLocalPath = oFTPScriptShell.CurrentDirectory
    End If
    
    
    If Not oFTPScriptFSO.FolderExists(sLocalPath) Then
        'destination not found
        FailedReason = "Error: Local Folder Not Found."
        GoTo Exit_FTPDownload
    End If
    
    
    Dim sOriginalWorkingDirectory As String
    sOriginalWorkingDirectory = oFTPScriptShell.CurrentDirectory
    oFTPScriptShell.CurrentDirectory = sLocalPath
    '--------END Path Checks---------
    
    'build input file for ftp command
    Dim sFTPScript As String
    sFTPScript = ""
    
    sFTPScript = sFTPScript & "USER " & sUsername & vbCrLf
    sFTPScript = sFTPScript & sPassword & vbCrLf
    sFTPScript = sFTPScript & "cd " & sRemotePath & vbCrLf
    sFTPScript = sFTPScript & "binary" & vbCrLf
    sFTPScript = sFTPScript & "prompt n" & vbCrLf
    sFTPScript = sFTPScript & "mget " & sRemoteFile & vbCrLf
    sFTPScript = sFTPScript & "quit" & vbCrLf & "quit" & vbCrLf & "quit" & vbCrLf
    
    
    Dim sFTPTemp As String
    Dim sFTPTempFile As String
    Dim sFTPResults As String
    
    sFTPTemp = oFTPScriptShell.ExpandEnvironmentStrings("%TEMP%")
    sFTPTempFile = sFTPTemp & "\" & oFTPScriptFSO.GetTempName
    sFTPResults = sFTPTemp & "\" & oFTPScriptFSO.GetTempName
    
    'Write the input file for the ftp command to a temporary file.
    Dim fFTPScript As Object
    Set fFTPScript = oFTPScriptFSO.CreateTextFile(sFTPTempFile, True)
    
    fFTPScript.WriteLine (sFTPScript)
    fFTPScript.Close
    
    Set fFTPScript = Nothing
    
    
    oFTPScriptShell.Run "%comspec% /c FTP -n -s:" & sFTPTempFile & " " & Site & " > " & sFTPResults, 0, True
    Sleep Delay

    
    'Check results of transfer.
    Dim fFTPResults As Object
    Dim sResults As String
    
    Const OpenAsDefault = -2
    Const FailIfNotExist = 0
    Const ForReading = 1
    Const ForWriting = 2
    
    Set fFTPResults = oFTPScriptFSO.OpenTextFile(sFTPResults, ForReading, FailIfNotExist, OpenAsDefault)
    sResults = fFTPResults.ReadAll
    fFTPResults.Close
    
    
    If InStr(sResults, "226 Transfer complete.") > 0 Then
        FailedReason = ""
    ElseIf InStr(sResults, "File not found") > 0 Then
        FailedReason = "Error: File Not Found"
    ElseIf InStr(sResults, "cannot log in.") > 0 Then
        FailedReason = "Error: Login Failed."
    Else
        FailedReason = "Error: Unknown."
    End If
    
    
    oFTPScriptFSO.DeleteFile (sFTPTempFile)
    oFTPScriptFSO.DeleteFile (sFTPResults)
    
    Set oFTPScriptFSO = Nothing
    
    oFTPScriptShell.CurrentDirectory = sOriginalWorkingDirectory
    Set oFTPScriptShell = Nothing
    
    
Exit_FTPDownload:
    FTPDownload = FailedReason
    Exit Function
    
Err_FTPDownload:
    FailedReason = Err.Description
    Resume Exit_FTPDownload
    
End Function