VBA Help: Email loop with an attachment

[NeoSez]

I went to the Ron de Bruin site and it's no longer there.
Can someone please help me with the VBA code to send emails?
I want to send emails to all the people in my contacts list of like 1000.
In the body, it will say Hello (name of company from column "A")
I have a file (abc.pdf) I would like to attach to each email.
Subject line should have today's date at the end of the line. Eg. Delivery Date (today's date)
Thank you.

A	B	C	D	E
Company	line numbering starting from 2. This is used so I can start at any number for emailing to that company. Eg. I might want to omit email the first 10 people and start at #11 instead. But not necessary if it can't be done.		TO: (email addresses)	CC: (email addresses)

 

[ranman256]

paste code into a module

'NOTE : YOU MUST HAVE THE OUTLOOK X.x Object Library REFERENCE CHECKED IN VBE; Alt-F11, menu,tools, references, Microsoft Outlook XX Object library

this assumes Co Name is col A
email is in col B
filepath to attach is in .J1
adjust as needed

have outlook open
then run: SendAllEmails

Public Sub SendAllEmails()
Dim i As Integer
Dim vEmail, vFile, vCC
Dim vName, vSubj, vBody

'MsgBox "Have Outlook open."
'SetWarnings False

  'the file path for file to attach is in J1.
vFile = Range("J1").Value

Sheets("Contacts").Activate    'goto the email list
  
        'cycle thru the list of email addrs
Range("A2").Select
While ActiveCell.Value <> ""
 
  vName = ActiveCell.Offset(0, 0).Value   'col A
  vEmail = ActiveCell.Offset(0, 1).Value   'col B
  vSubj = " Delivery Date (" & Date & ")"
  vBody = "Hello " & vName
 
  Send1Email vEmail, vSubj, vBody,  vFile

  ActiveCell.Offset(1, 0).Select   'next row
Wend

'SetWarnings True
MsgBox "Done"

End Sub


Private Function Send1Email(ByVal pvTo, ByVal pvSubj, ByVal pvBody,  Optional ByVal pvFile) As Boolean
Dim oMail As Outlook.MailItem
Dim oApp As Outlook.Application

On Error GoTo ErrMail

'NOTE : YOU MUST HAVE THE OUTLOOK X.x Object Library    REFERENCE CHECKED IN VBE; Alt-F11, menu,tools, references, Microsoft Outlook XX Object library

Set oApp = GetApplication("Outlook.Application")  'it may be open already so use this
'Set oApp = CreateObject("Outlook.Application")  'not this

Set oMail = oApp.CreateItem(olMailItem)
With oMail
    .To = pvTo
    .Subject = pvSubj
 
    If Not IsMissing(pvFile) Then .Attachments.Add pvFile, olByValue, 1
 
    .HTMLBody = pvBody
 
    '.Display True
    .Send
End With

Send1Email = True
endit:
Set oMail = Nothing
Set oApp = Nothing
Exit Function

ErrMail:
MsgBox Err.Description, vbCritical, Err
Resume endit
Resume
End Function


Private Function GetApplication(className As String) As Object
' function to encapsulate the instantiation of an application object
Dim theApp As Object
On Error Resume Next
Set theApp = GetObject(, className)
If Err.Number <> 0 Then
    MsgBox "Unable to Get" & className & ", attempting to CreateObject"
    Set theApp = CreateObject(className)
End If

If theApp Is Nothing Then
    Err.Raise Err.Number, Err.Source, "Unable to Get or Create the " & className & "!"
    Set GetApplication = Nothing
End If

'MsgBox "Successfully got a handle on Outlook Application, returning to caller"
Set GetApplication = theApp
End Function

 

[NeoSez]

paste code into a module

'NOTE : YOU MUST HAVE THE OUTLOOK X.x Object Library REFERENCE CHECKED IN VBE; Alt-F11, menu,tools, references, Microsoft Outlook XX Object library

this assumes Co Name is col A
email is in col B
filepath to attach is in .J1
adjust as needed

have outlook open
then run: SendAllEmails

Public Sub SendAllEmails()
Dim i As Integer
Dim vEmail, vFile, vCC
Dim vName, vSubj, vBody

'MsgBox "Have Outlook open."
'SetWarnings False

  'the file path for file to attach is in J1.
vFile = Range("J1").Value

Sheets("Contacts").Activate    'goto the email list
 
        'cycle thru the list of email addrs
Range("A2").Select
While ActiveCell.Value <> ""
 
  vName = ActiveCell.Offset(0, 0).Value   'col A
  vEmail = ActiveCell.Offset(0, 1).Value   'col B
  vSubj = " Delivery Date (" & Date & ")"
  vBody = "Hello " & vName
 
  Send1Email vEmail, vSubj, vBody,  vFile

  ActiveCell.Offset(1, 0).Select   'next row
Wend

'SetWarnings True
MsgBox "Done"

End Sub


Private Function Send1Email(ByVal pvTo, ByVal pvSubj, ByVal pvBody,  Optional ByVal pvFile) As Boolean
Dim oMail As Outlook.MailItem
Dim oApp As Outlook.Application

On Error GoTo ErrMail

'NOTE : YOU MUST HAVE THE OUTLOOK X.x Object Library    REFERENCE CHECKED IN VBE; Alt-F11, menu,tools, references, Microsoft Outlook XX Object library

Set oApp = GetApplication("Outlook.Application")  'it may be open already so use this
'Set oApp = CreateObject("Outlook.Application")  'not this

Set oMail = oApp.CreateItem(olMailItem)
With oMail
    .To = pvTo
    .Subject = pvSubj
 
    If Not IsMissing(pvFile) Then .Attachments.Add pvFile, olByValue, 1
 
    .HTMLBody = pvBody
 
    '.Display True
    .Send
End With

Send1Email = True
endit:
Set oMail = Nothing
Set oApp = Nothing
Exit Function

ErrMail:
MsgBox Err.Description, vbCritical, Err
Resume endit
Resume
End Function


Private Function GetApplication(className As String) As Object
' function to encapsulate the instantiation of an application object
Dim theApp As Object
On Error Resume Next
Set theApp = GetObject(, className)
If Err.Number <> 0 Then
    MsgBox "Unable to Get" & className & ", attempting to CreateObject"
    Set theApp = CreateObject(className)
End If

If theApp Is Nothing Then
    Err.Raise Err.Number, Err.Source, "Unable to Get or Create the " & className & "!"
    Set GetApplication = Nothing
End If

'MsgBox "Successfully got a handle on Outlook Application, returning to caller"
Set GetApplication = theApp
End Function

Thank you for providing the code so quickly. There were a few errors and compile error: user-defined type not defined, was one of the errors. I made the changes below:
Private Function Send1Email(ByVal pvTo, ByVal pvSubj, ByVal pvBody, Optional ByVal pvFile) As Boolean
Dim oMail As Object
Dim oApp As Object
Set oApp = CreateObject("Outlook.Application")
Set oMail = oApp.CreateItem(0)

End Function