Outlook 2007 Macro for sending mail automatically

[srinivasanyadhav]

I have a folder containing purchase orders (in pdf format) for many companies (say 500 companies), which I should send them manually to all the companies twice a month.

(by insert the Purchase order and selecting the E-mail address and send separately to all of them)


Is there any way to automate this work?

[HansV]

Welcome to Eileen's Lounge!

How can we link the purchase orders to e-mail addresses?

[srinivasanyadhav]

can we have a excel sheet having company name (which will be the name for purchase order) in one column and e-mail address in the corresponding column?

[HansV]

Yes, that is possible.

Would you prefer to run the code from the Excel workbook or from Outlook?

[srinivasanyadhav]

Both are OK.

[Rudi]

Just an alternate to what Hans might build; I have used an add-in from Graham Mayor called "Merge many to one" to do this, and it is quite effective. Set up the merge details like name and email and PDF path in a source file (like Excel) and use the add-in to email it to multiple recipients using One to One.

[HansV]

The Word add-in from Graham Mayor mentioned by Rudi should do the job nicely.

For what it's worth, here is a macro that you can run from the Excel workbook with the company names and e-mail addresses. Change the constants at the beginning of the code as needed.

Code: Select all

Sub SendInvoices()
    Const CompanyCol = "A"
    Const MailCol = "B"
    Const FirstRow = 2
    Const FileFolder = "C:\Invoices\"
    Dim LastRow As Long
    Dim StartRow As Long
    Dim CurRow As Long
    Dim Company As String
    Dim Email As String
    Dim Filename As String
    Dim StartedOL As Boolean
    Dim olApp As Object
    Dim olMsg As Object

    On Error Resume Next
    Set olApp = GetObject(Class:="Outlook.Application")
    If olApp Is Nothing Then
        Set olApp = CreateObject(Class:="Outlook.Application")
        If olApp Is Nothing Then
            MsgBox "Cannot start Outlook!", vbExclamation
            Exit Sub
        End If
        StartedOL = True
    End If
    On Error GoTo ErrHandler
    olApp.Session.Logon

    LastRow = Range(CompanyCol & Rows.Count).End(xlUp).Row
    ' Process in batches of 50
    For StartRow = FirstRow To LastRow Step 50
        For CurRow = StartRow To Application.Min(StartRow + 49, LastRow)
            Company = Range(CompanyCol & CurRow).Value
            Filename = FileFolder & Company & ".pdf"
            Email = Range(MailCol & CurRow).Value
            Set olMsg = olApp.CreateItem(0) ' olMailItem
            olMsg.Subject = "Invoice for " & Company
            olMsg.Body = "Dear " & Company & vbCrLf & _
                "Please find the attached invoice." & vbCrLf & _
                "Yours sincerely, Srinavan"
            olMsg.Recipients.Add Email
            olMsg.Attachments.Add Filename
            ' To test, open the message:
            olMsg.Display
            ' For the final version, send it immediately:
            'olMsg.Send
        Next CurRow
    Next StartRow

ExitHandler:
    On Error Resume Next
    If StartedOL And Not olApp Is Nothing Then
        olApp.Quit
    End If
    Exit Sub

ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler
End Sub

The code works best if Outlook has already been started before the macro is run.
In the version above, each e-mail message will be displayed for testing purposes. If it works OK, you can comment out the line

Code: Select all

            olMsg.Display

by prefixing it with an apostrophe ', and uncomment the line

Code: Select all

            'olMsg.Send

by removing the apostrophe. This will cause the macro to send the messages immediately.

[srinivasanyadhav]

Hey Hans,

it's great.
Thanks a lot.

One more thing to fix.
When we run the code, it goes from row 2 to Row 50.
If I have a company name in row 15, for which there is no attachment in the file path, THE CODE STOPS.

I don't want the code to stop in row 15. if the attachment is not in the file path, just want to ignore that particular row and continue from the next row.
So that I can have a common excel sheet, which I don't have to edit each time, according to the files in the file path.

[HansV]

The following version checks whether there is a file to be attached.

Code: Select all

