在公司，经常使用FTP上传文件给不同部门的同事。
用软件上传，虽然可以保存连接的站点在书签上，方便操作。但数据量一大，用鼠标点击十分麻烦。还无法判断文件是否上传成功。
于是用VBA写了一个批量上传的模版，除了能批量上传文件，还可以检测文件是否上传成功。
曾经试过使用系统自带的FTP命令，发现无法设置传输的模式为被动。所以借用了WinSCP这个软件，用 shell调用命令行来实现批理上传。
代码如下，感兴趣的可以直接下载压缩包（里面包含WinSCP软件），直接使用模版
Sub wsUpFile()
Dim myWs As String, myDat As String, myLog As String, myPath As String
Dim tmp As String
Dim t, arr, brr, crr
Dim lrow As Integer, n As Integer, i As Integer, j As Integer
Dim Stm, dic, ddd, bjShell
Application.ScreenUpdating = False
myWs = ThisWorkbook.Path & "\WinSCP\WinSCP.exe" '软件位置
myIni = Replace(myWs, ".exe", ".ini")
myPath = Replace(myWs, "\WinSCP.exe", "")
If Dir(myWs) = "" Then MsgBox "找不到软件，请在软件位置！": Exit Sub
myWs = Chr(34) & myWs & Chr(34) '加双引号
Range("I:XX").Clear
myDat = myPath & "\example.txt" '脚本
myLog = myPath & "\log_file.txt" '日志
If Dir(myDat) <> "" Then Kill myDat '删除脚本
If Dir(myLog) <> "" Then Kill myLog '删除日志
lrow = Cells(Rows.Count, 1).End(3).Row
If lrow <= 1 Then MsgBox "找不到上传文件，请在A列输入文件！": Exit Sub
arr = Range("A1:A" & lrow)
lrow = Cells(Rows.Count, 4).End(3).Row
If lrow <= 1 Then MsgBox "找不到位置，请在D列输入文件！": Exit Sub
brr = Range("D1").Resize(lrow, 4 + UBound(arr))
n = 0
For i = 2 To UBound(arr)
t1 = InStrRev(arr(i, 1), "\")
brr(1, 4 + i) = Right(arr(i, 1), Len(arr(i, 1)) - t1) '文件名
If Dir(arr(i, 1)) = "" And Dir(arr(i, 1), vbDirectory) = "" Then n = n + 1 '文件存在，上传
Next
If n = UBound(arr) - 1 Then MsgBox "找不到上传文件，请在A列输入文件！": Exit Sub
Set dic = CreateObject("scripting.dictionary") '区分连接
Set ddd = CreateObject("scripting.dictionary") '区分连接与目录位置
For i = 2 To UBound(brr)
tmp = "open ftp://" & brr(i, 1) & ":" & brr(i, 2) & "@" & brr(i, 3) & ":" & brr(i, 4) '区分连接
dic(tmp) = dic(tmp) & "|" & i
For j = 6 To UBound(brr, 2)
tmp = "open ftp://" & brr(i, 1) & ":***@" & brr(i, 3) & ":" & brr(i, 4) & "||" & brr(i, 5) & "/" & brr(1, j)
ddd(tmp) = i & "|" & j '连续与目录文件位置
Next
Next
Set Stm = CreateObject("Adodb.Stream")
Stm.Open
Stm.Charset = "utf-8" '编码
Stm.writetext "option batch continue" & vbCrLf '默认批处理
Stm.writetext "option confirm off" & vbCrLf '关闭提示信息
Stm.writetext "option transfer binary" & vbCrLf '使用二进制格式传送
For Each ky In dic.keys
Stm.writetext ky & vbCrLf ' user：访问用户名 ，pwd:用户密码 ，ip:ip地址，port：端口号
t = Split(dic(ky), "|") '同连接下的各目录
For j = 1 To UBound(t)
For i = 2 To UBound(arr)
If Dir(arr(i, 1)) <> "" Or Dir(arr(i, 1), vbDirectory) <> "" Then '文件或文件夹存在，上传
Stm.writetext "put " & arr(i, 1) & " " & brr(t(j), 5) & "/" & vbCrLf '上传文件，下载用get
End If
Next
Next
Stm.writetext "Close" & vbCrLf '关闭连接
Next
Stm.writetext "exit" '退出
Stm.SaveToFile myDat
Stm.Close: Set Stm = Nothing
pscode = myWs & " /script=" & myDat & " /log=" & myLog
Set objShell = CreateObject("wscript.shell")
iReturn = objShell.Run("cmd.exe /c " & pscode, 0, True) '执行代码并隐藏窗口并等代码执行完
'检查是否上传成功
For i = 2 To UBound(brr)
For j = 6 To UBound(brr, 2)
brr(i, j) = "Q"
Next
Next
On Error Resume Next
crr = Split(FileArr(myLog, "UTF-8", "gb2312"), vbNewLine)
For i = 2 To UBound(crr)
If InStr(crr(i), "Script: open") > 0 Then ftp = Split(crr(i), "Script: ")(1) '获取连接信息
If InStr(crr(i), "上传成功") > 0 Then
tmp = ftp & "||" & Split(crr(i - 1), "; ")(1)
tp = Split(ddd(tmp), "|")
brr(tp(0), tp(1)) = "R"
End If
Next
Range("D1").Resize(lrow, 4 + UBound(arr)) = brr
Range("D1").Resize(lrow, 4 + UBound(arr)).Borders.LineStyle = xlContinuous
Range("I2").Resize(lrow - 1, UBound(arr) - 1).Font.Name = "Wingdings 2"
Application.ScreenUpdating = True
MsgBox "已上传完成！请查看上传结果！"
End Sub
Function FileArr(sFile As String, sCode As String, dCode As String)
'参数：源文件，源文件编码，目标文件，目标文件编码。编码举例----"gb2312"、"UTF-8"等
Dim ObjStream As Object
Set ObjStream = CreateObject("Adodb.Stream")
With ObjStream
.Mode = 3 'adModeReadWrite = 3 ' 指示读/写权限。
.Type = 1 'adTypeBinary = 1
.Open
.LoadFromFile sFile '源文件
.Position = 0
.Type = 2 'adTypeText = 2
.Charset = sCode
FileArr = .ReadText '读取文本到sCode
.Close
End With
Set ObjStream = Nothing
End Function
下面有个模版，直接解压就可以使用了
https://pan.baidu.com/s/1fsIzin-riPK4MZ2Z3vb81A
网友评论