VBA代码复制和粘贴Excel范围到Outlook

问题描述

我需要将范围从Excel文件复制到Outlook，然后以电子邮件形式发送。它需要嵌入到电子邮件本身。我发现这个代码的工作原理很好，有一个例外：它是中心的范围在页面的outlook中间，我需要它对齐到左边。

I need to copy a range from an Excel file into Outlook, then send it as an email. It needs to be embedded into the email itself. I found this code which works great, with one exception: It is centering the range in the middle of the "page" in outlook, and I need it to align to the left.

我假设这是在HTML中完成，但我不知道那种语言。这里是我使用的代码：

I am assuming this is done in HTML but I do not know that language. Here is the code I am using:

Option Explicit

Public Sub prcSendMail()
 Dim objOutlook As Object, objMail As Object

 Set objOutlook = CreateObject(Class:="Outlook.Application")
 Set objMail = objOutlook.CreateItem(0)

 With objMail
     .To = "[email protected]"
     .Subject = "Hallo"
     .HTMLBody = fncRangeToHtml("Summary", "B2:G26")
     .Display 'zum testen
 '    .Send
 End With

 Set objMail = Nothing
 Set objOutlook = Nothing

 End Sub

 Private Function fncRangeToHtml( _
 strWorksheetName As String, _
 strRangeAddress As String) As String

 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

 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

有一些代码左对齐我复制到Outlook ？
我有W7 x64，Excel 2013和Outlook 2013.
谢谢！

Is there some code to left align the range I am copying into Outlook?I have W7 x64, Excel 2013 and Outlook 2013.Thanks!

推荐答案

objTextstream.Close

strTempText = Replace(strTempText, "align=center x:publishsource=", "align=left x:publishsource=")

这篇关于VBA代码复制和粘贴Excel范围到Outlook的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持！