Sub SendInvoices()
    Const CompanyCol = "A"
    Const MailCol = "B"
    Const FirstRow = 2
    Const FileFolder = "C:\Invoices\"
    Dim LastRow As Long
    Dim StartRow As Long
    Dim CurRow As Long
    Dim Company As String
    Dim Email As String
    Dim Filename As String
    Dim StartedOL As Boolean
    Dim olApp As Object
    Dim olMsg As Object

    On Error Resume Next
    Set olApp = GetObject(Class:="Outlook.Application")
    If olApp Is Nothing Then
        Set olApp = CreateObject(Class:="Outlook.Application")
        If olApp Is Nothing Then
            MsgBox "Cannot start Outlook!", vbExclamation
            Exit Sub
        End If
        StartedOL = True
    End If
    On Error GoTo ErrHandler
    olApp.Session.Logon

    LastRow = Range(CompanyCol & Rows.Count).End(xlUp).Row
    ' Process in batches of 50
    For StartRow = FirstRow To LastRow Step 50
        For CurRow = StartRow To Application.Min(StartRow + 49, LastRow)
            Company = Range(CompanyCol & CurRow).Value
            Filename = FileFolder & Company & ".pdf"
            ' Test whether the file to be attached exists
            If Dir(Filename) <> "" Then
                Email = Range(MailCol & CurRow).Value
                Set olMsg = olApp.CreateItem(0) ' olMailItem
                olMsg.Subject = "Invoice for " & Company
                olMsg.Body = "Dear " & Company & vbCrLf & _
                    "Please find the attached invoice." & vbCrLf & _
                    "Yours sincerely, Srinavan"
                olMsg.Recipients.Add Email
                olMsg.Attachments.Add Filename
                ' To test, open the message:
                olMsg.Display
                ' For the final version, send it immediately:
                'olMsg.Send
            End If
        Next CurRow
    Next StartRow

ExitHandler:
    On Error Resume Next
    If StartedOL And Not olApp Is Nothing Then
        olApp.Quit
    End If
    Exit Sub

ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler
End Sub

[srinivasanyadhav]

hey Hans,

Great man!
You have bring down my work by a lot.

is it possible to attach another .pdf file, which is common to all the vendors, to all the E-mail is send through this.
(I will save that file in the same file path)

[HansV]

Yes - I have added a constant OtherFile. Change its value to the filename you need.
This file is added to the message in the loop:

Code: Select all

Sub SendInvoices()
    Const CompanyCol = "A"
    Const MailCol = "B"
    Const FirstRow = 2
    Const FileFolder = "C:\Invoices\"
    ' Name of other attachment
    Const OtherFile = "OtherFile.pdf"
    Dim LastRow As Long
    Dim StartRow As Long
    Dim CurRow As Long
    Dim Company As String
    Dim Email As String
    Dim Filename As String
    Dim StartedOL As Boolean
    Dim olApp As Object
    Dim olMsg As Object

    On Error Resume Next
    Set olApp = GetObject(Class:="Outlook.Application")
    If olApp Is Nothing Then
        Set olApp = CreateObject(Class:="Outlook.Application")
        If olApp Is Nothing Then
            MsgBox "Cannot start Outlook!", vbExclamation
            Exit Sub
        End If
        StartedOL = True
    End If
    On Error GoTo ErrHandler
    olApp.Session.Logon

    LastRow = Range(CompanyCol & Rows.Count).End(xlUp).Row
    ' Process in batches of 50
    For StartRow = FirstRow To LastRow Step 50
        For CurRow = StartRow To Application.Min(StartRow + 49, LastRow)
            Company = Range(CompanyCol & CurRow).Value
            Filename = FileFolder & Company & ".pdf"
            ' Test whether the file to be attached exists
            If Dir(Filename) <> "" Then
                Email = Range(MailCol & CurRow).Value
                Set olMsg = olApp.CreateItem(0) ' olMailItem
                olMsg.Subject = "Invoice for " & Company
                olMsg.Body = "Dear " & Company & vbCrLf & _
                    "Please find the attached invoice." & vbCrLf & _
                    "Yours sincerely, Srinavan"
                olMsg.Recipients.Add Email
                olMsg.Attachments.Add Filename
                ' Add other attachment
                olMsg.Attachments.Add FileFolder & OtherFile
                ' To test, open the message:
                olMsg.Display
                ' For the final version, send it immediately:
                'olMsg.Send
            End If
        Next CurRow
    Next StartRow

