vba - online - Creando una carpeta comprimida(o comprimida)

como descomprimir un archivo zip

Question

¿Hay alguna manera de crear programáticamente una carpeta comprimida en Windows? No puedo ver una manera de hacer esto usando el FileSystemObject (aunque existe el atributo ''Compressed'').

He visto zip dll pero preferiría evitar tener que volver a distribuir un archivo DLL si es posible. Windows XP soporta nativamente carpetas comprimidas después de todo.

Answer 1

Eche un vistazo a los siguientes enlaces:

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

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

Pelar las partes importantes del primer ejemplo de enlace puede ser suficiente.

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