VBA实例—FTP批量上传模版

在公司，经常使用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