Solved: Generate Email BCC from Column of Email Addresses

[Opv]

I have a workbook of contact information for Classmates from high school. I am wanting a script that will automatically generate an email to all my classmates keeping them up to date on the upcoming class reunion.

The addresses are in the cells L3:L250; however, some of the entries do not have email addresses. Consequently, I need to concatenate all the rows that have an email address, insert a "; " between each one, and omit the rows that do not have an email address. Then, I'd like, if possible, for the generated list to automatically open Outlook and insert the list in the BCC field. If that is not possible, the list can be generated to a cell below R250 and I can manually copy and paste the list to Outlook.

Possible?

[domfootwear]

I have a workbook of contact information for Classmates from high school. I am wanting a script that will automatically generate an email to all my classmates keeping them up to date on the upcoming class reunion.

The addresses are in the cells L3:L250; however, some of the entries do not have email addresses. Consequently, I need to concatenate all the rows that have an email address, insert a "; " between each one, and omit the rows that do not have an email address. Then, I'd like, if possible, for the generated list to automatically open Outlook and insert the list in the BCC field. If that is not possible, the list can be generated to a cell below R250 and I can manually copy and paste the list to Outlook.

Possible?

Pls post your Excel sample.
Or you can check below link:
http://www.rondebruin.nl/sendmail.htm

[Opv]

Attached is a dummy version of my database. You will note in the column to the right of the email addresses I have used concatenate to pull together the First Name,Last Name," <",email address",">" in preparation for generating the the email mailing list. So, now the column in question is Column M.

I hope this helps.

Thanks,

Opv

[GTO]

...Consequently, I need to concatenate all the rows that have an email address, insert a "; " between each one, and omit the rows that do not have an email address. Then, I'd like, if possible, for the generated list to automatically open Outlook and insert the list in the BCC field. If that is not possible, the list can be generated to a cell below R250 and I can manually copy and paste the list to Outlook.

Possible?

I did not look at getting or creating an instance of Outlook, but as I understand it, the first part is to get all the rows in Col M that have vals into a string.

I did it as a simple function, the return val you could copy to clipboard, or to a cell, or of course, enter into bcc with additional code...


Option Explicit

Sub CallIt()

MsgBox "The string will cutoff here due to length, but looks like..." & _
String(2, vbCrLf) & _
DistributionList

'Debug.Print strDistributionList
End Sub
Function DistributionList() As String
Dim _
wks As Worksheet, _
rngLRow As Range, _
strDistributionList As String, _
aryEmailAddresses As Variant, _
a As Variant

Set wks = ThisWorkbook.Worksheets("MyContacts")
Set rngLRow = RangeFound(wks.Range("M3:M" & Rows.Count))

If rngLRow Is Nothing Then Exit Function

aryEmailAddresses = Range(wks.Range("M3"), rngLRow).Value

For Each a In aryEmailAddresses
If Not a = vbNullString Then
strDistributionList = strDistributionList & a & "; "
End If
Next

DistributionList = IIf(Len(strDistributionList) > 3, _
Left$(strDistributionList, Len(strDistributionList) - 2), _
vbNullString)
End Function

Function RangeFound(SearchRange As Range, _
Optional FindWhat As String = "*", _
Optional StartingAfter As Range, _
Optional LookAtTextOrFormula As XlFindLookIn = xlValues, _
Optional LookAtWholeOrPart As XlLookAt = xlPart, _
Optional SearchRowCol As XlSearchOrder = xlByRows, _
Optional SearchUpDn As XlSearchDirection = xlPrevious, _
Optional bMatchCase As Boolean = False) As Range

If StartingAfter Is Nothing Then
Set StartingAfter = SearchRange(1)
End If

Set RangeFound = SearchRange.Find(What:=FindWhat, _
After:=StartingAfter, _
LookIn:=LookAtTextOrFormula, _
LookAt:=LookAtWholeOrPart, _
SearchOrder:=SearchRowCol, _
SearchDirection:=SearchUpDn, _
MatchCase:=bMatchCase)
End Function

