主体参考很多vbs、VB方面的程序。目前以下还未进行测试

方法一：调用shell

  1. '获得rar的安装路径
  2. Function GetSetupPath(AppName As String)
  3.     Dim WSH As Object
  4.     Set WSH = CreateObject("Wscript.Shell")
  5.     GetSetupPath = WSH.RegRead("HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\App Paths\" & AppName & "\Path")
  6.     Set WSH = Nothing
  7. End Function
  8. Sub 测试()
  9. Debug.Print GetSetupPath("Winrar.exe")
  10. Debug.Print GetSetupPath("Excel.exe")
  11. End Sub
  14. 'Shell函数
  15.   'Shell执行一个可执行文件.返回一个 Variant (Double)，如果成功的话，代表这个程序的任务 ID，若不成功，则会返回 0。
  16.   '语法
  17.    'Shell("可执行程序的路径 文件名或命令行",窗口的显示方式)
  19.   Sub 用绘图程序打开图片()
  20.   Dim mysh
  21.      mysh = Shell("mspaint.exe " & ThisWorkbook.path & "\pic.jpg", vbMaximizedFocus)
  22.   End Sub
  24.   'WinRar命令的命令行表示方法
  26.    ' WinRar程序路径  命令 开关1 开关2 开关3..开关N  压缩包路径 压缩的文件路径
  27.       '命令是指要进行怎么样的操作，如A是压缩，X是解压缩
  28.       '开关是具体操作时的细节，如压缩是是否把原文件删除，是否添加密码等
  30. Sub RarFile()   '压缩单个文件
  31.   Dim Rarexe As String
  32.   Dim myRAR As String
  33.   Dim Myfile As String
  34.   Dim FileString As String
  35.   Dim Result As Long
  36.     Rarexe = "C:\program files\winrar\winrar.exe" 'rar程序路径
  37.     myRAR = ThisWorkbook.path & "\A.rar"  '压缩后的文件名
  38.     Myfile = ThisWorkbook.path & "\B*.xls"     ' 指定要压缩的文件
  39.     FileString = Rarexe & " A " & myRAR & " " & Myfile 'rar程序的A命令压缩文件的字符串
  40.     Result = Shell(FileString, vbHide) '执行压缩
  41. End Sub
  42. '如果文件名使用通配符,可以对同类的文件进行和压缩,
  43. '如果只有路径没有文件名,则会把这个文件夹进行压缩
  44. Sub RarFile2()   '多个文件压在一起
  45.   Dim Rarexe As String
  46.   Dim myRAR As String
  47.   Dim Myfile As String
  48.   Dim FileString As String
  49.   Dim Result As Long
  50.     Rarexe = "C:\program files\winrar\winrar.exe" 'rar程序路径
  51.     myRAR = ThisWorkbook.path & "\B.rar"  '压缩后的文件名
  52.    ' Myfile = ThisWorkbook.path & "\B\*.xls"     ' 指定要压缩的文件类型
  53.     Myfile = ThisWorkbook.path & "\B\"     ' 指定要压缩的文件夹路径
  54.     FileString = Rarexe & " A " & myRAR & " " & Myfile 'rar程序的A命令压缩文件的字符串
  55.     Result = Shell(FileString, vbHide) '执行压缩
  56. End Sub
  58. '-ep压缩时忽略路径,如果没有则会带上
  59. '-ep1压缩时忽略基准路径
  60. Sub RarFile2()   '多个文件压在一起
  61.   Dim Rarexe As String
  62.   Dim myRAR As String
  63.   Dim Myfile As String
  64.   Dim FileString As String
  65.   Dim Result As Long
  66.     Rarexe = "C:\program files\winrar\winrar.exe" 'rar程序路径
  67.     myRAR = ThisWorkbook.path & "\B.rar"  '压缩后的文件名
  68.     Myfile = ThisWorkbook.path & "\B"     ' 指定要压缩的文件
  69.     FileString = Rarexe & " A -ep1 " & myRAR & " " & Myfile 'rar程序的A命令压缩文件的字符串
  70.     Result = Shell(FileString, vbHide) '执行压缩
  71. End Sub
  74. '-p+密码 加密码后可以看到文件列表
  75. '-hp+密码 加密码后无法看到文件列表
  77. Sub RarFile9()   '多个文件压在一起,并添加密码,可以看到文件列表
  78.   Dim Rarexe As String
  79.   Dim myRAR As String
  80.   Dim Myfile As String
  81.   Dim FileString As String
  82.   Dim Result As Long
  83.     Rarexe = "C:\program files\winrar\winrar.exe" 'rar程序路径
  84.     myRAR = ThisWorkbook.path & "\B.rar"  '压缩后的文件名
  85.     Myfile = ThisWorkbook.path & "\B\"     ' 指定要压缩的文件
  86.     FileString = Rarexe & " A -p123 " & myRAR & " " & Myfile
  87.     Result = Shell(FileString, vbHide) '执行压缩
  88. End Sub
  90. Sub RarFile10()   '多个文件压在一起,并添加密码,看不到文件列表
  91.   Dim Rarexe As String
  92.   Dim myRAR As String
  93.   Dim Myfile As String
  94.   Dim FileString As String
  95.   Dim Result As Long
  96.     Rarexe = "C:\program files\winrar\winrar.exe" 'rar程序路径
  97.     myRAR = ThisWorkbook.path & "\B.rar"  '压缩后的文件名
  98.     Myfile = ThisWorkbook.path & "\B\"     ' 指定要压缩的文件
  99.     FileString = Rarexe & " A -hp123 " & myRAR & " " & Myfile
  100.     Result = Shell(FileString, vbHide) '执行压缩
  101. End Sub
  103. 'df压缩后删除原文件
  104. 'dr压缩后删除原文件到回收站
  106. Sub RarFile2()   '多个文件压在一起,删除原文件
  107.   Dim Rarexe As String
  108.   Dim myRAR As String
  109.   Dim Myfile As String
  110.   Dim FileString As String
  111.   Dim Result As Long
  112.     Rarexe = "C:\program files\winrar\winrar.exe" 'rar程序路径
  113.     myRAR = ThisWorkbook.path & "\B\B.rar"  '压缩后的文件名
  114.     Myfile = ThisWorkbook.path & "\B\*.xls"     ' 指定要压缩的文件
  115.     FileString = Rarexe & " A -df -p123 -ep " & myRAR & " " & Myfile 'rar程序的A命令压缩文件的字符串
  116.     Result = Shell(FileString, vbHide) '执行压缩
  117. End Sub
  119. Sub RarFile3()   '多个文件压在一起，删除原文件到回收站
  120.   Dim Rarexe As String
  121.   Dim myRAR As String
  122.   Dim Myfile As String
  123.   Dim FileString As String
  124.   Dim Result As Long
  125.     Rarexe = "C:\program files\winrar\winrar.exe" 'rar程序路径
  126.     myRAR = ThisWorkbook.path & "\B\B.rar"  '压缩后的文件名
  127.     Myfile = ThisWorkbook.path & "\B\*.xls"     ' 指定要压缩的文件
  128.     FileString = Rarexe & " A -dr -p123 -ep " & myRAR & " " & Myfile 'rar程序的A命令压缩文件的字符串
  129.     Result = Shell(FileString, vbHide) '执行压缩
  130. End Sub
  133. Sub RarFile2()   '多个文件压在一起,排除某个文件
  134.   Dim Rarexe As String
  135.   Dim myRAR As String
  136.   Dim Myfile As String
  137.   Dim FileString As String
  138.   Dim Result As Long
  139.     Rarexe = "C:\program files\winrar\winrar.exe" 'rar程序路径
  140.     myRAR = ThisWorkbook.path & "\B.rar"  '压缩后的文件名
  141.     Myfile = ThisWorkbook.path & "\B\*.xls"     ' 指定要压缩的文件
  142.     FileString = Rarexe & " A -x" & ThisWorkbook.path & "\B\dr.xls -x" & ThisWorkbook.path & "\B\1.xls -ep " & myRAR & " " & Myfile 'rar程序的A命令压缩文件的字符串
  143.     Result = Shell(FileString, vbHide) '执行压缩
  145. End Sub
  148. '借助dir和do循环，压缩指定文件夹中的所有文件
  149. Sub RarFile4()   '每个文件单独压缩
  150.   Dim Rarexe As String
  151.   Dim myRAR As String
  152.   Dim Myfile As String
  153.   Dim FileString As String
  154.   Dim Result As Long
  155.   Dim p As String, f As String
  156.    p = ThisWorkbook.path & "\B\"
  157.    Rarexe = "C:\program files\winrar\winrar.exe" 'rar程序路径
  158.    f = Dir(p & "*.xls")
  159.   Do While f <> ""
  160.     f = Split(f, ".")(0)
  161.     Myfile = ThisWorkbook.path & "\B\" & f & ".xls"   ' 指定要压缩的文件
  162.     myRAR = ThisWorkbook.path & "\B\" & f & ".rar" '压缩后的文件名
  164.     FileString = Rarexe & " A -ep " & myRAR & " " & Myfile 'rar程序的A命令压缩文件的字符串
  165.     Result = Shell(FileString, vbHide) '执行压缩
  166.    f = Dir
  167.   Loop
  168. End Sub
  170. 'D可以删除指定的文件
  171. 'WinRAR d 文件夹 可以带通配符的文件名或同类文件
  173. Sub RarFile3()   '
  174.   Dim Rarexe As String
  175.   Dim myRAR As String
  176.   Dim Myfile As String
  177.   Dim FileString As String
  178.   Dim Result As Long
  179.     Rarexe = "C:\program files\winrar\winrar.exe" 'rar程序路径
  180.     myRAR = ThisWorkbook.path & "\B\B.rar"  '在删除的压缩包名称
  181.     Myfile = ThisWorkbook.path & "\B\说明.txt"     ' 指定要删除的文件
  182.     FileString = Rarexe & " D " & myRAR & " " & "说明.txt" 'rar程序的A命令压缩文件的字符串
  183.     Result = Shell(FileString, vbHide) '执行程序
  184. End Sub
  187. Sub RarFile2()   '解压缩
  188.   Dim Rarexe As String
  189.   Dim myRAR As String
  190.   Dim Mypath As String
  191.   Dim FileString As String
  192.   Dim Result As Long
  193.     Rarexe = "C:\program files\winrar\winrar.exe" 'rar程序路径
  194.     myRAR = ThisWorkbook.path & "\B\B.rar"  '压缩后的文件名
  195.     Mypath = ThisWorkbook.path & "\B\"     ' 指定要压缩的文件
  196.     FileString = Rarexe & " x -ep -hp123 " & myRAR & " " & Mypath 'rar程序的A命令压缩文件的字符串
  197.     Result = Shell(FileString, vbHide) '执行压缩
  198. End Sub
  199. 'x 表示解压缩
  200. '-ep解压到当前文件夹下
  201. '-hp123 解压含密码的压缩包
  202. ————————————————
  203. 版权声明：本文为CSDN博主「预见未来to50」的原创文章，遵循 CC 4.0 BY-SA 版权协议，转载请附上原文出处链接及本声明。
  204. 原文链接：https://blog.csdn.net/hpdlzu80100/article/details/80835784

方法二：使用FileSystemObject，手动构建

' VB Script Document
option explicit

createZip "d:\test", "d:\testZip.zip"

sub createZip(sfolder, tfolder)
  dim fso, zipfile
  dim shell, WshShell, destfolder, srcfolder

  ' create a blank zip compress file
  set fso = CreateObject("Scripting.FileSystemObject")
  set zipfile = fso.OpenTextFile(tfolder, 8, vbtrue)

  zipfile.Write "PK" & Chr(5) & Chr(6) & string(18, 0)
  zipfile.close

  ' copy you file into blank zip file
  set shell = CreateObject("Shell.Application")
  set WshShell = WScript.CreateObject("WScript.Shell")

  set destfolder = shell.NameSpace(tfolder)
  set srcfolder = shell.NameSpace(sfolder)

  destfolder.CopyHere srcfolder.items, &H214

end sub

Zip "D:\test.xls", "D:\test.zip" 

Sub Zip(ByVal mySourceDir, ByVal myZipFile) 
    Set fso = CreateObject("Scripting.FileSystemObject") 
    If fso.GetExtensionName(myZipFile) <> "zip" Then 
        Exit Sub 
  ElseIf fso.FolderExists(mySourceDir) Then 
    FType = "Folder" 
  ElseIf fso.FileExists(mySourceDir) Then 
    FType = "File" 
    FileName = fso.GetFileName(mySourceDir) 
    FolderPath = Left(mySourceDir, Len(mySourceDir) - Len(FileName)) 
  Else 
    Exit Sub 
  End If 

  Set f = fso.CreateTextFile(myZipFile, True) 
  f.Write "PK" & Chr(5) & Chr(6) & String(18, Chr(0)) 
  f.Close 
  Set objShell = CreateObject("Shell.Application") 

  Select Case Ftype 
  Case "Folder" 
  Set objSource = objShell.NameSpace(mySourceDir) 
  Set objFolderItem = objSource.Items() 
  Case "File" 
  Set objSource = objShell.NameSpace(FolderPath) 
  Set objFolderItem = objSource.ParseName(FileName) 
  End Select 
  Set objTarget = objShell.NameSpace(myZipFile) 
  intOptions = 256 
  objTarget.CopyHere objFolderItem, intOptions 
  Do 
  WScript.Sleep 1000 
  Loop Until objTarget.Items.Count > 0 
End Sub

Sub UnzipAFile()
'==================================
'==*****功能:文件解压***********====
'==*****作者:雪山飞狐***********====
'==*****QQ:335081548***********====
'==****QQ交流群:13877563*******====
'==================================
    Dim ShellApp As Object
    Dim TargetFile, ZipFolder

    TargetFile = Application.GetOpenFilename _
        (FileFilter:="Zip Files (*.zip), *.zip")
    If TargetFile = False Then Exit Sub

    ZipFolder = Application.DefaultFilePath & "\解压文件临时存放\"
    On Error Resume Next
    RmDir ZipFolder
    MkDir ZipFolder
    On Error GoTo 0

    Set ShellApp = CreateObject("Shell.Application")
    ShellApp.Namespace(ZipFolder).CopyHere ShellApp.Namespace(TargetFile).items
    If MsgBox("文件解压到:" & vbNewLine & ZipFolder & vbNewLine & vbNewLine & "是否显示文件夹?", vbQuestion + vbYesNo) = vbYes Then
       Shell "Explorer.exe /e," & ZipFolder, vbNormalFocus
    End If
End Sub