Excel 将文件夹和文件压缩到该文件夹

我已经通过excel vba压缩了一个文件夹和内容。例如：我有一个名为2178的文件夹，其中有两张图片

2178_photo.jpg

2178_poa.jpg

压缩后，我需要压缩文件夹中的3个文件

文件夹名称

2178_photo.jpg

2178_poa.jpg

但在当前的程序中，我只得到2个文件：

2178_photo.jpg

2178_poa.jpg

---

Sub-NewZip（sPath）'创建空Zip文件
如果Len（Dir（sPath））>0，则杀死sPath
打开sPath，输出为#1
打印#1、Chr$（80）&Chr$（75）&Chr$（5）&Chr$（6）&字符串（18,0）
关闭#1
端接头
子压缩文件夹（）中的所有文件
Dim文件名zip，文件夹名
Dim strDate作为字符串，DefPath作为字符串
将oApp作为对象DefPath=“D:\KYC\”进行调整
FolderName=“d:\kyc\2178”‘压缩文件夹名称’我正在获取用于选择文件夹和压缩所有文件的代码。我的要求是选择一个文件夹并压缩该文件夹（包括其内容）。谢谢第三个文件需要是什么？只是一个有名字的文本文件？或者您需要将正在压缩的文件“放在”zip文件中具有相同名称的文件夹中吗？是的。迈克，这正是你写的。将文件压缩到具有相同名称的文件夹中。谢谢
Sub NewZip(sPath) 'Create empty Zip File
    If Len(Dir(sPath)) > 0 Then Kill sPath
    Open sPath For Output As #1
    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
    Close #1 
End Sub

Sub Zip_All_Files_in_Folder()
    Dim FileNameZip, FolderName
    Dim strDate As String, DefPath As String
    Dim oApp As Object DefPath = "D:\KYC\"
    FolderName = "d:\kyc\2178"     ' the zipping folder name '<< Change
    strDate = Format(Now, " dd-mmm-yy h-mm-ss")
    FileNameZip = "d:\kyc\2178.zip" ' to be zipped folder'DefPath & Range("A" & i).Value & ".zip"
    'Create empty Zip File
    NewZip (FileNameZip)
    Set oApp = CreateObject("Shell.Application")
    'Copy the files to the compressed folder
    oApp.Namespace(FileNameZip).CopyHere oApp.Namespace(FolderName).items
    'Keep script waiting until Compressing is done
    On Error Resume Next
    Do Until oApp.Namespace(FileNameZip).items.count = _
       oApp.Namespace(FolderName).items.count
        Application.Wait (Now + TimeValue("0:00:01"))
    Loop
    On Error GoTo 0
    MsgBox "ok " 
End Sub