Question

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

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.

Answer 1

Have a look at the following links:

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