I need a macro to send bulk mails where mail id willl be in excel & subject & content in the mail body will be common, And also a pdf as attachment.
I am having one but need to rectify it
Code: Select all
Sub Mail()
Dim r As Long
Dim m As Long
Dim objOL As Object
Dim objMsg As Object
Dim blnStart As Boolean
' Try to open Outlook
On Error Resume Next
Set objOL = GetObject(Class:="Outlook.Application")
If objOL Is Nothing Then
Set objOL = CreateObject(Class:="Outlook.Application")
If objOL Is Nothing Then
MsgBox "Failed to start Outlook!", vbCritical
Exit Sub
End If
blnStart = True
End If
On Error GoTo ErrHandler
objOL.Session.Logon
' Determine last used row
m = Range("B" & Rows.Count).End(xlUp).Row
' Loop through the rows
For r = 2 To m
' Check if e-mail address is filled in
If Range("B" & r).Value <> "" Then
' Create message
Set objMsg = objOL.CreateItem(0) ' olMailItem
' Recipient
objMsg.Recipients.Add Range("B" & r)
' Subject
objMsg.Subject = "Reminder"
' Body
objMsg.Body = "Dear " & Range("A" & r).Value & "," & vbCrLf & vbCrLf & _
"Greetings from " & Range("G" & r).Value & "," & vbCrLf & vbCrLf & _
"We are happy to inform you that the " & Range("C" & r).Value & _
" you have taken from our branch of " & Range("F" & r).Text & _
" is falling due on " & Range("D" & r).Text & _
". Please visit the branch to prolong our relationship or SMS to " & _
Range("E" & r).Text & ". Our executive will contact you." & vbCrLf & vbCrLf & _
"Regards," & vbCrLf & "ABC Ltd"
' Use only one of the next two instructions
' For testing: display the message
objMsg.Display
' For the final version: send the message
objMsg.Attachments.Add ("C:\test.txt")
'objMsg.Send
End If
Next r
ExitHandler:
On Error Resume Next
If blnStart And Not objOL Is Nothing Then
objOL.Quit
End If
Exit Sub
ErrHandler:
MsgBox Err.Description, vbExclamation
Resume ExitHandler
ActiveWorkbook.Save
ChDir "C:\Documents and Settings\Administrator\Desktop"
ActiveWorkbook.SaveAs Filename:= _
"C:\Documents and Settings\Administrator\Desktop\Test.xlsm", FileFormat:= _
xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
ActiveWorkbook.Save
ActiveWorkbook.Save
End Sub
Ananthan
