Copy a string of email addresses from Excel into Outlook TO: box

RichardSaint

New Member
Joined
May 1, 2012
Messages
3
The macro I'm using to copy a worksheet to the body of an Outlook email is working fine. Now I want to go to the worksheet ("volunteer list") and copy the email addresses in column D if the value of column A has an X in it then place that group of addresses in the TO: box of Outlook. Could you please show me where to place that code in the example below. Thank you.

Sub Mail_Selection_Range_Outlook_Body()<?xml:namespace prefix = o ns = "urn:schemas-microsoft-com:eek:ffice:eek:ffice" /><o:p></o:p>
' Don't forget to copy the function RangetoHTML in the module.<o:p></o:p>
' Working in Office 2000-2010<o:p></o:p>
Dim rng As Range<o:p></o:p>
Dim OutApp As Object<o:p></o:p>
Dim OutMail As Object<o:p></o:p>
<o:p></o:p>
Set rng = Nothing<o:p></o:p>
On Error Resume Next<o:p></o:p>
'Only the visible cells in the selection<o:p></o:p>
'Set rng = Selection.SpecialCells(xlCellTypeVisible)<o:p></o:p>
'You can also use a range if you want<o:p></o:p>
Set rng = Sheets("Final Order of Service").Range("A1:B75").SpecialCells(xlCellTypeVisible)<o:p></o:p>
On Error GoTo 0<o:p></o:p>
<o:p></o:p>
If rng Is Nothing Then<o:p></o:p>
MsgBox "The selection is not a range or the sheet is protected" & _<o:p></o:p>
vbNewLine & "please correct and try again.", vbOKOnly<o:p></o:p>
Exit Sub<o:p></o:p>
End If<o:p></o:p>
<o:p></o:p>
With Application<o:p></o:p>
.EnableEvents = False<o:p></o:p>
.ScreenUpdating = False<o:p></o:p>
End With<o:p></o:p>
<o:p></o:p>
Set OutApp = CreateObject("Outlook.Application")<o:p></o:p>
Set OutMail = OutApp.CreateItem(0)<o:p></o:p>
<o:p></o:p>
On Error Resume Next<o:p></o:p>
With OutMail<o:p></o:p>
.To = ""<o:p></o:p>
.CC = ""<o:p></o:p>
.BCC = ""<o:p></o:p>
.Subject = "Order of Service"<o:p></o:p>
.HTMLBody = RangetoHTML(rng)<o:p></o:p>
.Display<o:p></o:p>
End With<o:p></o:p>
On Error GoTo 0<o:p></o:p>
<o:p></o:p>
With Application<o:p></o:p>
.EnableEvents = True<o:p></o:p>
.ScreenUpdating = True<o:p></o:p>
End With<o:p></o:p>
<o:p></o:p>
Set OutMail = Nothing<o:p></o:p>
Set OutApp = Nothing<o:p></o:p>
End Sub<o:p></o:p>
<o:p></o:p>
Function RangetoHTML(rng As Range)<o:p></o:p>
' Changed by Ron de Bruin 28-Oct-2006<o:p></o:p>
' Working in Office 2000-2010<o:p></o:p>
Dim fso As Object<o:p></o:p>
Dim ts As Object<o:p></o:p>
Dim TempFile As String<o:p></o:p>
Dim TempWB As Workbook<o:p></o:p>
<o:p></o:p>
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"<o:p></o:p>
<o:p></o:p>
'Copy the range and create a new workbook to past the data in<o:p></o:p>
rng.Copy<o:p></o:p>
Set TempWB = Workbooks.Add(1)<o:p></o:p>
With TempWB.Sheets(1)<o:p></o:p>
.Cells(1).PasteSpecial Paste:=8<o:p></o:p>
.Cells(1).PasteSpecial xlPasteValues, , False, False<o:p></o:p>
.Cells(1).PasteSpecial xlPasteFormats, , False, False<o:p></o:p>
.Cells(1).Select<o:p></o:p>
Application.CutCopyMode = False<o:p></o:p>
On Error Resume Next<o:p></o:p>
.DrawingObjects.Visible = True<o:p></o:p>
.DrawingObjects.Delete<o:p></o:p>
On Error GoTo 0<o:p></o:p>
End With<o:p></o:p>
<o:p></o:p>
'Publish the sheet to a htm file<o:p></o:p>
With TempWB.PublishObjects.Add( _<o:p></o:p>
SourceType:=xlSourceRange, _<o:p></o:p>
Filename:=TempFile, _<o:p></o:p>
Sheet:=TempWB.Sheets(1).Name, _<o:p></o:p>
Source:=TempWB.Sheets(1).UsedRange.Address, _<o:p></o:p>
HtmlType:=xlHtmlStatic)<o:p></o:p>
.Publish (True)<o:p></o:p>
End With<o:p></o:p>
<o:p></o:p>
'Read all data from the htm file into RangetoHTML<o:p></o:p>
Set fso = CreateObject("Scripting.FileSystemObject")<o:p></o:p>
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)<o:p></o:p>
RangetoHTML = ts.ReadAll<o:p></o:p>
ts.Close<o:p></o:p>
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _<o:p></o:p>
"align=left x:publishsource=")<o:p></o:p>
<o:p></o:p>
'Close TempWB<o:p></o:p>
TempWB.Close savechanges:=False<o:p></o:p>
<o:p></o:p>
'Delete the htm file we used in this function<o:p></o:p>
Kill TempFile<o:p></o:p>
<o:p></o:p>
Set ts = Nothing<o:p></o:p>
Set fso = Nothing<o:p></o:p>
Set TempWB = Nothing<o:p></o:p>
End Function<o:p></o:p>
<!-- / message -->
 

JP2112

Board Regular
Joined
Oct 27, 2008
Messages
237
Welcome to the forum. Please wrap your VBA code in tags like this:

[code]
... your code goes here ...
[/code]


The line of code that specifies the recipients is this:

Code:
.To = ""
You would need a function that grabs the email addresses from the worksheet, concatenates them using ";" or "," (depending on your Outlook settings, ";" is safest if you don't know) and returns them to the calling procedure. Then you would call your function and assign its return value to the line of code above. ex:

Code:
.To = GetEmailAddresses
Assuming your function was named "GetEmailAddresses".
 

Forum statistics

Threads
1,082,505
Messages
5,365,965
Members
400,864
Latest member
RobynP51

Some videos you may like

This Week's Hot Topics

Top