ZipFiles/Folders Using VB Script in QTP/UFT

Sample:
 strmyFolderPath = "C:\Jay\Sample"
strZipFilePath  = "C:\Jay\MySampleFile.Zip"
Call  ZipMyFolder( strmyFolderPath, strZipFilePath )


Function ZipMyFolder( strmyFolderPath, strZipFilePath )
    Dim intSkipped, intSrcItems
    Dim objApp, objFolder, objFSO, objItem, objTxt
    Dim strSkipped

    Const ForWriting = 2

    intSkipped = 0

    ' Make sure the path ends with a backslash
    If Right( strmyFolderPath, 1 ) <> "\" Then
        strmyFolderPath = strmyFolderPath & "\"
    End If

    ' Use custom error handling
    On Error Resume Next

    ' Create an empty ZIP file
    Set objFSO = CreateObject( "Scripting.FileSystemObject" )
    Set objTxt = objFSO.OpenTextFile( strZipFilePath, ForWriting, True )
    objTxt.Write "PK" & Chr(5) & Chr(6) & String( 18, Chr(0) )
    objTxt.Close
    Set objTxt = Nothing

    ' Abort on errors
    If Err Then
        ZipMyFolder = Array( Err.Number, Err.Source, Err.Description )
        Err.Clear
        On Error Goto 0
        Exit Function
    End If
  
    ' Create a Shell object
    Set objApp = CreateObject( "Shell.Application" )

    ' Copy the files to the compressed folder
    For Each objItem in objApp.NameSpace( strmyFolderPath ).Items
        If objItem.IsFolder Then
            ' Check if the subfolder is empty, and if
            ' so, skip it to prevent an error message
            Set objFolder = objFSO.GetFolder( objItem.Path )
            If objFolder.Files.Count + objFolder.SubFolders.Count = 0 Then
                intSkipped = intSkipped + 1
            Else
                objApp.NameSpace( strZipFilePath ).CopyHere objItem
            End If
        Else
            objApp.NameSpace( strZipFilePath ).CopyHere objItem
        End If
    Next

    Set objFolder = Nothing
    Set objFSO    = Nothing

    ' Abort on errors
    If Err Then
        ZipMyFolder = Array( Err.Number, Err.Source, Err.Description )
        Set objApp = Nothing
        Err.Clear
        On Error Goto 0
        Exit Function
    End If

    ' Keep script waiting until compression is done
    intSrcItems = objApp.NameSpace( strmyFolderPath  ).Items.Count
    Do Until objApp.NameSpace( strZipFilePath ).Items.Count + intSkipped = intSrcItems
        WScript.Sleep 200
    Loop
    Set objApp = Nothing

    ' Abort on errors
    If Err Then
        ZipMyFolder = Array( Err.Number, Err.Source, Err.Description )
        Err.Clear
        On Error Goto 0
        Exit Function
    End If

    ' Restore default error handling
    On Error Goto 0

    ' Return message if empty subfolders were skipped
    If intSkipped = 0 Then
        strSkipped = ""
    Else
        strSkipped = "skipped empty subfolders"
    End If

    ' Return code 0 (no error occurred)
    ZipMyFolder = Array( 0, intSkipped, strSkipped )
End Function