Code for sending Outlook email with attachments using a list

[craig]

I have received the attached code which will send an email with an
attachment, using a list that contains recepient name, email address,
and attachment path. My job is using email addresses that are
contained in my global address book, and would prefer to use the name
instead of the email address. What code needs to be changed to make
this work.

Sub Send_Files()
'Working in 2000-2007
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim sh As Worksheet
Dim cell As Range, FileCell As Range, rng As Range
Dim strSubject, strBody, strNote, StrMessage

With Application
.EnableEvents = False
.ScreenUpdating = False
End With

Set sh = Sheets("Sheet1")

Set OutApp = CreateObject("Outlook.Application")
'OutApp.Session.Logon

strSubject = InputBox("Please enter the subject of today's mail:",
"Message Subject Entry", "")
strNote = ""
StrMessage = InputBox("Please enter message here:", "Message
Entry", "")
strBody = strNote & Chr(10) & _

For Each cell In
sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)

'Enter the file names in the C:Z column in each row
Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")

If cell.Value Like "?*@?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(olMailItem)

With OutMail
.SentOnBehalfOfName = ""
.To = "cell.Value"
.Subject = strSubject
.Body = strBody
For Each FileCell In
rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value
End If
End If
Next FileCell
.Send 'Or use Display
End With

Set OutMail = Nothing
End If
Next cell

Set OutApp = Nothing

With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub

 

[Ron de Bruin]

Hi Graig

Try this instead of .To

..Recipients.Add "TheName"