I have done this before and it does work but, Might be due to multiple process code have contradicts that prevents the attachments from sending. Can anyone help debug the issue? Some or most of this from automation online that really help but still not resolved. Please help me figure this out, Only the attchment cannot be send out for b2 and e2 its a content using file path, the path is correct so far but still would not send.
VBA Code:
Sub BulkMailxmas()
Application.ScreenUpdating = False
Dim outApp As Object
Dim outMail As Object
' Variables to hold values for different items of mail
Dim sendTo As String, subj As String, atchmnt As String
Dim msg1 As String, msg2 As String, ccTo As String, bccTo As String
Dim lstRow As Long
Dim rng As Range
Dim cell As Range
Dim TodayDate As String
Dim LogoPath As String
Dim AdditionalAtchmnt As String
Dim userProfile As String ' To store the user's profile path
' Get the date value from K2 on the "Email" sheet
' Check if the value in K2 is a valid date
If IsDate(ThisWorkbook.Sheets("Email").Range("K2").Value) Then
TodayDate = Format(ThisWorkbook.Sheets("Email").Range("K2").Value, "dd/mm/yyyy")
Else
' If not a valid date, use today's date as fallback
TodayDate = Format(Date, "dd/mm/yyyy")
End If
' Activate the "Email" sheet
ThisWorkbook.Sheets("Email").Activate
' Getting last row of containing email id in column C
lstRow = Cells(Rows.Count, 3).End(xlUp).Row
' Set the range for email addresses in column C
Set rng = Range("C2:C" & lstRow)
' Get the additional attachment file path from E2
AdditionalAtchmnt = ThisWorkbook.Sheets("Email").Range("E2").Value
' Initialize Outlook object
Set outApp = CreateObject("Outlook.Application")
On Error GoTo cleanup ' Handle any error during object creation
' Get the user's profile path dynamically
userProfile = Environ("USERPROFILE")
' Get dynamic values from cells D2, D3, and J2
Dim senderName As String, senderTitle As String, footerText As String, emailreff As String
senderName = ThisWorkbook.Sheets("Email").Range("D2").Value ' Get sender's name from D2
senderTitle = ThisWorkbook.Sheets("Email").Range("D3").Value ' Get sender's title from D3
footerText = ThisWorkbook.Sheets("Email").Range("D4").Value ' Get sender's email from D4
emailreff = ThisWorkbook.Sheets("Email").Range("J2").Value ' Get "SentOnBehalfOfName" from J2
' Loop through each cell in the range
For Each cell In rng
sendTo = cell.Value ' Email address
atchmnt = cell.Offset(0, -1).Value ' Attachment path from column B
ccTo = "" ' Initialize CC
' Get the recipient name from column A for the greeting
Dim recipientName As String
recipientName = cell.Offset(0, -2).Value ' Get the recipient name from column A (2 columns left from C)
' Concatenate CC emails from columns F, G, H, and I
If ThisWorkbook.Sheets("Email").Range("F2").Value <> "" Then
ccTo = ThisWorkbook.Sheets("Email").Range("F2").Value
End If
If ThisWorkbook.Sheets("Email").Range("G2").Value <> "" Then
If ccTo <> "" Then ccTo = ccTo & ";" & ThisWorkbook.Sheets("Email").Range("G2").Value Else ccTo = ThisWorkbook.Sheets("Email").Range("G2").Value
End If
If ThisWorkbook.Sheets("Email").Range("H2").Value <> "" Then
If ccTo <> "" Then ccTo = ccTo & ";" & ThisWorkbook.Sheets("Email").Range("H2").Value Else ccTo = ThisWorkbook.Sheets("Email").Range("H2").Value
End If
If ThisWorkbook.Sheets("Email").Range("I2").Value <> "" Then
If ccTo <> "" Then ccTo = ccTo & ";" & ThisWorkbook.Sheets("Email").Range("I2").Value Else ccTo = ThisWorkbook.Sheets("Email").Range("I2").Value
End If
' Create the email body with dynamic values
msg1 = "<html><body style='font-family: Helvetica; font-size: 11pt;'>" & _
"<p>Hi " & recipientName & ",</p>" & _
"<p>Please find attached the invoice and billing report for the fortnight ended " & TodayDate & ".</p>" & _
"<p>Thank you.</p>" & _
"<p>Best regards,</p>" & _
"<p>" & senderName & "<br>" & senderTitle & "</p>"
' Ensure msg2 (footer) is dynamically created with the footerText from D4
msg2 = "<p>Suite 1, Level 3, 250 Cam Road<br>" & _
"Camberwell, VIC 3124<br>" & _
"+123 456789<br>" & _
"<p>" & footerText & "<br>" & _
"www.asampleonly.com.au</p>" & _
"</body></html>"
' Set the subject line based on the date in K2
subj = "Disbursement and Billing Report for " & TodayDate
' Create a new email item
On Error Resume Next ' Handle any error during object creation
Set outMail = outApp.CreateItem(0)
' Writing and sending mail in new mail
With outMail
.To = sendTo
.CC = ccTo ' Set CC recipients
.Subject = subj
.sentOnBehalfOfName = emailreff ' Get "SentOnBehalfOfName" from J2
.HTMLBody = msg1 & _
"<img src='" & userProfile & "\Desktop\AS LOGO 1\AS2.jpg' width=300>" & msg2 & _
"<img src='" & userProfile & "\Desktop\AS LOGO 1\as3.png' width=300>"
' Debugging: print the file paths to the Immediate window
Debug.Print "Main Attachment Path: " & atchmnt
Debug.Print "Additional Attachment Path: " & AdditionalAtchmnt
' Check if the main attachment exists before adding
If Len(atchmnt) > 0 And Dir(atchmnt) <> "" Then
.Attachments.Add atchmnt ' Add the main attachment from column B
Else
MsgBox "Main attachment not found: " & atchmnt
End If
' Check if the additional attachment exists before adding
If Len(AdditionalAtchmnt) > 0 And Dir(AdditionalAtchmnt) <> "" Then
.Attachments.Add AdditionalAtchmnt ' Add the additional attachment from E2
Else
MsgBox "Additional attachment not found: " & AdditionalAtchmnt
End If
.Send ' Send mail without any notification
End With
On Error GoTo 0 ' Reset error handling
Set outMail = Nothing ' Clear outMail object for next mail
Next cell ' Loop ends
cleanup: ' Freeing all objects created
Set outApp = Nothing
Application.ScreenUpdating = True
End Sub
Last edited by a moderator:
