vba - Excel 2010 将范围和图片粘贴到 Outlook 中

Question

我在解决这个问题时遇到了相当大的困难。我可以毫无问题地将范围粘贴为 HTML，但在某些通信中，我们希望将范围粘贴为图片。我可以创建一个范围并将其另存为图片，但我不知道如何在创建图片后将其粘贴到 Outlook 中。

如果您只是在寻找可复制范围并将其粘贴到 Outlook 中的代码，那么这非常有用。所有电子邮件数据都引用名为“邮件”的选项卡上的单元格，因此您只需将“邮件”选项卡和宏复制并粘贴到任何工作簿中，并通过编辑“邮件”选项卡上的字段而不更改宏来添加电子邮件自动化。如果您使用此代码，请确保引用 Microsoft Outlook x.x 对象库(在 VBA 窗口中:工具 - 引用 - Microsoft Outlook x.x 对象库)。

我需要更进一步，能够将范围转换为图片并将其粘贴到电子邮件中。我可以连接它，但无法将其插入体内，而这正是我所需要的。我查看了几个示例，包括 Ron DeBruins 网站上的示例，但我无法让它们中的任何一个工作。我正在运行 Windows 7 x64 和 Office 2010 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

如有任何建议，我们将不胜感激。谢谢!

Answer 1

感谢 BP_，他引导我访问了一个链接，该链接回答了我的问题。这是针对我的应用程序进行修改后的代码。

这允许我在 Excel 的选项卡中设置所有变量，而不是编辑查询本身。我使用此方法是因为我团队中的一些人不习惯编辑 VBA。

Sub Mail_W_Pic()

Dim TempFilePath As String
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim strbody As String
Dim width As String
Dim height 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
width = (sh.Range("C15").Value)
height = (sh.Range("C16").Value)

    'Create a new Microsoft Outlook session
    Set OutApp = CreateObject("outlook.application")
    'create a new message
    Set OutMail = OutApp.CreateItem(olMailItem)

    With OutMail
        .SentOnBehalfOfName = sh.Range("C4")
        .Display
        .Subject = sh.Range("C8").Value
        .To = sh.Range("C5")
        .CC = sh.Range("C6")
        .BCC = sh.Range("C7")
        'first we create the image as a JPG file
        Call createJpg(sh.Range("C13").Value, sh.Range("C14").Value, "DashboardFile")
        'we attached the embedded image with a Position at 0 (makes the attachment hidden)
        TempFilePath = Environ$("temp") & "\"
        .Attachments.Add TempFilePath & "DashboardFile.jpg", olByValue, 0

        'Then we add an html <img src=''> link to this image
        'Note than you can customize width and height - not mandatory

        .HTMLBody = "<br>" & strbody & "<br><br>" _
            & "<img src='cid:DashboardFile.jpg'" & "width=width height=heigth><br><br>" _
            & "<br>Best Regards,<br>Ed</font></span>" & .HTMLBody

        .Display
        '.Send
    End With

Set sh = Nothing

End Sub

Sub createJpg(Namesheet As String, nameRange As String, nameFile As String)
ThisWorkbook.Activate
Worksheets(Namesheet).Activate
Set Plage = ThisWorkbook.Worksheets(Namesheet).Range(nameRange)
Plage.CopyPicture
With ThisWorkbook.Worksheets(Namesheet).ChartObjects.Add(Plage.Left, Plage.Top, Plage.width, Plage.height)
    .Activate
    .Chart.Paste
    .Chart.Export Environ$("temp") & "\" & nameFile & ".jpg", "JPG"
End With
Worksheets(Namesheet).ChartObjects(Worksheets(Namesheet).ChartObjects.Count).Delete

Set Plage = Nothing

End Sub