vba 创建压缩（或压缩）文件夹
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/179031/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
Creating a compressed (or zipped) folder
提问by Simon
Is there a way to programmatically create a compressed folder in Windows? I can't see a way to do this using the FileSystemObject (although there is the 'Compressed' attribute).
有没有办法在 Windows 中以编程方式创建压缩文件夹？我看不到使用 FileSystemObject 执行此操作的方法（尽管有“压缩”属性）。
I've seen zip dll's but I'd prefer to avoid having to re-distribute a dll if possible. Windows XP natively supports compressed folders after all.
我见过 zip dll，但如果可能的话，我宁愿避免重新分发 dll。毕竟，Windows XP 本身就支持压缩文件夹。
采纳答案by Jorge Ferreira
Have a look at the following links:
看看以下链接：
http://www.rondebruin.nl/windowsxpzip.htm
http://www.rondebruin.nl/windowsxpzip.htm
http://forums.microsoft.com/MSDN/ShowPost.aspx?PostID=1383147&SiteID=1
http://forums.microsoft.com/MSDN/ShowPost.aspx?PostID=1383147&SiteID=1
Stripping the important parts from the first linkexample may prove to be sufficient.
从第一个链接示例中剥离重要部分可能就足够了。
Sub NewZip(sPath)
'Create empty Zip File
'Changed by keepITcool Dec-12-2005
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
Function Split97(sStr As Variant, sdelim As String) As Variant
'Tom Ogilvy
Split97 = Evaluate("{""" & _
Application.Substitute(sStr, sdelim, """,""") & """}")
End Function
Sub Zip_File_Or_Files()
Dim strDate As String, DefPath As String, sFName As String
Dim oApp As Object, iCtr As Long, I As Integer
Dim FName, vArr, FileNameZip
DefPath = Application.DefaultFilePath
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If
strDate = Format(Now, " dd-mmm-yy h-mm-ss")
FileNameZip = DefPath & "MyFilesZip " & strDate & ".zip"
'Browse to the file(s), use the Ctrl key to select more files
FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xl*), *.xl*", _
MultiSelect:=True, Title:="Select the files you want to zip")
If IsArray(FName) = False Then
'do nothing
Else
'Create empty Zip File
NewZip (FileNameZip)
Set oApp = CreateObject("Shell.Application")
I = 0
For iCtr = LBound(FName) To UBound(FName)
vArr = Split97(FName(iCtr), "\")
sFName = vArr(UBound(vArr))
If bIsBookOpen(sFName) Then
MsgBox "You can't zip a file that is open!" & vbLf & _
"Please close it and try again: " & FName(iCtr)
Else
'Copy the file to the compressed folder
I = I + 1
oApp.Namespace(FileNameZip).CopyHere FName(iCtr)
'Keep script waiting until Compressing is done
On Error Resume Next
Do Until oApp.Namespace(FileNameZip).items.Count = I
Application.Wait (Now + TimeValue("0:00:01"))
Loop
On Error GoTo 0
End If
Next iCtr
MsgBox "You find the zipfile here: " & FileNameZip
End If
End Sub
