vba - 通过 sFTP 和 FTP 使用 VBA 上传，记录输出以检测错误

Question

我编写了以下代码来尝试上传到两个不同的服务器，一个通过 ftp，另一个通过 sftp。

我想知道是否有更好的方法通过 SFTP 上传，因为我当前的方法如果任何部分失败都不会触发 FTP 错误。

我想一个解决办法，我想要的就是让他们两个将输出记录到一个文本文件中，然后从中我可以手动查看错误是什么，如果我想设置一个简单的读取日志，检查错误，如果 x 执行 y...

        On Error GoTo Err_FTPFile

        ' UPLOAD FIRST FILE VIA FTP

        'Build up the necessary parameters
        sHost = "ftp.server.com"
        sUser = "user@server.com"
        sPass = "password"
        sSrc = """" + Environ("TEMP") + "\" + file + ".txt" + """"
        sDest = "/remote/folder/"

        'Write the FTP commands to a file
        iFNum = FreeFile
        sFTPCmds1 = Environ("TEMP") & "\" & "FTPCmd1.tmp"
        Open sFTPCmds1 For Output As #iFNum
            Print #iFNum, "ftp"
            Print #iFNum, "open " & sHost
            Print #iFNum, sUser
            Print #iFNum, sPass
            Print #iFNum, "cd " & sDest
            Print #iFNum, "put " & sSrc
            Print #iFNum, "disconnect"
            Print #iFNum, "bye"
        Close #iFNum

        'Upload the file
        Shell Environ("WINDIR") & "\System32\ftp.exe -s:" & sFTPCmds1
        Application.Wait (Now + TimeValue("0:00:10"))


        ' UPLOAD SECOND FILE VIA SFTP

        'Build up the necessary parameters
        sFTPDetails = "C:\psftp.exe -b C:\commands.tmp user@ex.server.com -pw password"
        sSrc = """" + Environ("TEMP") + "\" + file + ".txt" + """"
        sDest = "/remote/folder/"

        'Write the FTP commands to a file
        iFNum = FreeFile
        sFTPCmds2 = sFolder & "\" & "commands.tmp"
        Open sFTPCmds2 For Output As #iFNum
            Print #iFNum, "cd " & sDest
            Print #iFNum, "put " & sSrc
            Print #iFNum, "quit"
            Print #iFNum, "bye"
        Close #iFNum

        'Upload the file
        Call Shell(sFTPDetails, vbNormalFocus)
        Application.Wait (Now + TimeValue("0:00:10"))

Exit_FTPFile:
        On Error Resume Next
        Close #iFNum

        'Delete the temp FTP command file
        Kill sFTPCmds1
        Kill sFTPCmds2
        Kill Environ("TEMP") + file + ".txt"

        GoTo ContinuePoint

Err_FTPFile:
        Shell "C:\FailPushBullet.exe"
        MsgBox Err.Number & " - " & Err.Description & " Failed.", vbOKOnly, "Error"
        GoTo ContinuePoint

ContinuePoint:
' Do stuff

我理想地希望底部的 SFTP 能够像上面的 FTP 一样工作和运行。

我尝试了以下操作并且运行:

    sClient = "C:\psftp.exe"
    sArgs = "user@website.com -pw passexample -b C:\commands.tmp"
    sFull = sClient & " " & sArgs

    sSrc = """" + Environ("TEMP") + "\" + "test" + ".txt" + """"
    sDest = "folder"

    'Write the FTP commands to a text file
    iFNum = FreeFile
    sFTPCmds = "C:\" & "commands.tmp"
    Open sFTPCmds For Output As #iFNum
        Print #iFNum, "cd " & sDest
        Print #iFNum, "put " & sSrc
        Print #iFNum, "quit"
        Print #iFNum, "bye"
    Close #iFNum

    'Upload the file
    Call Shell(sFull, vbNormalFocus)

但是如果我将 sArgs 更改为 sArgs = "user@website.com -pw passexample -b C:\commands.tmp 1> log.txt" 它不会运行，它只是关闭而不执行任何操作。我认为 1> log.txt 应该将输出放入文件

Answer 1

是否需要使用 Putty？我推荐WinSCP用于 VBA 中的 FTP 操作。实际上有一个 .NET 程序集/COM 库可用于使用 VBA 轻松实现自动化(甚至比我下面的示例更容易)。也就是说，我的公司环境禁止用户安装 .NET/COM(有充分的理由)，因此我编写了自己的代码，简化如下。

要使用下面的内容，请从上面的链接下载可移植可执行文件，因为您需要 WinSCP.com 来编写脚本。

此示例具有以下功能:

