Zip y Unzip
Windows XP and 2003 Native Zip/Unzip
http://www.xtremevbtalk.com/showthread.php?t=284538
http://www.visualbasicscript.com/m_53086/tm.htm
http://www.jkp-ads.com/articles/Excel2007FileFormat02.asp (Author : Jan Karel Pieterse)
http://www.rondebruin.nl/windowsxpzip.htm
Function fUnzip(sZipFile, sTargetFolder)
Dim oShellApp: Set oShellApp = CreateObject("Shell.Application")
Dim oFSO: Set oFSO = CreateObject("Scripting.FileSystemObject")
If Not oFSO.FolderExists(sTargetFolder) Then oFSO.CreateFolder sTargetFolder
oShellApp.Namespace(sTargetFolder).CopyHere oShellApp.Namespace(sZipFile).Items
Do
Sleep 1000
Loop While oFSO.GetFolder(sTargetFolder).Files.Count < oShellApp.Namespace(sZipFile).Items.Count
End Function
Function fZip(sSourceFolder, sTargetZIPFile)
Dim oShellApp, oFSO, iErr, sErrSource, sErrDescription
Set oShellApp = CreateObject("Shell.Application")
Set oFSO = CreateObject("Scripting.FileSystemObject")
If Right(sSourceFolder, 1) <> "\" Then
sSourceFolder = sSourceFolder & "\"
End If
On Error Resume Next
If oFSO.FileExists(sTargetZIPFile) Then
oFSO.DeleteFile sTargetZIPFile, True
End If
iErr = err.Number
On Error GoTo 0
If iErr <> 0 Then
fZip = iErr
Exit Function
End If
On Error Resume Next
'Write the fileheader for a blank zipfile.
oFSO.OpenTextFile(sTargetZIPFile, 2, True).Write "PK" & Chr(5) & Chr(6) & String(18, Chr(0))
iErr = err.Number
On Error GoTo 0
If iErr <> 0 Then
fZip = iErr
Exit Function
End If
On Error Resume Next
oShellApp.Namespace(sTargetZIPFile).CopyHere oShellApp.Namespace(sSourceFolder).Items
iErr = err.Number
On Error GoTo 0
If iErr <> 0 Then
fZip = iErr
Exit Function
End If
Do Until oShellApp.Namespace(sTargetZIPFile).Items.Count = oShellApp.Namespace(sSourceFolder).Items.Count
Sleep 500
Loop
fZip = 0
Set oFSO = Nothing
Set oShellApp = Nothing
End Function
Comprimir y Descomprimir usando lineas de comandos