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

Question

我需要将一个范围从 Excel 文件复制到 Outlook，然后将其作为电子邮件发送。它需要嵌入到电子邮件本身。我发现这段代码效果很好，但有一个异常(exception):它在 Outlook 中将范围居中放置在“页面”的中间，我需要它向左对齐。

我假设这是用 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=")