Option Explicit
#If VBA7 Then
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If
'Constants from https://www.pinvoke.net/default.aspx/Constants.ShellAPI
'Descriptions from https://docs.microsoft.com/en-us/windows/desktop/shell/folder-copyhere
'Flags which aren't described on the latter page are commented out.
'Private Const FOF_MULTIDESTFILES = &H1
'Private Const FOF_CONFIRMMOUSE = &H2
Private Const FOF_SILENT = &H4 'Do not display a progress dialog box.
Private Const FOF_RENAMEONCOLLISION = &H8 'Give the file being operated on a new name in a move, copy, or rename operation if a file with the target name already exists.
Private Const FOF_NOCONFIRMATION = &H10 'Respond with "Yes to All" for any dialog box that is displayed.
'Private Const FOF_WANTMAPPINGHANDLE = &H20 'fill in SHFILEOPSTRUCT.hNameMappings. Must be freed using SHFreeNameMappings
Private Const FOF_ALLOWUNDO = &H40 'Preserve undo information, if possible.
Private Const FOF_FILESONLY = &H80 'Perform the operation on files only if a wildcard file name (*.*) is specified.
Private Const FOF_SIMPLEPROGRESS = &H100 'Display a progress dialog box but do not show the file names.
Private Const FOF_NOCONFIRMMKDIR = &H200 'Do not confirm the creation of a new directory if the operation requires one to be created.
Private Const FOF_NOERRORUI = &H400 'Do not display a user interface if an error occurs.
Private Const FOF_NOCOPYSECURITYATTRIBS = &H800 'Version 4.71. Do not copy the security attributes of the file.
Private Const FOF_NORECURSION = &H1000 'Only operate in the local directory. Do not operate recursively into subdirectories.
Private Const FOF_NO_CONNECTED_ELEMENTS = &H2000 'Version 5.0. Do not copy connected files as a group. Only copy the specified files.
'Private Const FOF_WANTNUKEWARNING = &H4000 'During delete operation, warn if nuking instead of recycling (partially overrides FOF_NOCONFIRMATION)
'Private Const FOF_NORECURSEREPARSE = &H8000 'Treat reparse points as objects, not containers
Public Sub Create_Zip_Files()
Dim PDFsFolder As String
Dim ZIPsFolder As String
Dim files As Variant
Dim inputFiles As String, outputZipFile As String
Dim prefix As String
Dim i As Long
PDFsFolder = "C:\path\to\PDF files\" 'CHANGE THIS - folder containing files to be zipped
ZIPsFolder = "C:\path\to\zip files\" 'CHANGE THIS - folder in which output .zip files will be created
If Right(PDFsFolder, 1) <> "\" Then PDFsFolder = PDFsFolder & "\"
If Right(ZIPsFolder, 1) <> "\" Then ZIPsFolder = ZIPsFolder & "\"
With ActiveSheet
'Read values from columns A:B to files array.
'The '+ 1' means the last row of the files array is empty to create a terminating value for the last group of input files in the For Next loop below
files = .Range("A2:B" & .Cells(.Rows.Count, "A").End(xlUp).Row + 1)
End With
prefix = ""
inputFiles = ""
For i = 1 To UBound(files)
If Left(files(i, 1), 3) <> prefix Then
If inputFiles <> "" Then
Zip_Files inputFiles, outputZipFile
End If
prefix = Left(files(i, 1), 3)
inputFiles = PDFsFolder & files(i, 1)
outputZipFile = ZIPsFolder & files(i, 2)
Else
inputFiles = inputFiles & "|" & PDFsFolder & files(i, 1)
End If
Next
MsgBox "Done"
End Sub
Private Sub Zip_Files(ByVal inputFiles As String, ByVal outputZipFile As Variant)
Dim FSO As Object 'Scripting.FileSystemObject
Dim WShell As Object 'Shell32.Shell
Dim WShtempFolder As Object 'Shell32.Folder
Dim WShZipFolder As Object 'Shell32.Folder
Dim file As Variant
Dim CopyHereFlags As Variant
Dim tempFolder As Variant, tempZipFolder As Variant
tempFolder = Environ("temp")
tempZipFolder = tempFolder & "\temp zip"
Set FSO = CreateObject("Scripting.FileSystemObject")
Set WShell = CreateObject("Shell.Application")
'Create temporary folder to contain the files to be zipped. If the temporary folder already exists it is deleted first
If FSO.FolderExists(tempZipFolder) Then FSO.DeleteFolder tempZipFolder, True
Set WShtempFolder = WShell.Namespace(tempFolder)
WShtempFolder.NewFolder Mid(tempZipFolder, InStrRev(tempZipFolder, "\") + 1)
Set WShtempFolder = WShell.Namespace(tempZipFolder)
'Copy input files to the temporary folder. Duplicate file names are automatically renamed because the FOF_RENAMEONCOLLISION flag is specified
CopyHereFlags = FOF_SILENT + FOF_RENAMEONCOLLISION + FOF_NOCONFIRMATION + FOF_NOERRORUI
For Each file In Split(inputFiles, "|")
WShtempFolder.CopyHere file, CopyHereFlags
DoEvents
Next
'Create new .zip file and copy all files in the temporary folder to it
NewZip outputZipFile
Set WShZipFolder = WShell.Namespace(outputZipFile)
WShZipFolder.CopyHere WShtempFolder.Items, CopyHereFlags
'Wait until all files are copied to the .zip file
Do
DoEvents
Sleep 100
Loop Until WShZipFolder.Items.Count = WShtempFolder.Items.Count
Set FSO = Nothing
Set WShell = Nothing
End Sub
'http://www.rondebruin.nl/win/s7/win001.htm
Private Sub NewZip(sPath)
'Create empty Zip File
'If Len(Dir(sPath)) > 0 Then Kill sPath
On Error Resume Next 'trap 'Permission denied' error on Kill command
While Len(Dir(sPath)) > 0 'ensure zip file is deleted
Kill sPath
Wend
On Error GoTo 0
Open sPath For Output As #1
Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Close #1
End Sub
