Sub ZipFiles()

'==================================

'==*****功能:压缩文件***********====

'==*****作者:雪山飞狐***********====

'==*****QQ:335081548***********====

'==****QQ交流群:13877563*******====

'==================================

    Dim ShellApp As Object

    Dim FileNames, FileNameZip, i As Long, FileCount As Long

    '//***选择文件的对话框,允许 用户从单个目录中选择多个文件

    FileNames = Application.GetOpenFilename(FileFilter:="All Files(*.*),*.*", FilterIndex:=1, Title:="请选择要压缩的文件", MultiSelect:=True)

    If Not IsArray(FileNames) Then Exit Sub    '//***如果点击了取消就退出程序

    FileCount = UBound(FileNames)    '统计选择的文件个数

    FileNameZip = Application.DefaultFilePath & "\新建压缩文件.zip"

    Open FileNameZip For Output As #1

    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)

    Close #1

    Set ShellApp = CreateObject("Shell.Application")

    For i = LBound(FileNames) To UBound(FileNames)

        DoEvents

        ShellApp.Namespace(FileNameZip).CopyHere FileNames(i)

        On Error Resume Next

        Do Until ShellApp.Namespace(FileNameZip).items.Count = i

            DoEvents

            Application.Wait (Now + TimeValue("0:00:01"))

        Loop

    Next

    If MsgBox(FileCount & "个压缩文件" & vbNewLine & FileNameZip & vbNewLine & vbNewLine & "查看zip文件") Then

        Shell "Explorer.exe /e," & FileNameZip, vbNormalFocus

    End If

End Sub