Private Sub CommandButton3_Click() 'Ron de Bruin, 25-10-2019 'https://www.rondebruin.nl/win/s1/outlook/bmail0.htm 'This macro uses the function named : CopyRangeToJPG 'Routine modified by Steve Schroeder on 09/03/2021 Dim OutApp As Object Dim OutMail As Object Dim MakeJPG As String Dim strFilename1, strFilename2, I As String strFilename1 = "https://sp006.jpmchase.net/sites/spykzlqp/Production Tools/Apps/Misc/SME Templates/404 APPLY 1.html" strFilename2 = "https://sp006.jpmchase.net/sites/spykzlqp/Production Tools/Apps/Misc/SME Templates/404 APPLY 2.html" Dim strFileContent1, strFileContent2 As String Dim oHTTP As Object Set oHTTP = CreateObject("MSXML2.XMLHTTP") oHTTP.Open "GET", strFilename1, False oHTTP.Send strFileContent1 = oHTTP.ResponseText oHTTP.Open "GET", strFilename2, False oHTTP.Send strFileContent2 = oHTTP.ResponseText Set oHTTP = Nothing 'Since we're using the .HTMLBody format in structuring the email (below) due to replacing values 'in the text body of the email (above), we need to manually capture and add the signature line. I = Environ("APPDATA") & "\Microsoft\Signatures\" 'Path to the signature files. If Dir(I, vbDirectory) <> vbNullString Then I = I & Dir$(I & "*.htm") Else I = "" 'Grab the .htm signature file. On Error Resume Next 'If there's no .htm file, then the following line would produce an error message. I = CreateObject("Scripting.FileSystemObject").GetFile(I).OpenAsTextStream(1, -2).ReadAll On Error GoTo 0 If Left(I, 8) = "C:\Users" Then I = "" 'If there's no .htm file, reset variable I to a null string so nothing displays. With Application .EnableEvents = False .ScreenUpdating = False End With Set OutApp = CreateObject("Outlook.Application") Set OutMail = OutApp.CreateItem(0) 'Create JPG file of the range MakeJPG = CopyRangeToJPG("Sheet2", "A1:F25") On Error Resume Next With OutMail .Subject = "Customer access for new application - " .Attachments.Add MakeJPG, 1, 0 .HTMLBody = "

" & strFileContent1 & "

" & _ "

" & strFileContent2 & I & "" 'This is the "secret" - make the 2 messages surrounding the image their own separate "" components! .Display End With On Error GoTo 0 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 'https://www.rondebruin.nl/win/s1/outlook/bmail0.htm Dim PictureRange As Range With ActiveWorkbook On Error Resume Next .Worksheets(NameWorksheet).Activate Set PictureRange = .Worksheets(NameWorksheet).Range(RangeAddress) 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 On Error GoTo 0 End With Worksheets("Sheet1").Activate CopyRangeToJPG = Environ$("temp") & Application.PathSeparator & "NamePicture.jpg" Set PictureRange = Nothing End Function