Question

我需要将Excel文件中的范围复制到Outlook中，然后将其作为电子邮件发送。它需要嵌入到电子邮件本身。我发现这个代码效果很好，但有一个例外：它将范围居中放在outlook中“page”的中间位置，我需要将它对齐到左边。

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

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 = "Mike.Marshall@worldpay.us"
     .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。谢谢！

Answer 1

在objTextstream.Close

之后添加此内容

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

Answer 2

这对我有用

 With objMail
    .To = "Bofa@deeznutz.com"
    .cc = ""
    .Subject = "BR1 Summary for Adjustments +/- >$250"
    .HTMLBody = "<table width='100'><tr><td align=left>" + fncRangeToHtml("weekly adjustments report", Sheet1.UsedRange.Address) + "</td></tr></table>" & "<br>" & "<b>" & "<font size=4>" & "Adjustments +/- >$250" & "</font>" & "</b>" & fncRangeToHtml("Sheet1", Sheet2.UsedRange.Address)

VBA喜欢引号和空格。但是在最后一行代码中，您可以引用所有HTML函数或将其分解。但是一旦你完成了大胆的使用，你必须＆＃34; / function＆＃34;在它喜欢这些信息之前结束它。和＆amp;并且+工作相同。

将Excel范围复制并粘贴到Outlook中的VBA代码

2 个答案: