Hi guys,
I have been struggling with my macro for the whole day and I really don't know what to do. Basically macro is supposed to add attachments to the mail based on criteria set (to follow same order as in the file), however I am experiencing overflow issue all the time.
I have been struggling with my macro for the whole day and I really don't know what to do. Basically macro is supposed to add attachments to the mail based on criteria set (to follow same order as in the file), however I am experiencing overflow issue all the time.
VBA Code:
Sub AttachFinalTermsPDFToEmail()
Dim OutlookApp As Object
Dim OutlookMail As Object
Dim ws As Worksheet
Dim LastRow As Long
Dim i As Long
Dim FilePath As String
Dim FinalTermsNumber As String
Dim FileName As String
Dim FolderPath As String
Dim TotalSize As Double
Dim FileSize As Double
Dim EmailLimit As Double
Dim FileList As Collection
Dim EmailCount As Integer
Dim fso As Object
On Error GoTo ErrorHandler
' Initialize FileSystemObject
Set fso = CreateObject("Scripting.FileSystemObject")
' Initialize Outlook Application
Set OutlookApp = CreateObject("Outlook.Application")
' Set the worksheet object
Set ws = ThisWorkbook.Sheets("Tabelle 1")
' Set the folder path where the PDF files are stored
FolderPath = ""
' Check if the folder path exists
If Not fso.FolderExists(FolderPath) Then
MsgBox "The specified folder path does not exist: " & FolderPath, vbCritical
Exit Sub
End If
' Set email attachment size limit (20MB in bytes)
EmailLimit = 20 * 1024 * 1024
' Find the last row with data in the Final Terms No column
LastRow = ws.Cells(ws.Rows.Count, "T").End(xlUp).Row
' Initialize a collection to hold file paths
Set FileList = New Collection
TotalSize = 0
EmailCount = 1
' Loop through each Final Terms number starting from row 9
For i = 9 To LastRow
FinalTermsNumber = ws.Cells(i, 20).Value
If Trim(FinalTermsNumber) <> "" Then
FileName = Dir(FolderPath & "*-" & FinalTermsNumber & "*.pdf")
Do While FileName <> ""
FilePath = FolderPath & FileName
FileSize = fso.GetFile(FilePath).Size
If FileSize > EmailLimit Then
MsgBox "File " & FileName & " exceeds the email size limit and will not be attached.", vbExclamation
ElseIf TotalSize + FileSize > EmailLimit Then
SendEmailWithAttachments OutlookApp, FileList, EmailCount
Set FileList = New Collection
TotalSize = 0
EmailCount = EmailCount + 1
Else
FileList.Add FilePath
TotalSize = TotalSize + FileSize
End If
FileName = Dir()
Loop
End If
Next i
If FileList.Count > 0 Then
SendEmailWithAttachments OutlookApp, FileList, EmailCount
End If
MsgBox "Emails created successfully. Please review and send them manually."
ExitSub:
' Release objects
Set OutlookMail = Nothing
Set OutlookApp = Nothing
Exit Sub
ErrorHandler:
MsgBox "An error occurred: " & Err.Description, vbCritical
Resume ExitSub
End Sub
Sub SendEmailWithAttachments(OutlookApp As Object, FileList As Collection, EmailCount As Integer)
Dim OutlookMail As Object
Dim i As Integer
' Create a new mail item
Set OutlookMail = OutlookApp.CreateItem(0)
' Add attachments to the mail item
For i = 1 To FileList.Count
OutlookMail.Attachments.Add FileList(i)
Next i
' Customize email properties
With OutlookMail
.Subject = "Terms PDFs"
.Body = "Please find attached the Terms PDFs."
.To = ""
' Add more recipients, CCs, etc. as needed
End With
' Display the mail item (change .Send to .Display if you want to review before sending)
OutlookMail.Display
' Release object
Set OutlookMail = Nothing
End Sub
Last edited by a moderator:
