通过 sFTP & FTP 使用 VBA 上传，记录输出以检测错误
Upload with VBA via sFTP & FTP, log outputs to detect errors
我写了下面的代码来尝试上传到两个不同的服务器，一个通过 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 一样工作和运行。
我尝试了以下 运行s:
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 应该将输出放入文件
好的..经过反复试验，我终于找到了问题所在，假设给定参数中的所有值都有效，问题是：
- 在
username 之前缺少 -l 选项 (line 34)
- 缺少
hostname (line 34)
sFolder 未设置或空字符串 (line 40) - 可能会导致问题 - 找不到文件
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"
作为预防措施，您可以使用代码前面所述的 parameter/variable 生成命令。还有一点提示可以通过 直接将 写入 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"))
如果此代码不是 运行ning 那么参数值可能有问题，您可以从命令提示符手动复制 Sheet1!A1 和 运行 中的粘贴值..不要忘记在调试前注释掉 line 58，这样文件就不需要删除了
是否必须使用 Putty？对于 VBA 内的 FTP 操作，我建议 WinSCP。实际上有一个 .NET assembly/COM 库可用于使用 VBA 轻松实现自动化（甚至比我下面的示例更容易）。也就是说，我的公司环境禁止用户安装 .NET/COM（有充分的理由），所以我编写了自己的代码，简化如下。
要使用下面的内容，请从上面的 link 下载可移植的可执行文件，因为您需要 WinSCP.com 来编写脚本。
本例具有以下特点：
- FTP 和 SFTP 传输使用相同的协议 (WinSCP)
- 写一个精简的、机器可读的 XML 日志和全文
记录到文件
- 使用批处理文件而不是直接 Shell() 执行；这允许
您暂停代码（或注释掉最终的 Kill 语句）以
查看原始命令和批处理文件以便于调试。
- 显示来自尝试解析 XML 的用户友好的错误消息
日志;保留 XML 和 txt 日志（没有密码数据）供以后使用
评论。
子上传 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
检查输出日志和return用户消息的功能：
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 class 来利用对象相反，还有更多。我认为这超出了 SO 答案的范围，但如果有帮助，我很高兴 post。
我写了下面的代码来尝试上传到两个不同的服务器，一个通过 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 一样工作和运行。
我尝试了以下 运行s:
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 应该将输出放入文件
好的..经过反复试验，我终于找到了问题所在，假设给定参数中的所有值都有效，问题是：
- 在
username之前缺少-l选项 (line 34) - 缺少
hostname(line 34) sFolder未设置或空字符串 (line 40) - 可能会导致问题 - 找不到文件
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"
作为预防措施，您可以使用代码前面所述的 parameter/variable 生成命令。还有一点提示可以通过 直接将 写入 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"))
如果此代码不是 运行ning 那么参数值可能有问题，您可以从命令提示符手动复制 Sheet1!A1 和 运行 中的粘贴值..不要忘记在调试前注释掉 line 58，这样文件就不需要删除了
是否必须使用 Putty？对于 VBA 内的 FTP 操作，我建议 WinSCP。实际上有一个 .NET assembly/COM 库可用于使用 VBA 轻松实现自动化（甚至比我下面的示例更容易）。也就是说，我的公司环境禁止用户安装 .NET/COM（有充分的理由），所以我编写了自己的代码，简化如下。
要使用下面的内容，请从上面的 link 下载可移植的可执行文件，因为您需要 WinSCP.com 来编写脚本。
本例具有以下特点：
- FTP 和 SFTP 传输使用相同的协议 (WinSCP)
- 写一个精简的、机器可读的 XML 日志和全文 记录到文件
- 使用批处理文件而不是直接 Shell() 执行；这允许 您暂停代码（或注释掉最终的 Kill 语句）以 查看原始命令和批处理文件以便于调试。
- 显示来自尝试解析 XML 的用户友好的错误消息 日志;保留 XML 和 txt 日志（没有密码数据）供以后使用 评论。
子上传 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
检查输出日志和return用户消息的功能：
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 class 来利用对象相反，还有更多。我认为这超出了 SO 答案的范围，但如果有帮助，我很高兴 post。