【发布时间】：2014-11-20 15:06:41
【问题描述】：
我很难弄清楚这一点。我可以毫无问题地将范围粘贴为 HTML，但在某些通信中，我们希望将范围作为图片过去。我可以创建一个范围并将其另存为图片，但我不知道如何在创建后将图片粘贴到 Outlook 中。
如果您只是在寻找可以复制范围并将其粘贴到 Outlook 中的代码，则此方法非常有用。所有电子邮件数据都引用名为“邮件”的选项卡上的单元格，因此您只需将“邮件”选项卡和宏复制并粘贴到任何工作簿中，并通过编辑“邮件”选项卡上的字段而不更改宏来添加电子邮件自动化。如果您使用此代码，请确保引用 Microsoft Outlook x.x 对象库（在 VBA 窗口中：工具 - 参考 - Microsoft Outlook x.x 对象库）。
我需要更进一步，能够将范围转换为图片并将其粘贴到电子邮件中。我可以连接它，但我不能将它插入身体，这是我需要的。我查看了几个示例，包括 Ron DeBruins 网站上的示例，但我无法让其中任何一个工作。我正在运行带有 Office 2010 x64 的 Windows 7 x64。
这是我正在运行以粘贴范围的代码。
Option Explicit
Sub Mail_AS_Range()
' Working in Office 2010-2013
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim strbody As String
On Error Resume Next
Dim sh As Worksheet
Set sh = Sheets("Mail")
strbody = sh.Range("C9").Value
Sheets(sh.Range("C11").Value).Select
ActiveWorkbook.Save
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.SentOnBehalfOfName = sh.Range("C4") 'This allows us to send from an alternate email address
.Display 'Alternate send address will not work if we do not display the email first.
'I dont know why but this step is a MUST
.To = sh.Range("C5")
.CC = sh.Range("C6")
.BCC = sh.Range("C7")
.Subject = sh.Range("C8").Value
.HTMLBody = "<br>" & strbody & fncRangeToHtml(sh.Range("C13").Value, sh.Range("C14").Value) & .HTMLBody
' This is where the body of the email is pulled together.
' <br> is an HTML tag to turn the text into HTML
' strbody is your text from cell C9 on the mail tab
' fncRangetoHtml is converting the range you specified into HTML
' .HTMLBody inserts your email signature
.Attachments.Add sh.Range("C10").Value
'.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Private Function fncRangeToHtml( _
strWorksheetName As String, _
strRangeAddress As String) As String
' This is creating a private function to make the range specified in the Mail macro into HTML
Dim objFilesytem As Object, objTextstream As Object, objShape As Shape
Dim strFilename As String, strTempText As String
Dim blnRangeContainsShapes As Boolean
strFilename = Environ$("temp") & "\" & _
Format(Now, "dd-mm-yy_h-mm-ss") & ".htm"
ThisWorkbook.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=strFilename, _
Sheet:=strWorksheetName, _
Source:=strRangeAddress, _
HtmlType:=xlHtmlStatic).Publish True
Set objFilesytem = CreateObject("Scripting.FileSystemObject")
Set objTextstream = objFilesytem.GetFile(strFilename).OpenAsTextStream(1, -2)
strTempText = objTextstream.ReadAll
objTextstream.Close
strTempText = Replace(strTempText, "align=center x:publishsource=", "align=left x:publishsource=")
For Each objShape In Worksheets(strWorksheetName).Shapes
If Not Intersect(objShape.TopLeftCell, Worksheets( _
strWorksheetName).Range(strRangeAddress)) Is Nothing Then
blnRangeContainsShapes = True
Exit For
End If
Next
If blnRangeContainsShapes Then strTempText = fncConvertPictureToMail(strTempText, Worksheets(strWorksheetName))
fncRangeToHtml = strTempText
Set objTextstream = Nothing
Set objFilesytem = Nothing
Kill strFilename
End Function
Public Function fncConvertPictureToMail(strTempText As String, objWorksheet As Worksheet) As String
Const HTM_START = "<link rel=File-List href="
Const HTM_END = "/filelist.xml"
Dim strTemp As String
Dim lngPathLeft As Long
lngPathLeft = InStr(1, strTempText, HTM_START)
strTemp = Mid$(strTempText, lngPathLeft, InStr(lngPathLeft, strTempText, ">") - lngPathLeft)
strTemp = Replace(strTemp, HTM_START & Chr$(34), "")
strTemp = Replace(strTemp, HTM_END & Chr$(34), "")
strTemp = strTemp & "/"
strTempText = Replace(strTempText, strTemp, Environ$("temp") & "\" & strTemp)
fncConvertPictureToMail = strTempText
End Function
任何建议将不胜感激。谢谢！
【问题讨论】：
-
你检查过这个吗？ vba-useful.blogspot.com/2014/01/…
-
它需要一些调整，但这会起作用，甚至比我预期的还要好！我将发布适用于我的项目的修改后的代码。谢谢！