Compress subfolders of a folder

[Merri]

This function compresses all subfolders and all files in those subfolders. The drive must be NTFS for this to work

Public Function CompressSubFolders(ByVal Path As String) As Boolean
    Dim objFolder As Object, objWMI As Object, strWQL As String
    On Error GoTo ErrorHandler
    Set objWMI = GetObject("winmgmts:\\.\root\CIMV2")
    strWQL = "ASSOCIATORS OF {Win32_Directory.Name=""" & Replace(Path, "\", "\\") & """} WHERE AssocClass = Win32_Subdirectory ResultRole = PartComponent"
    For Each objFolder In objWMI.ExecQuery(strWQL, , 48)
        CompressSubFolders = CompressSubFolders Or (objWMI.ExecMethod("Win32_Directory.Name=""" & Replace(objFolder.Name, "\", "\\") & """", "Compress", Nothing).ReturnValue = 0)
    Next
ErrorHandler:
End Function

Returns True if compressing any of the subfolders succeeded. Note that this function may lock your application for a while if used on a big folder.