ExitHandler:
    On Error Resume Next
    If StartedOL And Not olApp Is Nothing Then
        olApp.Quit
    End If
    Exit Sub

ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler
End Sub

[srinivasanyadhav]

The .pdf file doesn't attach to the mail.


One more thing.

I want to add my Boss mail id in the CC column.

[HansV]

Code: Select all

Sub SendInvoices()
    Const CompanyCol = "A"
    Const MailCol = "B"
    Const FirstRow = 2
    Const FileFolder = "C:\Invoices\"
    ' Name of other attachment
    Const OtherFile = "OtherFile.pdf"
    ' CC address
    Const CCAddress = "theboss@company.com"
    Dim LastRow As Long
    Dim StartRow As Long
    Dim CurRow As Long
    Dim Company As String
    Dim Email As String
    Dim Filename As String
    Dim StartedOL As Boolean
    Dim olApp As Object
    Dim olMsg As Object

    On Error Resume Next
    Set olApp = GetObject(Class:="Outlook.Application")
    If olApp Is Nothing Then
        Set olApp = CreateObject(Class:="Outlook.Application")
        If olApp Is Nothing Then
            MsgBox "Cannot start Outlook!", vbExclamation
            Exit Sub
        End If
        StartedOL = True
    End If
    On Error GoTo ErrHandler
    olApp.Session.Logon

    LastRow = Range(CompanyCol & Rows.Count).End(xlUp).Row
    ' Process in batches of 50
    For StartRow = FirstRow To LastRow Step 50
        For CurRow = StartRow To Application.Min(StartRow + 49, LastRow)
            Company = Range(CompanyCol & CurRow).Value
            Filename = FileFolder & Company & ".pdf"
            ' Test whether the file to be attached exists
            If Dir(Filename) <> "" Then
                Email = Range(MailCol & CurRow).Value
                Set olMsg = olApp.CreateItem(0) ' olMailItem
                olMsg.Subject = "Invoice for " & Company
                olMsg.Body = "Dear " & Company & vbCrLf & _
                    "Please find the attached invoice." & vbCrLf & _
                    "Yours sincerely, Srinavan"
                olMsg.Recipients.Add Email
                ' Add CC
                olMsg.Recipients.Add(CCAddress).Type = 2 ' olCC
                olMsg.Attachments.Add Filename
                ' Add other attachment
                olMsg.Attachments.Add FileFolder & OtherFile
                ' To test, open the message:
                olMsg.Display
                ' For the final version, send it immediately:
                'olMsg.Send
            End If
        Next CurRow
    Next StartRow

ExitHandler:
    On Error Resume Next
    If StartedOL And Not olApp Is Nothing Then
        olApp.Quit
    End If
    Exit Sub

ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler
End Sub

[srinivasanyadhav]

Everything fixed.

Thanks for your great help!
Thanks again.

Srinivasan Ponnurangan
Chennai
INDIA
+91-98416 77464

[HansV]

If your ISP objects to sending a large number of messages in a short time, you can display a message box after each batch of 50 messages. The code will wait until you click OK to resume, or Cancel to stop sending:

Code: Select all

