VBA Drop Down 创建 Outlook 电子邮件 HTMLBody

Question

我有一个 VBA cody，它可以从 excel 表中创建 Outlook 电子邮件正文。
基于下拉值的 Excel 表中的值。 (月)。
如果下拉显示一月，该表也显示一月。
我的问题是 Outlook 电子邮件 HTML 正文总是显示相同的月份，它们不会根据我的下拉值而改变。

Sub CustomMailMessage()

Dim OApp As Object
Dim OMail As Object
Dim rng As Range
Dim sig As String
Dim inputRange As Range

Set dvcell = Worksheets("Sheet2").Range("S1")
Set inputRange = Evaluate(dvcell.Validation.Formula1)

For Each c In inputRange
    For i = 1 To 2
        dvcell = c.Value
        Set OApp = CreateObject("Outlook.Application")
        Set OMail = OApp.CreateItem(0)

        With OMail
            .To = ThisWorkbook.Worksheets("Sheet1").Cells(i, 1).Value
            .Subject = "This is the subject"
            .HTMLBody = RangetoHTML(rng) ---I think here is the issue
            .Display
        End With
    Next i
Next c

Set OApp = Nothing
Set OMail = Nothing

End Sub

这是 RangetoHTML 函数，它给了我错误的结果

Function RangetoHTML(rng As Range)

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


        TempFile = ActiveWorkbook.Path & ".htm"

        'Copy the range and create a new workbook to past the data in
       Set rng = ThisWorkbook.Worksheets("Sheet2").Range("A1:M3")
        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
        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

Answer 1

那是因为您的复制范围始终是恒定的:
改变这一行:

Set rng = ThisWorkbook.Worksheets("Sheet2").Range("A1:M3")

根据您的组合框值的范围。