MikeLittle
New Member
- Joined
- Feb 5, 2016
- Messages
- 17
I have built a project to copy a range of cells and paste them as a picture into an Outlook email. The issue is that the Excel doc has 52 tables on one sheet representing each week, and I want to have a button on each table to copy that specific range and create the email.
Sub Workload_Email_WK1()
Dim OutlookApp As Object
Dim OutlookMail As Object
Dim signature As String
Dim MakeJPG As String
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookMail = OutlookApp.CreateItem(0)
Dim strbody As String
strbody = "Happy " & Range("'Email Info'!D2") & " Everyone," & "<br>" & _
" " & " " & " " & " " & "Projected workload attached.<br>" & " " & "<br>" & _
"<br>" & "Have a great day!<br>"
MakeJPG = CopyRangeToJPG("Workload_Projection", "A1:O13")
If MakeJPG = "" Then
MsgBox "Something went wrong, we can't create the email."
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End If
On Error Resume Next
With OutlookMail
.Display
.To = Range("'Email Info'!B3")
.CC = Range("'Email Info'!B4") & ("; ") & Range("'Email Info'!B5")
.Subject = Range("'Workload_Projection'!A1") & (" Inbound Workload Projection")
.Attachments.Add MakeJPG, 1, 1
.HTMLbody = "<html><p>" & strbody & "<br>" & "</p><img src=""cid:NamePicture.jpg"" width=890 height=175></html>" & .HTMLbody
.Attachments.Add ActiveWorkbook.FullName
End With
Set OutlookMail = Nothing
Set OutlookApp = Nothing
Application.SendKeys ("%s")
Sheets("Workload_Projection").Select
Range("A1:A2").Select
End Sub
Function CopyRangeToJPG(NameWorksheet As String, RangeAddress As String) As String
Dim PictureRange As Range
With ActiveWorkbook
On Error Resume Next
.Worksheets("Workload_Projection").Activate
Set PictureRange = .Worksheets("Workload_Projection").Range("A1:O13")
If PictureRange Is Nothing Then
MsgBox "Sorry, this is not a correct range."
On Error GoTo 0
Exit Function
End If
PictureRange.CopyPicture
With .Worksheets("Workload_Projection").ChartObjects.Add(PictureRange.Left, PictureRange.Top, PictureRange.Width, PictureRange.Height)
.Activate
.Chart.Paste
.Chart.Export Environ$("temp") & Application.PathSeparator & "NamePicture.jpg", "JPG"
End With
.Worksheets("Workload_Projection").ChartObjects(.Worksheets("Workload_Projection").ChartObjects.Count).Delete
End With
CopyRangeToJPG = Environ$("temp") & Application.PathSeparator & "NamePicture.jpg"
Set PictureRange = Nothing
End Function
Sub Workload_Email_WK1()
Dim OutlookApp As Object
Dim OutlookMail As Object
Dim signature As String
Dim MakeJPG As String
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookMail = OutlookApp.CreateItem(0)
Dim strbody As String
strbody = "Happy " & Range("'Email Info'!D2") & " Everyone," & "<br>" & _
" " & " " & " " & " " & "Projected workload attached.<br>" & " " & "<br>" & _
"<br>" & "Have a great day!<br>"
MakeJPG = CopyRangeToJPG("Workload_Projection", "A1:O13")
If MakeJPG = "" Then
MsgBox "Something went wrong, we can't create the email."
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End If
On Error Resume Next
With OutlookMail
.Display
.To = Range("'Email Info'!B3")
.CC = Range("'Email Info'!B4") & ("; ") & Range("'Email Info'!B5")
.Subject = Range("'Workload_Projection'!A1") & (" Inbound Workload Projection")
.Attachments.Add MakeJPG, 1, 1
.HTMLbody = "<html><p>" & strbody & "<br>" & "</p><img src=""cid:NamePicture.jpg"" width=890 height=175></html>" & .HTMLbody
.Attachments.Add ActiveWorkbook.FullName
End With
Set OutlookMail = Nothing
Set OutlookApp = Nothing
Application.SendKeys ("%s")
Sheets("Workload_Projection").Select
Range("A1:A2").Select
End Sub
Function CopyRangeToJPG(NameWorksheet As String, RangeAddress As String) As String
Dim PictureRange As Range
With ActiveWorkbook
On Error Resume Next
.Worksheets("Workload_Projection").Activate
Set PictureRange = .Worksheets("Workload_Projection").Range("A1:O13")
If PictureRange Is Nothing Then
MsgBox "Sorry, this is not a correct range."
On Error GoTo 0
Exit Function
End If
PictureRange.CopyPicture
With .Worksheets("Workload_Projection").ChartObjects.Add(PictureRange.Left, PictureRange.Top, PictureRange.Width, PictureRange.Height)
.Activate
.Chart.Paste
.Chart.Export Environ$("temp") & Application.PathSeparator & "NamePicture.jpg", "JPG"
End With
.Worksheets("Workload_Projection").ChartObjects(.Worksheets("Workload_Projection").ChartObjects.Count).Delete
End With
CopyRangeToJPG = Environ$("temp") & Application.PathSeparator & "NamePicture.jpg"
Set PictureRange = Nothing
End Function