Hope that helps,

Mark

[GTO]

ACK!!! That was stoopid...

Not tested (have to hit the sack), but change:


If rngLRow Is Nothing Then Exit Function

To:


If rngLRow Is Nothing Then
DistributionList = vbNullString
Exit Function
End If


Mark

[Opv]

Thanks. I don't know if I'm doing something wrong or what. But when I copy and paste the code, it gets pasted as a continuous row rather than as individual lines as displayed in your post. Also, the code is highlighted in red and will not run until such time as it is manually split out into the proper individual rows.

Is there a way to get around this problem?

[Opv]

I finally got the code installed and laid out properly on individual rows. The macro that calls the function and simulates the script in a message box. It seems to work fine, but I don't see an actual function to actually run the function in production?

[lucas]

Mark pretty specifically told you that he did not create the instance of outlook and that you would need further code in post 4.

He tackled the part where you need to compile your list if I understand correctly.

Have you read the help files or done anything yourself towards getting an instance of outlook running?

There are plenty of threads here in the forum and some kb entries.

Here's a little snippit that sends email to a specific address and has the .bcc line in it too.

You just need to take the list in the form of variable from Mikes code and add it to that line of this code. If you have trouble, post back here.

Sub eMailActiveWorkbook()
Dim OL As Object
Dim EmailItem As Object
Dim Wb As Workbook
Application.ScreenUpdating = False
Set OL = CreateObject("Outlook.Application")
Set EmailItem = OL.CreateItem(olMailItem)
Set Wb = ActiveWorkbook
Wb.Save
With EmailItem
.Subject = "Insert Subject Here"
.Body = "Insert message here" & vbCrLf & _
"Line 2" & vbCrLf & _
"Line 3"
.To = "steve66049@yahoo.Com"
.BCC = "joe@aol.com"
.Importance = olImportanceNormal 'Or olImprotanceHigh Or olImprotanceLow
.Attachments.Add Wb.FullName
.Display
' .Send
End With

Application.ScreenUpdating = True
Set Wb = Nothing
Set OL = Nothing
Set EmailItem = Nothing
End Sub

PS. You will have to set a reference to the Microsoft Outlook xx.0 Object library.
Do that in the VBE. Go to tools - references and add the library by checking it.

[Opv]

I'm afraid I'm quite the novice. I understand just enough to copy and paste the code. When you start talking about combining two scripts and making the modifications to make the combined script work, I'm totally lost.

[Opv]

Well, I don't know what I did but I somehow seemed to have stumbled upon something that might be working. I'll leave the thread unsolved for now until I test the script and make sure it stands up to some additional testing. If it continues to work, I'll post the combined code in case someone else ever needs it. Thanks to those of you who contributed the needed code.

[GTO]

Hi there,

I'm glad you are making progress :-) If you are already on a path, certainly disregard this; but as I had already completed it, just in case of use.

Similar to Steve's example, however, I chose to write it so that Outlook already has to be up and runnning. Not exactly what you asked for, but I was thinking that if this at work, there may be a password required to logon anyways.


Sub MailItem_Create()
Dim OTL As Object 'Outlook.Application
Dim otlNewMailItem As Object 'MailItem
Dim bolNotRunning As Boolean
Dim strRecipList As String

'// Assign the value returned by the function 'DistributionList' to a string variable//
strRecipList = DistributionList

'// If nothing was returned (an empty string), bailout... //
If strRecipList = vbNullString Then
MsgBox "No list of recipients was created; not mail msg created...", 0, vbNullString
Exit Sub
End If

'// Skip past an error if encountered, but ONLY for as long as we need to. Attempt //
'// to set a reference to Outlook. If Outlook is not running, this will fail and an//
'// error will be raised. If that happens, we'll set a flag to tell us. //
On Error Resume Next
Set OTL = GetObject(, "Outlook.Application")
If Err.Number > 0 Then
bolNotRunning = True
End If
On Error GoTo 0