• 对 FTP 和 SFTP 传输使用相同的协议(protocol) (WinSCP)
• 写入压缩的、机器可读的 XML 日志以及全文记录到文件
• 使用批处理文件而不是直接执行 Shell()；这允许您暂停代码(或注释掉最后的 Kill 语句)以查看原始命令和批处理文件，方便调试。
• 在尝试解析 XML 时显示一条用户友好的错误消息日志;保留 XML 和 txt 日志(没有密码数据)供以后使用审查。

Sub上传FTP和SFTP数据:

Public Sub FTPUpload()
'Execute the upload commands

'Create the commands file
Dim ObjFSO As Object
Dim ObjFile As Object
Dim ObjShell As Object
Dim ErrorCode As Integer
Dim sTempDir As String
Dim sType As String
Dim sUser As String
Dim sPass As String
Dim sServer As String
Dim sHostKey As String
Dim file As String 'Using your variable name here.
Dim sLocal As String
Dim sRemote As String
Dim sWinSCP As String

''''''''''''''''''''''''''''''''''''''''''''
'Set FTP Options
''''''''''''''''''''''''''''''''''''''''''''
sTempDir = Environ("TEMP") & "\" 'Log/batch files will be stored here.
sType = "ftp://" 'Or use "sftp://"
sUser = "user"
sPass = "password"
file = "example.txt" 'Assuming you will set this earlier in your code
sServer = "ftp.server.com"
sLocal = Chr(34) & Environ("TEMP") & "\" & file & Chr(34) 'Note that I included the full filename in the file variable; change this as necessary.
sRemote = "/remote/folder"
sWinSCP = "C:\Path\To\WinSCP\WinSCP.com"
'''''''''''''''''''''''''''''''''''''''''''''

'''''''''''''''''''''''''''''''''''''''''''''
'Create batch file and command script
'''''''''''''''''''''''''''''''''''''''''''''
On Error Resume Next
'Delete existing files
Kill sTempDir & "winscp.txt"
Kill sTempDir & "winscp.bat"
Kill sTempDir & "winscplog.xml"
Kill sTempDir & "winscplog.txt"
On Error GoTo 0

Set ObjFSO = CreateObject("Scripting.FileSystemObject")
Set ObjFile = ObjFSO.CreateTextFile(sTempDir & "winscp.txt", True)
ObjFile.writeline "open " & sType & sUser & ":" & sPass & "@" & sServer & "/" & IIf(sHostKey <> vbNullString, " -hostkey=" & Chr(34) & sHostKey & Chr(34), vbNullString)
ObjFile.writeline "put " & sLocal & " " & sRemote
ObjFile.writeline "close"
ObjFile.writeline "exit"
ObjFile.Close
Set ObjFile = Nothing
Set ObjFile = ObjFSO.CreateTextFile(sTempDir & "\winscp.bat", True)
ObjFile.writeline sWinSCP & " /script=" & sTempDir & "winscp.txt /xmllog=" & sTempDir & "winscplog.xml /log=" & sTempDir & "winscplog.txt"
ObjFile.Close
Set ObjFile = Nothing
Set ObjFSO = Nothing
'''''''''''''''''''''''''''''''''''''''''''''

'''''''''''''''''''''''''''''''''''''''''''''
'Execute batch file and process output log
'''''''''''''''''''''''''''''''''''''''''''''
Set ObjShell = VBA.CreateObject("WScript.Shell")
ErrorCode = ObjShell.Run(sTempDir & "\winscp.bat", 0, True)
Set ObjShell = Nothing
If CheckOutput(sTempDir) <> "All FTP operations completed successfully." Then
    MsgBox CheckOutput(sTempDir)
ElseIf ErrorCode > 0 Then
    MsgBox "Excel encountered an error when attempting to run the FTP program. Error code: " & ErrorCode
Else
    MsgBox "All FTP operations completed successfully."
