randomuser
New Member
- Joined
- Jul 22, 2022
- Messages
- 5
- Office Version
- 365
- Platform
- Windows
I am trying to send multiple ranges as images to one outlook template body. I have found this question a few times but the solutions don't 100% meet what I'm looking for. There are about 1200 rows causing issues when trying to send the sheet in one image through Outlook so I'd like to break them up into images of the ranges. The Ron de Bruin vba with CopyRangetoJPG is working perfectly but I can't figure out to copy/paste more than one in the same email. There is a similar solution with RangetoHTML, however my worksheet includes a pivot chart and it doesn't include it.
I did find an old solution posted that recommended "add a third parameter (e.g.: picNumber) and pass it to the function" but I'm not understanding what is needed. I think I'm missing what I need to do to pass it to the function. The adjustments I make cause it to error at "Kill MakeJPG".
Below is the Ron de Bruin VBA that I'm using with only the Outmail adjusted for a template. I'm going to be sending about 12 images but was trying to get it to work with a few so that I can understand how to do it.
I did find an old solution posted that recommended "add a third parameter (e.g.: picNumber) and pass it to the function" but I'm not understanding what is needed. I think I'm missing what I need to do to pass it to the function. The adjustments I make cause it to error at "Kill MakeJPG".
Below is the Ron de Bruin VBA that I'm using with only the Outmail adjusted for a template. I'm going to be sending about 12 images but was trying to get it to work with a few so that I can understand how to do it.
VBA Code:
Sub Mail_small_Text_And_JPG_Range_Outlook()
'Ron de Bruin, 12-03-2022
'This macro use the function named : CopyRangeToJPG
Dim OutApp As Object
Dim Outmail As Object
Dim strbody As String
Dim MakeJPG As String
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set Outmail = OutApp.CreateItemFromTemplate("H:\Documents\Files\mytemplate.oft")
'Create JPG file of the range
'Only enter the Sheet name and the range address
MakeJPG = CopyRangeToJPG("myworksheet", "B1:M80")
MakeJPG = CopyRangeToJPG("myworksheet", "G81:M180")
MakeJPG = CopyRangeToJPG("myworksheet", "G181:M280")
If MakeJPG = "" Then
MsgBox "Something go wrong, we can't create the mail"
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Exit Sub
End If
On Error Resume Next
With Outmail
.To = ""
.Subject = ""
.Attachments.Add MakeJPG, 1, 0
'Note: Change the width and height as needed
.HTMLBody = "<html><p>" & strbody & "</p><img src=""cid:NamePicture.jpg"" width= 750 height= 700></html>"
.Display 'or use .Send
End With
On Error GoTo 0
Kill MakeJPG
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set Outmail = Nothing
Set OutApp = Nothing
End Sub
Function CopyRangeToJPG(NameWorksheet As String, RangeAddress As String) As String
'Ron de Bruin, 25-10-2019
Dim PictureRange As Range
With ActiveWorkbook
On Error Resume Next
.Worksheets(NameWorksheet).Activate
Set PictureRange = .Worksheets(NameWorksheet).Range(RangeAddress)
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(NameWorksheet).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(NameWorksheet).ChartObjects(.Worksheets(NameWorksheet).ChartObjects.Count).Delete
End With
CopyRangeToJPG = Environ$("temp") & Application.PathSeparator & "NamePicture.jpg"
Set PictureRange = Nothing
End Function
[CODE=vba]
Any help would be much appreciated!
