Excel 2010将范围和图片粘贴到Outlook中 [英] Excel 2010 Paste Range and Picture into Outlook

问题描述

我很难想出这一个。我可以粘贴一个范围作为HTML没有问题，但在一些通信，我们想要超过范围作为图片，而不是。我可以创建一个范围并将其保存为图片，但是我无法弄清楚如何将图片创建到Outlook后。

如果您只是寻找代码将复制一个范围并将其粘贴到Outlook中，这很好用。所有电子邮件数据都是引用名为Mail的选项卡上的单元格，因此您可以简单地将邮件选项卡和宏复制并粘贴到任何工作簿中，并通过编辑邮件选项卡上的字段而不更改宏来添加电子邮件自动化。如果您使用此代码，请确保引用Microsoft Outlook xx对象库（在VBA窗口中：工具 - 参考 - Microsoft Outlook xx对象库）。

我需要采取这一步进一步，并能够将范围变成一个图片，并将其粘贴到电子邮件。我可以附上它，但是我不能把它插入身体，这就是我需要的。我已经看了几个例子，其中包括Ron DeBruins网站上的例子，但是我没有能够让任何一个工作。我正在运行Windows 7 x64与Office 2010 x64。

以下是我正在运行的代码来粘贴范围。

  Option Explicit 
 
 Sub Mail_AS_Range（）
 
' 2010-2013 
 Dim OutApp As Outlook.Application 
 Dim OutMail As Outlook.MailItem 
 Dim strbody As String 
 
关于错误简历Next 
 
 Dim sh As Worksheet 
 Set sh = Sheets（Mail）
 strbody = sh.Range（C9）。value 
表格（sh.Range（C11）。 ）。选择
 ActiveWorkbook.Save 
 
 
设置OutApp = CreateObject（Outlook.Application）
设置OutMail = OutApp.CreateItem（0）
使用OutMail 
 .SentOnBehalfOfName = sh.Range（C4）'这允许我们从备用电子邮件地址
发送。显示'如果我们不先显示电子邮件，则替代发送地址将无法正常工作。 
'我不知道为什么，但这一步是一个必须
 .To = sh.Range（C5）
 .CC = sh.Range（C6）
。 BCC = sh.Range（C7）
 .Subject = sh.Range（C8）。值
 .HTMLBody =< br> &安培;晶体& fncRangeToHtml（sh.Range（C13）。值，sh.Range（C14）。值）& .HTMLBody 
'这是将电子邮件的正文拉在一起的地方。 
'< br>是一个HTML标签将文本转换为HTML 
'strbody是您从邮件标签上的单元格C9的文本
'fncRangetoHtml将您指定的范围转换为HTML 
'.HTMLBody插入您的电子邮件签名
 .Attachments.Add sh.Range（C10）。价值
'。发送
 
结束
 
错误GoTo 0 
 
 Set OutMail = Nothing 
设置OutApp = Nothing 
 
 End Sub 
 
 
私有函数fncRangeToHtml（_ 
 strWorksheetName As String，_ 
 strRangeAddress As String）As String 
 
'这是创建一个私有函数，使邮件宏中指定的范围成为HTML 
 
 Dim objFilesytem作为Object，objTextstream As Object，objShape As Shape 
 Dim strFilename As String，strTempText As String 
 Dim blnRangeContainsShapes As Boolean 
 
 strFilename = Environ $（temp）& \& _ 
格式（现在，dd-mm-yy_h-mm-ss）& .htm
 
 ThisWorkbook.PublishObjects.Add（_ 
 SourceType：= xlSourceRange，_ 
文件名：= strFilename，_ 
工作表：= strWorksheetName，_ 
来源：= strRangeAddress，_ 
 HtmlType：= xlHtmlStatic）.Publish True 
 
设置objFilesytem = CreateObject（Scripting.FileSystemObject）
设置objTextstream = objFilesytem.GetFile （strFilename）.OpenAsTextStream（1，-2）
 strTempText = objTextstream.ReadAll 
 objTextstream.Close 
 strTempText =替换（strTempText，align = center x：publishsource =，align = left x：publishsource =）
 
对于Worksheets中的每个objShape（strWorksheetName）.Shapes 
如果不相交（objShape.TopLeftCell，Worksheets（_ 
 strWorksheetName）.Range（strRangeAddress ））没有了
 
 blnRangeContainsShapes = True 