End If
'''''''''''''''''''''''''''''''''''''''''''''

'Done with the FTP transfer. If you want to SFTP transfer immediately thereafter, use the below code
''''''''''''''''''''''''''''''''''''''''''''
'Re-set FTP Options
''''''''''''''''''''''''''''''''''''''''''''
sType = "sftp://"
'sHostKey = "ssh-rsa 1024 9d:d9:e9:69:db:cf:9c:71:8d:cb:da:a5:cf:a7:41:a7" 'Set this if you have a hostkey that should be auto-accepted
'I assume all other options are the same, but you can change user, password, server, etc. here as well. 
'Note that all code from here down is exactly the same as above; only the options have changed.
''''''''''''''''''''''''''''''''''''''''''''

'''''''''''''''''''''''''''''''''''''''''''''
'Create batch file and command script
'''''''''''''''''''''''''''''''''''''''''''''
On Error Resume Next
'Delete existing files
Kill sTempDir & "winscp.txt"
Kill sTempDir & "winscp.bat"
Kill sTempDir & "winscplog.xml"
Kill sTempDir & "winscplog.txt"
On Error GoTo 0

Set ObjFSO = CreateObject("Scripting.FileSystemObject")
Set ObjFile = ObjFSO.CreateTextFile(sTempDir & "winscp.txt", True)
ObjFile.writeline "open " & sType & sUser & ":" & sPass & "@" & sServer & "/" & IIf(sHostKey <> vbNullString, " -hostkey=" & Chr(34) & sHostKey & Chr(34), vbNullString)
ObjFile.writeline "put " & sLocal & " " & sRemote
ObjFile.writeline "close"
ObjFile.writeline "exit"
ObjFile.Close
Set ObjFile = Nothing
Set ObjFile = ObjFSO.CreateTextFile(sTempDir & "\winscp.bat", True)
ObjFile.writeline sWinSCP & " /script=" & sTempDir & "winscp.txt /xmllog=" & sTempDir & "winscplog.xml /log=" & sTempDir & "winscplog.txt"
ObjFile.Close
Set ObjFile = Nothing
Set ObjFSO = Nothing
'''''''''''''''''''''''''''''''''''''''''''''

'''''''''''''''''''''''''''''''''''''''''''''
'Execute batch file and process output log
'''''''''''''''''''''''''''''''''''''''''''''
Set ObjShell = VBA.CreateObject("WScript.Shell")
ErrorCode = ObjShell.Run(sTempDir & "\winscp.bat", 0, True)
Set ObjShell = Nothing
If CheckOutput(sTempDir) <> "All FTP operations completed successfully." Then
    MsgBox CheckOutput(sTempDir)
ElseIf ErrorCode > 0 Then
    MsgBox "Excel encountered an error when attempting to run the FTP program. Error code: " & ErrorCode
Else
    MsgBox "All FTP operations completed successfully."
End If
'''''''''''''''''''''''''''''''''''''''''''''

Exit_Upload:
    On Error Resume Next
    'Clean up (leave log files)
    Kill sTempDir & "winscp.txt" 'Remove scripting commands (note: this file will contain the password)
    Kill sTempDir & "winscp.bat" 'Remove batch file
    'Clear all objects
    Set ObjFSO = Nothing
    Set ObjFile = Nothing
    Set ObjShell = Nothing
    Exit Sub

End Sub

检查输出日志并为用户返回消息的函数:

Private Function CheckOutput(sLogDir As String) As String

Dim ObjFSO As Object
Dim ObjFile As Object
Dim StrLog As String

'Open log file
Set ObjFSO = CreateObject("Scripting.FileSystemObject")
Set ObjFile = ObjFSO.OpenTextFile(sLogDir & "winscplog.xml")
StrLog = ObjFile.readall
ObjFile.Close
Set ObjFile = Nothing
Set ObjFSO = Nothing

'Check log file for issues
If InStr(1, StrLog, "<message>Authentication failed.</message>") > 0 Then
    CheckOutput = "The supplied password was rejected by the server. Please try again."
ElseIf InStr(1, StrLog, "<failure>") Then
    If InStr(1, StrLog, "<message>Can't get attributes of file") > 0 Then
        CheckOutput = "The requested file does not exist on the FTP server or local folder."
    Else
        CheckOutput = "One or more attempted FTP operations has failed."
    End If
ElseIf InStr(1, StrLog, " <result success=" & Chr(34) & "false" & Chr(34)) > 0 Then
    CheckOutput = "One or more attempted FTP operations has failed."
ElseIf InStr(1, StrLog, " <result success=" & Chr(34) & "true" & Chr(34)) = 0 Then
    CheckOutput = "No FTP operations were performed. This may indicate that no files matching the file mask were found."
End If

'Enter success message or append log file details.
If CheckOutput = vbNullString Then
    CheckOutput = "All FTP operations completed successfully."
Else
    CheckOutput = CheckOutput & vbLf & vbLf & "Please see the below files for additional information. Note that passwords are not logged for security reasons." & _
    vbLf & "Condensed log: " & sLogDir & "winscplog.xml" & vbLf & "Complete log: " & sLogDir & "winscplog.txt"
End If

Exit_CheckOutput:
On Error Resume Next
Set ObjFile = Nothing
Set ObjFSO = Nothing
Exit Function

End Function

注意:我使用的实际代码要详细得多，因为它允许比上传更多的 (S)FTP 操作，使用 FTP 类来利用对象，等等。我认为这有点超出了答案的范围，但如果有帮助，我很乐意发布。