创建压缩(或压缩)文件夹 [英] Creating a compressed (or zipped) folder

问题描述

有没有办法在 Windows 中以编程方式创建压缩文件夹?我看不到使用 FileSystemObject 执行此操作的方法(尽管有压缩"属性).

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).

我见过 zip dll，但如果可能，我宁愿避免重新分发 dll.毕竟 Windows XP 本身就支持压缩文件夹.

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.

推荐答案

查看以下链接:

http://www.rondebruin.nl/windowsxpzip.htm

http://forums.microsoft.com/MSDN/ShowPost.aspx?PostID=1383147&SiteID=1

从第一个链接示例中剥离重要部分可能就足够了.

Stripping the important parts from the first link example 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

这篇关于创建压缩(或压缩)文件夹的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！