Option Explicit
Sub ExportMyPicture()
Dim MyChart As String, MyPicture As String
Dim PicWidth As Long, PicHeight As Long
Application.ScreenUpdating = False
On Error GoTo Finish
ActiveSheet.Shapes.Range(Array("Picture 1")).Select
MyPicture = Selection.Name
With Selection
PicHeight = .ShapeRange.Height
PicWidth = .ShapeRange.Width
End With
Charts.Add
ActiveChart.Location Where:=xlLocationAsObject, Name:="Sheet1"
Selection.Border.LineStyle = 0
MyChart = Selection.Name & " " & Split(ActiveChart.Name, " ")(2)
With ActiveSheet
With .Shapes(MyChart)
.Width = PicWidth
.Height = PicHeight
End With
.Shapes(MyPicture).Copy
With ActiveChart
.ChartArea.Select
.Paste
End With
.ChartObjects(1).Chart.Export Filename:="D:MyPic.jpg", FilterName:="jpg"
.Shapes(MyChart).Cut
End With
Application.ScreenUpdating = True
Exit Sub
Finish:
MsgBox "You must select a picture"
End Sub
Sub Send_Email()
ExportMyPicture
Dim c As Range
Dim OutLookApp As Object
Dim OutLookMailItem As Object
Dim olbyvalue As Integer
For Each c In Range("A2:A" & Columns("A").Cells(Rows.Count).End(xlUp).Row).Cells
Set OutLookApp = CreateObject("Outlook.application")
Set OutLookMailItem = OutLookApp.CreateItem(0)
With OutLookMailItem
.To = c.Value
.Subject = "Insert Subject here"
.HTMLBody = "Hello " & c.Offset(0, 1).Value & "<br>" & "<br>" & "This is a test mail" & "<br>"
.Attachments.Add "D:MyPic.jpg", _
olbyvalue, 0
.HTMLBody = .HTMLBody & "<br>" & "<img src='cid:MyPic.jpg'"
.Display
' .Send
End With
Next c
On Error Resume Next
Kill "D:MyPic.jpg"
End Sub
