Question

我正在尝试使用Excel工作表和VBA自动发送电子邮件。我能够将所需的范围复制到电子邮件中，但我想使用htm文件进行HTML格式化。

如何阅读htm文件并将其添加到我的电子邮件的.HTMLBody中？

这是我的代码，它发送一封包含正确工作表的电子邮件，但不包含随测试（路径）功能添加的HTML格式：

Sub Send_To_Outlook()
    Dim AWorksheet As Worksheet
    Dim Sendrng As range
    Dim rng As range
    Dim text As String
    Dim textline As String
    Dim sPath As String

    sPath = "H:\My Documents\email.htm"

    On Error GoTo StopMacro

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    'Fill in the Worksheet/range you want to mail
    Set Sendrng = Worksheets("Email").range("C6:L244")

    'Remember the activesheet
    Set AWorksheet = ActiveSheet

    With Sendrng

        ' Select the worksheet with the range you want to send
        .Parent.Select

        'Remember the ActiveCell on that worksheet
        Set rng = ActiveCell

        'Select the range you want to mail
        .Select

        ' Create the mail and send it
        ActiveWorkbook.EnvelopeVisible = True
        With .Parent.MailEnvelope


            With .Item
                .To = "myemail@email.com"
                .CC = ""
                .BCC = ""
                .Subject = "My subject"
                .HTMLBody = test(sPath)
                .Send
            End With

        End With

        'select the original ActiveCell
        rng.Select
    End With

    'Activate the sheet that was active before you run the macro
    AWorksheet.Select

StopMacro:
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
    ActiveWorkbook.EnvelopeVisible = False

End Sub


Function test(sPath As String)

    Dim oFSO As Object
    Dim oFS As Object, sText As String

    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set oFS = oFSO.OpenTextFile(sPath)

    test= oFS.ReadAll()

End Function

关于为什么不起作用的任何建议或建议都会很棒！

PS我还需要显示消息而不是发送消息，但这不是问题的重要部分。

Answer 1

您的函数不会返回任何值。试试这个：

Function test(sPath As String)
    test = CreateObject("Scripting.FileSystemObject").OpenTextFile(sPath).ReadAll()
End Function

Answer 2

我解决了我的问题。使用html并在上面的代码中发送工作表范围时出现问题。我决定将工作表转换为html，将图表导出为图像并将其插入到电子邮件的其余html中。

    Sub Mail_Sheet_Outlook_Body()

    Dim rng1 As range
    Dim rng2 As range
    Dim OutApp As Object
    Dim OutMail As Object
    Dim newimage As Action
    Dim aPath As String
    Dim bPath As String
    Dim sPath As String

    'Name the variables for your the needed paths
    sPath = "C:\Chart1.png"
    aPath = "C:\email1.htm"
    bPath = "C:\email2.htm"

    'Export your chart as an image
    Call ExportChart("Chart1")

    'Select the range your desired tables are in
    Set rng1 = Worksheets("Email").range("C6:L32")
    Set rng2 = Worksheets("Email").range("C45:L244")

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    'Create the email
    On Error Resume Next
    With OutMail
        .To = "myemail@email.com"
        .CC = ""
        .BCC = ""
        .Subject = "This is the Subject line"
        ' Place your tables in the correct location of your html for the email
        .HTMLBody = test(aPath) & RangetoHTML(rng1) & "<img src=" & "'" & sPath & "'" & "width=888; height=198>" & RangetoHTML(rng2) & test(bPath)
        .Display
    End With
    On Error GoTo 0

    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub
Function ExportChart(sChartName As String)

      '   Export a selected chart as a picture
        Const sSlash$ = "/"
        Const sPicType$ = ".png"
        Dim sPath$
        Dim sBook$
        Dim objChart As ChartObject


        On Error Resume Next
         '   Test if there are even any embedded charts on the activesheet
         '   If not, let the user know
        Set objChart = ActiveSheet.ChartObjects(1)
        If objChart Is Nothing Then
            MsgBox "No charts have been detected on this sheet", 0
            Exit Function
        End If

         '   Test if there is a single chart selected
        If ActiveChart Is Nothing Then
            MsgBox "You must select a single chart for exporting ", 0
            Exit Function
        End If

Start:

         '   chart is exported as a picture, Chart1.png in the same
         '   folder location as the workbook
        sBook = ActiveWorkbook.path
        sPath = sBook & sSlash & sChartName & sPicType
        ActiveChart.Export Filename:=sPath, FilterName:="PNG"


        With Application
            .EnableEvents = False
            .ScreenUpdating = False

        End With

End Function

Function RangetoHTML(rng As range)

    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    'Copy the range and create a new workbook to past the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With

    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.ReadAll
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")

    'Close TempWB
    TempWB.Close savechanges:=False

    'Delete the htm file we used in this function
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing

End Function

Function test(sPath As String)
    'Returns a string after reading the contents of a given file
    test = CreateObject("Scripting.FileSystemObject").OpenTextFile(sPath).ReadAll()

End Function

感谢您的帮助！ :)

Answer 3

当您说您的代码不起作用时，这是否意味着您收到错误或代码执行但电子邮件正文为空？

我首先检查你的“test”函数是否返回一个空字符串：

Function test(sPath As String)

Dim oFSO As Object
Dim oFS As Object, sText As String

Set oFSO = CreateObject("Scripting.FileSystemObject")
 Set oFS = oFSO.OpenTextFile(sPath)

' I don't think you need to loop until EOF with .ReadAll
sText = oFS.ReadAll

' This will print sText to the Immediate Window; if it is 0, then sText is null         
Debug.Print ("sText string has a length of: " & Len(sText))


End Function

我的猜测是sText为空。如果它正在成功读取.htm，我接下来会检查以确保.htm是有效的.html语法。

将htm文件读取到.HTMLBody VBA

3 个答案: