ExcelVBA参数化自动压缩文件可多文件及多文件夹混合压缩

前阵子做个项目要频繁压缩文件，到处找压缩文件的代码总没找到合适的，只好自己动手了。本过程实现调用系统安装的winrar软件完成压缩多文件及文件夹功能，其实际效果等同与在文件夹里选择多个文件及文件夹后右键压缩功能 ，本代码最大的好处是压缩文件夹时不会带根目录 ， 非常适用于文件及文件夹混合压缩 ，可指定压缩后目录。

示例代码如下

'****VBA压缩文件********Copyright@2015 www.excle880**************************************

'*将filelist文件或文件夹列表压缩到rarname文件中 注意都是用绝对路径 filelist之间逗号分隔

'*eg. E8_RarFiles "D:\Documents\Desktop\2.rar", "D:\Documents\Desktop\2\2,D:\Documents\Desktop\2\1.txt"

'****作者：excel880 *******************************************************

Sub E8_RarFiles(rarname, filelist)

Dim Source As String '压缩前的原始文件

Dim Target As String '压缩后的目标文件

Dim cmdstr As String 'Shell指令中的字符串

Dim Rarexe As String 'WINRAR执行文件的位置

Dim arr, dic, i, n, k, iitem, ks

Rarexe = "C:\program files\winrar\winrar"

arr = Split(filelist, ",")

Set dic = CreateObject("scripting.dictionary")

For i = 0 To UBound(arr)

n = InStrRev(arr(i), "\")

k = Left(arr(i), n - 1)

iitem = """" & Mid(arr(i), n + 1) & """"

dic(k) = dic(k) & " " & iitem

Next

ks = dic.keys

rarname = """" & rarname & """" '空格路径 加双引号

For i = 0 To dic.Count - 1

ChDrive ks(i)

ChDir ks(i)

Source = dic(ks(i))

cmdstr = Rarexe & " a " & rarname & " " & Source

Shell cmdstr, vbHide

Next

End Sub

Private Sub Test()

Dim i&, j&, k&, arr, brr, s

s = ThisWorkbook.Path & "\"

E8_RarFiles s & "test.rar", s & "1.txt," & s & "2.txt," & s & "1 2 3"

End Sub