'// If Outlook was not running, bailout and tell user why. //
If bolNotRunning Then
MsgBox "Outlook is not running. Please start Outlook and try again.", _
vbCritical, _
vbNullString
Exit Sub
End If

'// If we made it this far, we should have a list as well as know that Outlook is //
'// running. So, we'll set a reference to a newly created mail item (a new //
'// message) //
Set otlNewMailItem = OTL.CreateItem(0) ' olMailItem

'// With the new mail item, we'll plunk our list into the BCC area. Then (not well //
'// tested), I think you may have to resolve the addresses against your address book.//
'// I am not sure of course, and did not build any handling for that. Frankly, you //
'// are really attempting to learn two different things at one time. I think after //
'// you see where you get thus far, you may want to start a thread in the Outlook //
'// forum here, referencing this thread. //
With otlNewMailItem
.BCC = strRecipList
otlNewMailItem.Recipients.ResolveAll
.Display
End With

Set OTL = Nothing
End Sub

Again, just if of any help.

Mark

PS - you'll see that I included a simple way to call the previously posted function :-)

[Opv]

The following is how I accidentally combined the two original scripts that were suggested, one for for generating the mailing list and the other for putting the generated list into Outlook. As I stated before, I haven't a clue how I ended up with this combination. I tried several that didn't work. The following code seems to work (for now anyway) whether Outlook is running or not. (You will note that I modifed the range definition to accommodate a change in the column that contains the list of classmates with email addresses.)

Feel free to point how how this code is inefficient or just poor, for whatever reason. As I said, it works, but I'm sure it could likely be accomplished more effectively and efficiently.


Option Explicit

Sub eMailClassmates()
Dim OL As Object
Dim EmailItem As Object
Dim Wb As Workbook
Application.ScreenUpdating = False

DistributionList

Set OL = CreateObject("Outlook.Application")
Set EmailItem = OL.CreateItem(olMailItem)
Set Wb = ActiveWorkbook
Wb.Save
With EmailItem
.Subject = "Notice to Alumni!"
'.Body = "Insert message here" & vbCrLf & _
'"Line 2" & vbCrLf & _
'"Line 3"
.To = "High School Classmates <someone@mailinator.com>"
.BCC = DistributionList
.Importance = olImportanceHigh 'Or olImprotanceNormal Or olImprotanceLow
'.Attachments.Add Wb.FullName
.Display
' .Send
End With

Application.ScreenUpdating = True
Set Wb = Nothing
Set OL = Nothing
Set EmailItem = Nothing
End Sub

Function DistributionList() As String
Dim _
wks As Worksheet, _
rngLRow As Range, _
strDistributionList As String, _
aryEmailAddresses As Variant, _
a As Variant

Set wks = ThisWorkbook.Worksheets("MyContacts") 'Change worksheet as needed
Set rngLRow = RangeFound(wks.Range("O3:O" & Rows.Count)) 'Change range as needed

If rngLRow Is Nothing Then
DistributionList = vbNullString
Exit Function
End If

aryEmailAddresses = Range(wks.Range("O3"), rngLRow).Value 'Change range as needed.

For Each a In aryEmailAddresses
If Not a = vbNullString Then
strDistributionList = strDistributionList & a & "; "
End If
Next

DistributionList = IIf(Len(strDistributionList) > 3, _
Left$(strDistributionList, Len(strDistributionList) - 2), _
vbNullString)
End Function

Function RangeFound(SearchRange As Range, _
Optional FindWhat As String = "*", _
Optional StartingAfter As Range, _
Optional LookAtTextOrFormula As XlFindLookIn = xlValues, _
Optional LookAtWholeOrPart As XlLookAt = xlPart, _
Optional SearchRowCol As XlSearchOrder = xlByRows, _
Optional SearchUpDn As XlSearchDirection = xlPrevious, _
Optional bMatchCase As Boolean = False) As Range

If StartingAfter Is Nothing Then
Set StartingAfter = SearchRange(1)
End If

Set RangeFound = SearchRange.Find(What:=FindWhat, _
After:=StartingAfter, _
LookIn:=LookAtTextOrFormula, _
LookAt:=LookAtWholeOrPart, _
SearchOrder:=SearchRowCol, _
SearchDirection:=SearchUpDn, _
MatchCase:=bMatchCase)

End Function

[Opv]

The code below works fine for what it is designed to do. How could I modify the code to also take into account including only visible rows when the data is filtered?


Option Explicit

Sub eMailClassmates()
Dim OL As Object
Dim EmailItem As Object
Dim Wb As Workbook
Application.ScreenUpdating = False

DistributionList

Set OL = CreateObject("Outlook.Application")
Set EmailItem = OL.CreateItem(olMailItem)
Set Wb = ActiveWorkbook
Wb.Save
With EmailItem
.Subject = "Notice to Alumni!"
'.Body = "Insert message here" & vbCrLf & _
'"Line 2" & vbCrLf & _
'"Line 3"
.To = "High School Classmates <someone@mailinator.com>"
.BCC = DistributionList
.Importance = olImportanceHigh 'Or olImprotanceNormal Or olImprotanceLow
'.Attachments.Add Wb.FullName
.Display
' .Send
End With

Application.ScreenUpdating = True
Set Wb = Nothing
Set OL = Nothing
Set EmailItem = Nothing
End Sub

Function DistributionList() As String
Dim _
wks As Worksheet, _
rngLRow As Range, _
strDistributionList As String, _
aryEmailAddresses As Variant, _
a As Variant

Set wks = ThisWorkbook.Worksheets("MyContacts") 'Change worksheet as needed
Set rngLRow = RangeFound(wks.Range("O3:O" & Rows.Count)) 'Change range as needed

If rngLRow Is Nothing Then
DistributionList = vbNullString
Exit Function
End If

aryEmailAddresses = Range(wks.Range("O3"), rngLRow).Value 'Change range as needed.

For Each a In aryEmailAddresses
If Not a = vbNullString Then
strDistributionList = strDistributionList & a & "; "
End If
Next

DistributionList = IIf(Len(strDistributionList) > 3, _
Left$(strDistributionList, Len(strDistributionList) - 2), _
vbNullString)
End Function

Function RangeFound(SearchRange As Range, _
Optional FindWhat As String = "*", _
Optional StartingAfter As Range, _
Optional LookAtTextOrFormula As XlFindLookIn = xlValues, _
Optional LookAtWholeOrPart As XlLookAt = xlPart, _
Optional SearchRowCol As XlSearchOrder = xlByRows, _
Optional SearchUpDn As XlSearchDirection = xlPrevious, _
Optional bMatchCase As Boolean = False) As Range

If StartingAfter Is Nothing Then
Set StartingAfter = SearchRange(1)
End If

Set RangeFound = SearchRange.Find(What:=FindWhat, _
After:=StartingAfter, _
LookIn:=LookAtTextOrFormula, _
LookAt:=LookAtWholeOrPart, _
SearchOrder:=SearchRowCol, _
SearchDirection:=SearchUpDn, _
MatchCase:=bMatchCase)

End Function

[GTO]

Try:

aryEmailAddresses = Range(wks.Range("O3"), rngLRow).SpecialCells(xlCellTypeVisible).Value

[Opv]

Thanks. I got a Run Time error (13) "Type mismatch."

[GTO]

I quickly tested and did not get an error; however that is a bit moot, as I "swung and missed." We cannot plunk a non-contguous range of cells into an array (a Doh! on me), as only the first area makes it in for values.

Anyways, before suggesting a better fix, I think we should detect/fix the cause of the error...

I notice that you moved/added columns, as we were checking Col M, and are now checking Col O. You also state as to filtering. Could you re-attach the wb as it is now, including the current code?

Mark

[Opv]

Yes, once I got the code working I inserted an extra column and changed the range references accordingly. The code is working as it is, but it always includes all classmates, regardless of whether a column is filtered. I'd like to include only visible rows in the event I implement Auto Filter on one or more of the columns. I've included a sample of the worksheet with all the actual contact information either removed or replaced with dummy data. The target range is column $O$3 (currently) through O258. If there is a way for the range to be extended as I "Insert" new rows before O258, that would be great as well.

Thanks, Opv

[Opv]

Clarification: I'd like to include only visible rows with an email address (omitting the visible rows that are blank) in the event I implement Auto Filter on one or more of the columns.

Thanks, Opv

[GTO]

I believe if you will read through the comments in my prior code, as well as step thru the code, this will make sense. Only tested briefly, returned just visible/non-blank rows.

Note that we loop thru the visible cells, rather than assign to an array.


Option Explicit

Sub eMailClassmates()
Dim OL As Object 'Outlook.Application
Dim EmailItem As Object 'MailItem
Dim Wb As Workbook
Dim strRecipList As String

strRecipList = DistributionList

If strRecipList = vbNullString Then
MsgBox "No list of recipients was created; not mail msg created...", 0, vbNullString
Exit Sub
End If

Set OL = CreateObject("Outlook.Application")
Set EmailItem = OL.CreateItem(0) 'olMailItem

With EmailItem
.Subject = "Notice to Alumni!"
'.Body = "Insert message here" & vbCrLf & _
'"Line 2" & vbCrLf & _
'"Line 3"
.To = "Classmates <someone@mailinator.com>"
.BCC = strRecipList
.Importance = 2 'olImportanceHigh 'Or olImprotanceNormal Or olImprotanceLow
'// If needed? //
'.Recipients.ResolveAll
.Display
' .Send
End With

Set Wb = Nothing
Set OL = Nothing
Set EmailItem = Nothing
End Sub

Function DistributionList() As String
Dim _
wks As Worksheet, _
rngLRow As Range, _
strDistributionList As String, _
rngEmailAddresses As Range, _
rCell As Range

Set wks = ThisWorkbook.Worksheets("MyContacts") 'Change worksheet as needed
Set rngLRow = RangeFound(wks.Range("O3:O" & Rows.Count)) 'Change range as needed

If rngLRow Is Nothing Then
DistributionList = vbNullString
Exit Function
End If

Set rngEmailAddresses = Range(wks.Range("O3"), rngLRow).SpecialCells(xlCellTypeVisible) 'Change range as needed.

For Each rCell In rngEmailAddresses
If Not rCell.Value = vbNullString Then
strDistributionList = strDistributionList & rCell.Value & "; "
End If
Next

DistributionList = IIf(Len(strDistributionList) > 3, _
Left$(strDistributionList, Len(strDistributionList) - 2), _
vbNullString)
End Function

Function RangeFound(SearchRange As Range, _
Optional FindWhat As String = "*", _
Optional StartingAfter As Range, _
Optional LookAtTextOrFormula As XlFindLookIn = xlValues, _
Optional LookAtWholeOrPart As XlLookAt = xlPart, _
Optional SearchRowCol As XlSearchOrder = xlByRows, _
Optional SearchUpDn As XlSearchDirection = xlPrevious, _
Optional bMatchCase As Boolean = False) As Range

If StartingAfter Is Nothing Then
Set StartingAfter = SearchRange(1)
End If

Set RangeFound = SearchRange.Find(What:=FindWhat, _
After:=StartingAfter, _
LookIn:=LookAtTextOrFormula, _
LookAt:=LookAtWholeOrPart, _
SearchOrder:=SearchRowCol, _
SearchDirection:=SearchUpDn, _
MatchCase:=bMatchCase)
End Function

Hope that helps,

Mark

[Opv]

Works like a charm! Thanks for all your help.
Opv