Zip File using VBA (Visual Basic for Applications) code example

Zip

Refers to archive or compress file. A Zip file compressed using binary algorithms supported by mostly operating systems. In this article we will use VBA (Visual Basic for Applications) code.

Code example

Sub ZipMultipleFileExample()
On Error GoTo errh
    Dim oDefualtPath As String
    Dim oStrFileName As String
    Dim oShellAppObj As Object
    Dim oCounter As Long
    Dim K As Integer
    Dim oSelectedFileName, oFileArray, zipFileName

    oDefualtPath = Application.DefaultFilePath
    If Right(oDefualtPath, 1) <> "\" Then
        oDefualtPath = oDefualtPath & "\"
    End If
    
    'Generate unique id
    Dim GUID As String
    GUID = GenrateGuid
    zipFileName = oDefualtPath & "Zipfile " & GUID & ".zip"

    'Open file dialog
    oSelectedFileName = Application.GetOpenFilename(filefilter:="All Files, *.*", _
                    MultiSelect:=True, Title:="Select File(s) - VBAOVERALL")
    
    'Validate file selection
    If IsArray(oSelectedFileName) = False Then
        MsgBox "Please select at least one file"
    Else
        'Create empty Zip File
        CreateZip (zipFileName)
        Set oShellAppObj = CreateObject("Shell.Application")
        I = 0
        For oCounter = LBound(oSelectedFileName) To UBound(oSelectedFileName)
            
            'Check if file is opend
            If IsFileReadOnly(oStrFileName) Then
                MsgBox "Processing failed file readonly found"
            Else
                'Copy the file to the compressed folder
                oShellAppObj.Namespace(zipFileName).CopyHere oSelectedFileName(oCounter)
                K = K + 1
                'Put a wait loop so compress can be done
                On Error Resume Next
                Do Until oShellAppObj.Namespace(zipFileName).items.Count = K
                    Application.Wait (Now + TimeValue("0:00:01"))
                Loop
                On Error GoTo 0
            End If
        Next oCounter
        Range("Output") = zipFileName
        Range("Output").Hyperlinks.Add Anchor:=Range("Output"), Address:=zipFileName, ScreenTip:="Click to open zip file"
        MsgBox "Zip Operation successfull"
    End If
errh:
If Err.Number <> 0 Then
    MsgBox "Opration fail due to : " & Err.Description
    Exit Sub
End If
End Sub

CreateZip function

Sub CreateZip(sPath)
    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

ObjectSplit function

Function ObjectSplit(sStr As Variant, sdelim As String) As Variant
    ObjectSplit = ""
    ObjectSplit = Evaluate("{""" & _
                       Application.Substitute(sStr, sdelim, """,""") & """}")
End Function

GenerateGuid function

Function GenrateGuid() As String
  GenrateGuid = ""
  Dim oLib As Object
  Dim GUID As String
  Dim guid2 As String
  Set oLib = CreateObject("Scriptlet.TypeLib")
  GUID = Left$(oLib.GUID, 38)
  Set TypeLib = Nothing
  
  GUID = Replace(GUID, "{", "")
  GUID = Replace(GUID, "}", "")
  
  'Return result
  GenrateGuid = GUID
End Function

IsFileReadOnly function

Public Function IsFileReadOnly(strFileName As String) As Boolean
    IsFileReadOnly = False
    On Error GoTo errh
    Open strFileName For Binary Access Read Write Lock Read Write As #1
    Close #1
    IsFileReadOnly = True
errh:
    If Err.Number <> 0 Then
        IsFileReadOnly = False
    End If
End Function

Output

Next >> Unzip files using VBA code example

Share on Facebook

Tweet