通过sFTP＆amp;上传VBA FTP，日志输出以检测错误

时间：2016-02-17 13:11:51

标签： excel vba excel-vba ftp sftp

我编写了以下代码，尝试上传到两个不同的服务器，一个通过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应该将输出放入文件

2 个答案:

答案 0 :(得分：2)

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

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

此示例具有以下功能：

  • 对FTP和SFTP传输使用相同的协议（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类来代替利用对象等等。我认为这有点超出了SO的答案，但我很乐意发布是否有用。

答案 1 :(得分：1)

好了..经过一些试验和错误后我终于找到了问题，假设给定参数中的所有值都有效，问题是：

  1. 在-l（username）
    2. 之前遗漏了line 34选项
  2. 错过了hostname（line 34）
  3. sFolder未设置或空字符串（line 40） - 可能会导致问题 - 找不到文件

    4. line 34上的代码：

     sFTPDetails = "C:\psftp.exe -b C:\commands.tmp user@ex.server.com -pw password"

    正确的代码应该是：

     sFTPDetails = "C:\psftp.exe -b C:\commands.tmp -l user@ex.server.com -pw password ftp.server.com"

    由于预防可能是您可以使用前面在代码中描述的参数/变量生成命令。还有一点提示通过将直接调用<{1>}值来调试代码，以便以后可以在命令提示符下进行测试

    Cells

    如果此代码未运行，那么参数值可能有问题，要看到您可以只复制 ' UPLOAD SECOND FILE VIA SFTP 'Build up the necessary parameters sHost = "ftp.server.com" sUser = "user@server.com" sPass = "password" sSrc = """" & Environ("TEMP") & "\" + file & ".txt" & """" sDest = "/remote/folder/" sFolder = "C:" sFTP = "C:\psftp.exe" sFTPCmds2 = sFolder & "\" & "commands.tmp" sFTPDetails = sFTP & " -b " & sFTPCmds2 & " -1 " & sUser & " -pw " & sPass & " " & sHost 'FOR DEBUG Sheets(1).Cells(1,1) = sFTPDetails 'Write the FTP commands to a file iFNum = FreeFile 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")) 中的粘贴值并从命令提示符手动运行..并且不要忘记注释掉{调试之前{1}}所以文件不需要删除

相关问题
最新问题