Email Excel File to all entries on "Contacts" tab

[appelq]

I have an Excel Workbook file, that is revised periodically.
I have a Worksheet in the workbook that holds the Contact info for people that need to receive a copy whenever it is updated.

So the question is if I had the contacts as a list of email addresses, is it possible to create a macro (preferably with a button on the main worksheet) to email the file to all of the names in the contacts list?

I envision this working similar to when I click File / Send To... / email recipient and my Outlook opens up with the file already attached, AND all of the email addresses auto-filled into the TO field of the email.

Sub question would be how to automatically set the Subject line text and Body text.

Thanks in advance,
Appelq

 

[firefytr]

Hi there,

You could use something like this ..

Sub EmailWorkbookToRecipients()
    Dim olApp As Object, olMsg As Object, wb As Workbook, c As Range
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Set olApp = CreateObject("Outlook.Application")
    For Each c In Sheets("Sheet1").Range("A1:A20") 'set to desired area
        Set olMsg = olApp.CreateItem(0)
        With olMsg
            .To = c.Value
            .Subject = "Enter subject" 'change as desired
            .Body = "Enter Body" 'change as desired
            .Attachments.Add ThisWorkbook.FullName 'workbook must be saved first
            .Display    'change to .Send if you don't want displayed, Redemption will be needed though
        End With
    Next c
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Set olApp = Nothing
    Set olMsg = Nothing
End Sub

HTH

-----------
Regards,
Zack Barresse

 

[appelq]

Zack,
Thanks, this is great. I just had two minor issues:
In the line:
<< For Each c In Sheets("Sheet1").Range("A1:A20")>>
How can I make that a dynamic range size so the user does not have to modify the macro code if they add email addresses to their Contacts worksheet?
In my test, I entered to addresses in cells A1 and A2 but the loop when through A1 : A20 as hard coded in the line above.

A second issue arose because it created 20 Emails due to the way the loop is constructed (I guess). I has 2 addresses so 2 emails had entries in the TO field, and 18 emails had nothing in the TO field.

How can I change the code so that it makes 1 email, with each address appended to the line:
(i.e. me@mydomain.com; you@yourdomain.com; ...)?
It should loop through all the rows until it encounters a blank row and then stops?

Side question: Is there an easy way to place a clickable Button on a sheet to call this macro?

Thanks again for your input.

appelq

 

[infinitelo]

have you considered a mail merge???


if it is to be it's up to me

 

[firefytr]

Maybe ...

Sub EmailWorkbookToRecipients()
    Dim olApp As Object, olMsg As Object, wb As Workbook, c As Range, strTo As String, i As Long
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Set olApp = CreateObject("Outlook.Application")
    For Each c In Sheets("Sheet1").Range("A1", Sheets("Sheet1").Cells(Rows.Count, "A").End(xlup))
        If Len(c.Value) <> 0 And InStr(1, c.Value, "@") <> 0 Then
            Set olMsg = olApp.CreateItem(0)
            With olMsg
                i = 0
                While c.Offset(0, i).Value <> ""
                    .To = strTo & "; " & c.Offset(0, i).Value
                    i = i + 1
                Wend
                .Subject = "Enter subject" 'change as desired
                .Body = "Enter Body" 'change as desired
                .Attachments.Add ThisWorkbook.FullName 'workbook must be saved first
                .Display    'change to .Send if you don't want displayed, Redemption will be needed though
            End With
        End If
    Next c
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Set olApp = Nothing
    Set olMsg = Nothing
End Sub

I don't know much about mail merge, but you may want to explore that if infinitelo thinks it's a valid solution.

HTH

Regards,
Zack Barresse

Simplicity is the ultimate sophistication. What is a MS MVP? PODA
- Leonardo da Vinci

 

[appelq]

Ok I have it working with the code shown below.

Now may user wants to change it so that they can email only the current Worksheet, not the whole file.

How could I modify the below to do that?

Sub EmailToContacts()
Dim olApp As Object, olMsg As Object
Dim wb As Workbook, c As Range
Dim strto As String, cell As Range
Application.ScreenUpdating = False
Application.EnableEvents = False
Set olApp = CreateObject("Outlook.Application")
For Each cell In ThisWorkbook.Sheets("Contacts").Columns("A").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "*@*" Then
strto = strto & cell.Value & ";"
End If
Next
strto = Left(strto, Len(strto) - 1)
Set olMsg = olApp.CreateItem(0)
With olMsg
.To = strto
.Subject = "This is a test" 'change as desired
.Body = "Here's the update"
.Attachments.Add thisWorkbook.FullName
.Display 'change to .Send to not display
End With
Application.EnableEvents = True
Application.ScreenUpdating = True
Set olApp = Nothing
Set olMsg = Nothing
End Sub

 

[firefytr]

Maybe something like this ...

Sub EmailToContacts()
    Dim olApp As Object, olMsg As Object
    Dim wb As Workbook, wbTemp As Workbook, c As Range
    Dim strTo As String, rng As Range, strTemp As String
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Set olApp = CreateObject("Outlook.Application")
    For Each rng In ThisWorkbook.Sheets("Contacts").Columns("A").Cells.SpecialCells(xlCellTypeConstants)
        If rng.Value Like "*@*" Then
            strTo = strTo & rng.Value & ";"
        End If
    Next
    strTo = Left(strTo, Len(strTo) - 1)
    '### Add here...
    strTemp = "C:\YourFileNameHere"
    ActiveSheet.Copy
    Set wbTemp = ActiveWorkbook
    wbTemp.SaveAs strTemp
    wbTemp.Close
    '###
    Set olMsg = olApp.CreateItem(0)
    With olMsg
        .To = strTo
        .Subject = "This is a test"
        .Body = "Here's the update"
        .Attachments.Add strTemp '### Amend this line
        .Display
    End With
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Set olApp = Nothing
    Set olMsg = Nothing
End Sub

Regards,
Zack Barresse

Simplicity is the ultimate sophistication. What is a MS MVP? PODA
- Leonardo da Vinci

 

[appelq]

Zack,
You Rock!
Works great thanks!

Appelq

 

[firefytr]

No problem, glad to help.

Regards,
Zack Barresse

Simplicity is the ultimate sophistication. What is a MS MVP? PODA
- Leonardo da Vinci