-
I have code to attach zip files within sub-folders with C:Sales Reports in Microsoft outlook
The code works well and attaches some of the zip files in Outlook as the maximum limit is 20MB
I need my code amended to attach up to a max limit of 20MB and when this is reached to create a second to attach the balance of the zip files (the total off al the Zip files is less than 40MB so I only need two emails)
there are 18 zip files in the sub-folders. an alternative would be to attach the first 10 to the first email and the balance to be attached on the second email
Your assistance in this regard is most appreciated
-
Sub CreateEmail() '--------------------------------------------------- 'DECLARE AND SET VARIABLES Dim outApp As Object Dim OutMail As Object Dim strbody As String Dim Filename As String Set outApp = CreateObject("Outlook.Application") Set OutMail = outApp.CreateItem(0) '--------------------------------------------------- 'CREATE EMAIL BODY strbody = "Hi " & Join(Application.Transpose(Range("D1:D5").Value)) & vbNewLine & vbNewLine strbody = strbody & "Attached Please find latest Sales Reports" & vbNewLine & vbNewLine strbody = strbody & "Regards" & vbNewLine & vbNewLine '--------------------------------------------------- 'BUILD EMAIL On Error Resume Next With OutMail .to = Join(Application.Transpose(Range("E1:E5").Value), ";") .CC = "" .BCC = "" .Subject = "Sales Reports" .Body = strbody Path = "C:Sales Reports" '-------------------------------------------- 'GET FILENAMES ' Filename = Dir(Path & "*.zip") ' Do While Len(Filename) > 0 ' .Attachments.Add Filename ' Filename = Dir ' Loop Dim fso, oFolder, oSubfolder, oFile, col As Collection Set fso = CreateObject("Scripting.FileSystemObject") Set col = New Collection col.Add fso.GetFolder(Path) Do While col.Count > 0 Set oFolder = col(1) col.Remove 1 For Each oSubfolder In oFolder.SubFolders col.Add oSubfolder Next oSubfolder For Each oFile In oFolder.Files If CStr(oFile) Like "*.zip" Then .Attachments.Add CStr(oFile) End If Next oFile Loop .Display End With '--------------------------------------------------- 'CLEANUP On Error GoTo 0 Set OutMail = Nothing Set outApp = Nothing Set fso = Nothing End Sub
I have also posted on https://www.excelforum.com/excel-programming-vba-macros/1339082-macro-to-attach-zip-files-within-sub-folders.html
-
Hi Howard,
you should loop through that folder outside your CreateEmail procedure, collect files, when they reach your limit, create an email.
Should be like this:
Dim FSO As Object, FSize As Long, FilesCollection As Collection
Set FilesCollection = New Collection
Set FSO = CreateObject("Scripting.FileSystemObject")
ProcessFolderFiles FSO.GetFolder("C:userscatalindesktop"), FSize, FilesCollection
If FilesCollection.Count > 0 Then CreateEmail FilesCollection 'there may be remaining files, totalizing less than 18 mb
End Sub
Sub ProcessFolderFiles(objFolder As Object, ByRef FSize As Long, ByRef FilesCollection As Collection)
Dim SubFld As Object, aFile As Object
For Each SubFld In objFolder.SubFolders
ProcessFolderFiles SubFld, FSize, FilesCollection
Next
For Each aFile In objFolder.Files
FSize = FSize + aFile.Size
Debug.Print FSize
FilesCollection.Add aFile.Path
If FSize > 18000000 Then 'set to 18 mb, you can set to FilesCollection.count>9 for example
CreateEmail FilesCollection
Set FilesCollection = New Collection
FSize = 0 'reset file size
End If
Next
End Sub
Then, in your CreateEmail procedure, attach to email the files from FilesCollection collection received from outside procedure.
Of course, CreateEmail() should become:
Sub CreateEmail(byref FilesCollection as collection)
You should update the other forum, if the solution works, to inform them you have a solution, you don't want to waste their time.
Many Thanks for the help
