StackOverflow2013

Note that there are some explanatory texts on larger screens.

plurals

PO
text
Body
copied!<p>There are VBA methods to <a href="http://www.rondebruin.nl/win/s7/win001.htm" rel="noreferrer">zip</a> and <a href="http://www.rondebruin.nl/win/s7/win002.htm" rel="noreferrer">unzip</a> using the windows built in compression as well, which should give some insight as to how the system operates. You may be able to build these methods into a scripting language of your choice.</p> <p>The basic principle is that within windows you can treat a zip file as a directory, and copy into and out of it. So to create a new zip file, you simply make a file with the extension <code>.zip</code> that has the right header for an empty zip file. Then you close it, and tell windows you want to copy files into it as though it were another directory.</p> <p>Unzipping is easier - just treat it as a directory.</p> <p>In case the web pages are lost again, here are a few of the relevant code snippets:</p> <h1>ZIP</h1> <pre><code>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 bIsBookOpen(ByRef szBookName As String) As Boolean ' Rob Bovey On Error Resume Next bIsBookOpen = Not (Application.Workbooks(szBookName) Is Nothing) End Function 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 </code></pre> <h1>UNZIP</h1> <pre><code>Sub Unzip1() Dim FSO As Object Dim oApp As Object Dim Fname As Variant Dim FileNameFolder As Variant Dim DefPath As String Dim strDate As String Fname = Application.GetOpenFilename(filefilter:="Zip Files (*.zip), *.zip", _ MultiSelect:=False) If Fname = False Then 'Do nothing Else 'Root folder for the new folder. 'You can also use DefPath = "C:\Users\Ron\test\" DefPath = Application.DefaultFilePath If Right(DefPath, 1) <> "\" Then DefPath = DefPath & "\" End If 'Create the folder name strDate = Format(Now, " dd-mm-yy h-mm-ss") FileNameFolder = DefPath & "MyUnzipFolder " & strDate & "\" 'Make the normal folder in DefPath MkDir FileNameFolder 'Extract the files into the newly created folder Set oApp = CreateObject("Shell.Application") oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(Fname).items 'If you want to extract only one file you can use this: 'oApp.Namespace(FileNameFolder).CopyHere _ 'oApp.Namespace(Fname).items.Item("test.txt") MsgBox "You find the files here: " & FileNameFolder On Error Resume Next Set FSO = CreateObject("scripting.filesystemobject") FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True End If End Sub </code></pre>

Querying!

Guidance

An individual column

Larger individual text columns get their own page to allow for proper reading.

SQuiL has stopped working due to an internal error.

If you are curious you may find further information in the browser console, which is accessible through the devtools (F12).

Reload