VBA do divide zip into volumes that won exceed 28 Mb and adds "Part 1" "2" to the name

Hi everyone,

I have a VBA code that according the folder where excel file (VBA) is:
- Will zip all sub folders (and itīs content) into zip files with the same names
- name the zip files according to the folders name
- Destination folder must be the exact same folder where the excel file with the VBA code is
- The folder will be / is a windows network folder

Imagine my excel file is at folder name

HTML Code: 

, and inside that folder i have sub Folders:
apple
grapes
almonds

What i have is a macro that will zip on that same folder Fruit, and return files: apple.zip + grapes.zip + almonds.zip
And if i run the macro again, the code should overwritten the zip files according to the new files or folders inside folder Fruit


What i need now, is that in case any of the zip files exceeds 28 Mb to make volumes like:

apple.zip - Part 1 28Mb
apple.zip - Part 2 28Mb
apple.zip - Part 3 1Mb
grapes.zip 12Mb (if zip wont exceed 28Mb, no need to add to the name "Part 1" )
almonds.zip - Part 1 28Mb
almonds.zip - Part 2 5Mb

Something like that.

I cannot install any software to zip, only the windows default zip software.

Copy to clipboard
Public Function ZipSubFolders(ZipThatFolder As String)
'zip sub folders in ZipThatFolder
'ie. Call ZipSubFolders(GetThatFolder)
Dim FsoObj As Object, SubF As Object, xFS As Object
Dim Temp2 As Object, Foldername As String
Set FsoObj = CreateObject("Scripting.FileSystemObject")
Set xFS = FsoObj.GetFolder(ZipThatFolder)
For Each SubF In xFS.SubFolders
'can't zip empty folders
If Dir(SubF.Path & "\" & "*.*") <> "" Then
On Error Resume Next
'remove previous zip file
Set Temp2 = FsoObj.GetFile(SubF.Path & ".zip")
If Temp2 <> "" Then
FsoObj.deletefile (SubF.Path & ".zip"), False
End If
On Error GoTo 0
'zip folder
Call Zipp(SubF.Path & ".zip", SubF.Path)
Else 'remove these 2 lines as needed
MsgBox "No Files to zip in folder: " & SubF.Path
End If
Next SubF
Set Temp2 = Nothing
Set xFS = Nothing
Set FsoObj = Nothing
End Function

Public Function GetThatFolder() As String
Dim FlDr As FileDialog
Dim sItem As String
Set FlDr = Application.FileDialog(msoFileDialogFolderPicker)
With FlDr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = Application.DefaultFilePath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetThatFolder = sItem
Set FlDr = Nothing
End Function

'Many thanks to Ron de Bruin for his great code
Public Function Zipp(ZipName, FileToZip)
'Zips A Folder/File
'ZipName must be FULL Path\Filename.zip - name Zip File to Create
'FileToZip must be Full Path\Filename.xls - Name of file you want to zip
Dim oApp As Object, T As Double
If Dir(ZipName) = "" Then
Open ZipName For Output As #1
Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Close #1
End If
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(ZipName).CopyHere (FileToZip)
'Keep script waiting until Compressing is done
On Error Resume Next
Do Until oApp.Namespace(ZipName).items.Count = 1
T = Timer
Do Until Timer - T > 1
  DoEvents
Loop
Loop
On Error GoTo 0
Set oApp = Nothing
End Function

Can someone help adding to this code the functionality to divide the zips into volumes that won't exceed 28 Mb and rename zips accordingly (Part 1, Part 2 ...)

Thanks