Need Help with VBA for Creating Emails

[Michael0107]

I am trying to create a macro that will loop through a named range that contains email addresses to create an email with hard coded subject and opening line of the body. I then need to insert a range of cells based on a named range into the body and then send the email. I have been able to get the email created up to the point of inserting the range of cells. Ultimately, I would like to copy the range and insert it as a picture. Anyone that can assist with this I would be very grateful. - Below is the code that I have to this point - Mike

'Use this module to email embedded image Team View
'Charts individually to each team member
'Will only distribute if email address is in control tab
'Inputs: References to data from Team View
'Outputs: Email to Team Members
'
'
'This section will define the required sections for use in generating Individual Productivity Emails
Dim OutApp As Object, sendrng As Object
Dim OutMail As Object, wddoc As Object, t As Object

'Defines Range Names for Email Addresses and Image
Dim cell As Range, T271 As Range
Dim T331 As Range, T361 As Range
Dim T540 As Range, T411 As Range
Dim EC_Email As Range
Dim P271 As Range, P331 As Range
Dim P361 As Range, P540 As Range
Dim P411 As Range


'Defines Range for Email Addresses
Set T271 = Worksheets("Control Sheet").Range("_271email")
Set T331 = Worksheets("Control Sheet").Range("_331email")
Set T361 = Worksheets("Control Sheet").Range("_361email")
Set T540 = Worksheets("Control Sheet").Range("_540email")
Set T411 = Worksheets("Control Sheet").Range("_411email")

'Defines Range for Image Capture
Set P271 = Worksheets("Control Sheet").Range("_271pic")
Set P331 = Worksheets("Control Sheet").Range("_331pic")
Set P361 = Worksheets("Control Sheet").Range("_361pic")
Set P540 = Worksheets("Control Sheet").Range("_540pic")
Set P411 = Worksheets("Control Sheet").Range("_411pic")


Application.ScreenUpdating = True

Set OutApp = CreateObject("Outlook.Application")


On Error GoTo cleanup

Worksheets("Team View").Activate
ActiveSheet.Shapes("Drop Down 1").ControlFormat.Value = 9

'Calculate

For Each cell In T271
Set t = wddoc.Bookmarks("ResponseTime_ResponseTime").Range
Range("P271").Select
Selection.copy
If cell.Value Like "?*@?*.?*" Then
Set OutMail = OutApp.CreateItem(0)
Set sendrng = Worksheets("Teamview").Range("Chart") & x
On Error Resume Next
With OutMail
.To = cell.Value
.CC = "jxxx_bxxxxxx@xxx.com" & ";" & "jxxxxxxxx@xxx.com"
.Subject = "Productivity Report"
.Body = "Here is your most recent Productivity Report. " _
& "Any questions please contact your supervisor." & vbNewLine _
& vbNewLine
t.PasteSpecial DataType:=wdPasteEnhancedMetafile, Placement:=wdInLine

'You can add files also like this
'Set wordDoc = OutMail.GetInspector.WordEditor
'wordDoc.Range.PasteAndFormat P271
.Display
End With
'.Send
On Error GoTo 0
Set OutMail = Nothing
Next cell