Sub SendInvoices()
    Const CompanyCol = "A"
    Const MailCol = "B"
    Const FirstRow = 2
    Const FileFolder = "C:\Invoices\"
    ' Name of other attachment
    Const OtherFile = "OtherFile.pdf"
    ' CC address
    Const CCAddress = "theboss@company.com"
    Dim LastRow As Long
    Dim StartRow As Long
    Dim CurRow As Long
    Dim Company As String
    Dim Email As String
    Dim Filename As String
    Dim StartedOL As Boolean
    Dim olApp As Object
    Dim olMsg As Object

    On Error Resume Next
    Set olApp = GetObject(Class:="Outlook.Application")
    If olApp Is Nothing Then
        Set olApp = CreateObject(Class:="Outlook.Application")
        If olApp Is Nothing Then
            MsgBox "Cannot start Outlook!", vbExclamation
            Exit Sub
        End If
        StartedOL = True
    End If
    On Error GoTo ErrHandler
    olApp.Session.Logon

    LastRow = Range(CompanyCol & Rows.Count).End(xlUp).Row
    ' Process in batches of 50
    For StartRow = FirstRow To LastRow Step 50
        For CurRow = StartRow To Application.Min(StartRow + 49, LastRow)
            Company = Range(CompanyCol & CurRow).Value
            Filename = FileFolder & Company & ".pdf"
            ' Test whether the file to be attached exists
            If Dir(Filename) <> "" Then
                Email = Range(MailCol & CurRow).Value
                Set olMsg = olApp.CreateItem(0) ' olMailItem
                olMsg.Subject = "Invoice for " & Company
                olMsg.Body = "Dear " & Company & vbCrLf & _
                    "Please find the attached invoice." & vbCrLf & _
                    "Yours sincerely, Srinavan"
                olMsg.Recipients.Add Email
                ' Add CC
                olMsg.Recipients.Add(CCAddress).Type = 2 ' olCC
                olMsg.Attachments.Add Filename
                ' Add other attachment
                olMsg.Attachments.Add FileFolder & OtherFile
                ' To test, open the message:
                olMsg.Display
                ' For the final version, send it immediately:
                'olMsg.Send
            End If
        Next CurRow
        ' Optional - wait until user clicks button
        If MsgBox("Click OK when you're ready to send the next batch," & _
                "Or click Cancel if you want to stop sending.", _
                vbQuestion + vbOKCancel) = vbCancel Then
            Exit For
        End If
    Next StartRow

ExitHandler:
    On Error Resume Next
    If StartedOL And Not olApp Is Nothing Then
        olApp.Quit
    End If
    Exit Sub

ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler
End Sub

[srinivasanyadhav]

hey Hans,
The code suddenly stops working when I change the folder path.
can you check the below code.

Sub SendPO()
Const CompanyCol = "A"
Const MailCol = "B"
Const FirstRow = 2
Const FileFolder = "C:\Users\pur2\Desktop\PO\2014\MAY\TOOL ROOM"
' Name of other attachment
Const OtherFile = "PO TC.pdf"
' CC address
Const CCAddress = "mohan@iljin.com;sundar@iljin.com"
Dim LastRow As Long
Dim StartRow As Long
Dim CurRow As Long
Dim Company As String
Dim Email As String
Dim Filename As String
Dim StartedOL As Boolean
Dim olApp As Object
Dim olMsg As Object

On Error Resume Next
Set olApp = GetObject(Class:="Outlook.Application")
If olApp Is Nothing Then
Set olApp = CreateObject(Class:="Outlook.Application")
If olApp Is Nothing Then
MsgBox "Cannot start Outlook!", vbExclamation
Exit Sub
End If
StartedOL = True
End If
On Error GoTo ErrHandler
olApp.Session.Logon

LastRow = Range(CompanyCol & Rows.Count).End(xlUp).Row
' Process in batches of 500
For StartRow = FirstRow To LastRow Step 500
For CurRow = StartRow To Application.Min(StartRow + 499, LastRow)
Company = Range(CompanyCol & CurRow).Value
Filename = FileFolder & Company & ".pdf"
' Test whether the file to be attached exists
If Dir(Filename) <> "" Then
Email = Range(MailCol & CurRow).Value
Set olMsg = olApp.CreateItem(0) ' olMailItem
olMsg.Subject = "Purchase order - " & Company
olMsg.Body = "Dear Sir " & vbNewLine & _
" " & vbNewLine & _
"Please find the attached Purchase Order." & vbNewLine & _
" " & vbNewLine & _
"Regards," & vbNewLine & _
"Srinivasan P" & vbNewLine & _
"ILJIN Automotive pvt Ltd" & vbNewLine & _
"B1&B2, SIPCOT INDUSTRIAL PARK" & vbNewLine & _
"Irungattukottai, Sriperumbudur" & vbNewLine & _
"Tamilnadu - 602 105" & vbNewLine & _
"Mobile : 98416 77464"
olMsg.Recipients.Add Email
' Add CC
olMsg.Recipients.Add(CCAddress).Type = 2 ' olCC
olMsg.Attachments.Add Filename
' Add other attachment
olMsg.Attachments.Add FileFolder & OtherFile
' To test, open the message:
olMsg.Display
' For the final version, send it immediately:
' olMsg.Send
End If
Next CurRow
Next StartRow

