英文:
How can I add a worksheet into email body as image?
问题
I can provide a translation of the text you've provided in English:
As I asked before in another thread Paste specific worksheet range into email body, I'm trying to include a custom worksheet into the email body using Ron's VBA code with some modifications as I posted below:
VBA code (provided in your message)
So, basically the macro is working properly to invoke Microsoft Outlook new message, make an image from the specific range of the worksheet and paste it into the body of the new message.
But when I make a test and send the message to me and a colleague, the image is not shown as expected for receivers.
Below are some screenshots that I took from the scenario.
So guys, could someone help me to solve this issue please?
Please let me know if you need any further assistance.
英文:
As I asked before in another thread Paste specific worksheet range into email body, I'm trying to include a custom worksheet into the e-mail body using Ron's VBA code with some modifications as I posted below:
Sub Enviar_Abertura()
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.CreateItem(0)
MakeJPG = CopyRangeToJPG("E-MAIL ABERTURA", "B6:F27")
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
.SentOnBehalfOfName = "teste@teste.com.br"
.To = ""
.CC = ""
.BCC = ""
.Subject = Planilha5.Range("B4")
.Attachments.Add MakeJPG, 1, 0
.HTMLBody = "<html><p>" & strbody & "</p><img src=""cid:NamePicture.jpg""></html>"
.Display
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
So, basically the macro is working properly to invoke Microsoft Outlook new message, make an image from the specific range of the worksheet and paste it into the body of the new message.
But when I make a test and send the message to me and a colleague, the image is not shown as expected for receivers.
Below are some screenshot that I took from the scenario.
So guys, could someone help me to solve this issue please?
答案1
得分: 2
保持简单。
复制一张范围图片到Outlook。
Sub CopyRngToOutlook()
Dim doc As Object, rng As Range
Set rng = Sheets("Sheet1").Range("B6:F27")
With CreateObject("Outlook.Application").CreateItem(0)
.Display
Set doc = .GetInspector.WordEditor
rng.CopyPicture
doc.Range(0, 0).Paste
.To = "someone@somewhere.com"
.Subject = "Send Email Body"
.send
End With
End Sub
如果您想要发送附加文本：
Sub CopyRngToOutlook2()
Dim doc As Object, rng As Range
Set rng = Sheets("Sheet1").Range("B6:F27")
With CreateObject("Outlook.Application").CreateItem(0)
.Display
Set doc = .GetInspector.WordEditor
x = doc.Range.End - 1
doc.Range(x) = "Hello There" & vbNewLine & vbNewLine & vbNewLine
x = doc.Range.End - 1
rng.CopyPicture
doc.Range(x).Paste
.To = "someone@somewhere.com"
.Subject = "Send Email Body"
'.send
End With
End Sub
英文:
Keep it simple.
Copy a picture of the range to outlook
Sub CopyRngToOutlook()
Dim doc As Object, rng As Range
Set rng = Sheets("Sheet1").Range("B6:F27")
With CreateObject("Outlook.Application").CreateItem(0)
.Display
Set doc = .GetInspector.WordEditor
rng.CopyPicture
doc.Range(0, 0).Paste
.To = "someone@somewhere.com"
.Subject = "Send Email Body"
.send
End With
End Sub
If you wanted to send additional text:
Sub CopyRngToOutlook2()
Dim doc As Object, rng As Range
Set rng = Sheets("Sheet1").Range("B6:F27")
With CreateObject("Outlook.Application").CreateItem(0)
.Display
Set doc = .GetInspector.WordEditor
x = doc.Range.End - 1
doc.Range(x) = "Hello There" & vbNewLine & vbNewLine & vbNewLine
x = doc.Range.End - 1
rng.CopyPicture
doc.Range(x).Paste
.To = "someone@somewhere.com"
.Subject = "Send Email Body"
'.send
End With
End Sub
通过集体智慧和协作来改善编程学习和解决问题的方式。致力于成为全球开发者共同参与的知识库，让每个人都能够通过互相帮助和分享经验来进步。
评论