退出对于
 
结束如果
下一个
 
如果blnRangeContainsShapes然后strTempText = fncConvertPictureToMail（strTempText，Worksheets（strW orksheetName））
 
 fncRangeToHtml = strTempText 
 
设置objTextstream =没有
设置objFilesytem =没有
 
杀死strFilename 
 
结束函数
 
公共函数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 =替换（strTempText，strTemp，Environ $（temp）&\& strTemp）
 
 fncConvertPictureToMail = strTempText 
 
结束功能
  

任何建议将不胜感激。谢谢！

解决方案

谢谢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 
 
错误简历Next 
 
 Dim sh As Worksheet 
 Set sh = Sheets（Mail）
 strbody = sh.Range（C9 ）.Value 
表格（sh.Range（C11）。值）。选择
 width =（sh.Range（C15）。value）
 height =（sh.Range （C16）。$）
 
'创建一个新的Microsoft Outlook会话
 Set OutApp = CreateObject（outlook.application）
'创建一个新消息
 Set OutMail = OutApp.CreateItem（olMailItem）
 
 With OutMail 
 .SentOnBehalfOfName = sh.Range（C4）
 .Display 
 .Subject = sh。范围（C8）。值
 .To = sh.Range（C5）
 .CC = sh.Range（C6）
 .BCC = sh.R ange（C7）
'首先我们将图像创建为JPG文件
调用createJpg（sh.Range（C13）。Value，sh.Range（C14）。Value， DashboardFile）
'我们附加了位置为0的嵌入图像（隐藏附件）
 TempFilePath = Environ $（temp）& \
 .Attachments.Add TempFilePath& DashboardFile.jpg，olByValue，0 
 
'然后我们添加一个html< img src =''>链接到此图像
'注意比您可以自定义宽度和高度 - 不是强制性
 
 .HTMLBody =< br> &安培;晶体& <峰; br><峰; br> 中_ 
& < img src ='cid：DashboardFile.jpg'& width = width height = heigth>< br>< br> _ 
& < br>最好的问候< br> Ed< / font>< / span> &安培; .BB 
 
。显示
'。发送
结束
 
设置sh =没有
 
 End Sub 
 
 Sub createJpg（Namesheet As String，nameRange As String，nameFile As String）
 ThisWorkbook.Activate 
工作表（Namesheet）.Activate 
 Set Plage = ThisWorkbook.Worksheets（Namesheet） .Range（nameRange）
 Plage.CopyPicture 
使用ThisWorkbook.Worksheets（Namesheet）.ChartObjects.Add（Plage.Left，Plage.Top，Plage.width，Plage.height）
。激活
 .Chart.Paste 
 .Chart.Export Environ $（temp）& \& nameFile& .jpg，JPG
 End with 
工作表（Namesheet）.ChartObjects（Worksheets（Namesheet）.ChartObjects.Count）.Delete 
 
 Set Plage = Nothing 
 
 End Sub 
  

I am having considerable difficulty figuring this one out. I can paste a range as HTML without issues, but in some communications we want to past the range as a picture instead. I can create a range and save it as a picture, but I cannot figure out how to past the picture into Outlook after it is created.

If you are just looking for code that will copy a range and paste it into Outlook, this works great. All of the email data is referencing cells on a tab called Mail, so you can simply copy and paste the Mail tab and the macro into any workbook and add email automation by editing the fields on the mail tab and not changing the macro. If you use this code, make sure to reference Microsoft Outlook x.x Object Library (In VBA Window: Tools - References - Microsoft Outlook x.x Object Library).

I need to take this one step further and be able to turn the range into a picture and paste it into the email. I can attach it, but I cannot insert it into the body, which is what I need. I have looked at several examples, including those on Ron DeBruins website, but I have not been able to get any of them to work. I am running Windows 7 x64 With Office 2010 x64.

Here is the code I am running to paste a range.

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

Any suggestions would be appreciated. Thanks!

解决方案

Thank you to BP_ who directed me to a link, which answered my question. Here is my code after modifying for my application.

This allows me to set all the variables within a tab in Excel and not edit the query itself. I use this method because some folks on my team are not comfortable editing 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

这篇关于Excel 2010将范围和图片粘贴到Outlook中的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！