ExitHandler:
On Error Resume Next
If StartedOL And Not olApp Is Nothing Then
olApp.Quit
End If
Exit Sub

ErrHandler:
MsgBox Err.Description, vbExclamation
Resume ExitHandler
End Sub

[srinivasanyadhav]

and here is the attachment!

[HansV]

The value of FileFolder must end in a backslash \

Code: Select all

    Const FileFolder = "C:\Users\pur2\Desktop\PO\2014\MAY\TOOL ROOM\"

Otherwise, there is no \ between the folder path and the filename in

Code: Select all

    Filename = FileFolder & Company & ".pdf"

and

Code: Select all

    olMsg.Attachments.Add FileFolder & OtherFile

[srinivasanyadhav]

thank u Hans!

[srinivasanyadhav]

Dear Hans,

Here is the code below for sending a common msg to all the vendors I deal with.
when I have more than one mail id for a vendor in a cell, like
123@gmail.com;456@gmail.com.

While running the code, the code stops with a error msg "Outlook does not recognize one or more names".
What I have to do to get rid of it?

Code: Select all

Sub SendGenMsg()
     Const CompanyCol = "A"
     Const MailCol = "B"
     Const FirstRow = 2
     Dim LastRow As Long
     Dim StartRow As Long
     Dim CurRow As Long
     Dim Company As String
     Dim Email As String
     Dim Filename As String
     Dim StartedOL As Boolean
     Dim olApp As Object
     Dim olMsg As Object

     On Error Resume Next
     Set olApp = GetObject(Class:="Outlook.Application")
     If olApp Is Nothing Then
         Set olApp = CreateObject(Class:="Outlook.Application")
         If olApp Is Nothing Then
             MsgBox "Cannot start Outlook!", vbExclamation
             Exit Sub
         End If
         StartedOL = True
     End If
     On Error GoTo ErrHandler
     olApp.Session.Logon

     LastRow = Range(CompanyCol & Rows.Count).End(xlUp).Row
     ' Process in batches of 50
     For StartRow = FirstRow To LastRow Step 50
         For CurRow = StartRow To Application.Min(StartRow + 49, LastRow)
             Company = Range(CompanyCol & CurRow).Value
           
                 Email = Range(MailCol & CurRow).Value
                 Set olMsg = olApp.CreateItem(0) ' olMailItem
                 olMsg.Subject = "CONFIRMATION OF BALANCE for " & Company
                 olMsg.Body = "Dear Sir " & vbNewLine & _
"            " & vbNewLine & _
"Thank you for your support!" & vbNewLine & _
"     " & vbNewLine & _
"Kindly send us back the signed copy of Confirmation of Balance statement, which we sent 2 weeks back through First flight courier as early as possible." & vbNewLine & _
"Please contact Mr.Saravanan at saisaravanan@iljin.com or +91-90030 71022  for further queries." & vbNewLine & _
"Kindly ignore this mail if you already sent back the letter" & vbNewLine & _
"                            " & vbNewLine & _
"                            " & vbNewLine & _
"                            " & vbNewLine & _
"Regards," & vbNewLine & _
"Srinivasan P" & vbNewLine & _
"ILJIN Automotive pvt Ltd" & vbNewLine & _
"B1&B2, SIPCOT INDUSTRIAL PARK" & vbNewLine & _
"Irungattukottai, Sriperumbudur" & vbNewLine & _
"Tamilnadu - 602 105" & vbNewLine & _
"Mobile : 98416 77464"

                 olMsg.Recipients.Add Email
                ' Add CC
        olMsg.cc = "mohan@iljin.com;saisaravanan@iljin.com"
        ' To test, open the message:
                 olMsg.Display
                 ' For the final version, send it immediately:
                 olMsg.Send
             
         Next CurRow
     Next StartRow

ExitHandler:
     On Error Resume Next
     If StartedOL And Not olApp Is Nothing Then
         olApp.Quit
     End If
     Exit Sub

ErrHandler:
     MsgBox Err.Description, vbExclamation
     Resume ExitHandler
 End Sub