循环下拉并创建单独的Outlook电子邮件正文

Question

我有一个仪表板。某些单元格值基于下拉列表值（下拉列表=月份名称）。我想将每个仪表板发送给五个不同的客户。由于客户（我i = 1到5），我的代码中有一个循环，并且我有一个循环来根据下拉列表值更改电子邮件正文。 我的问题是电子邮件正文始终相同 - 它不会根据下拉值进行更改。

      Sub CustomMailMessage()

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

        sig = ReadSignature("Internal.htm")
        Set rng = ThisWorkbook.Worksheets("Sheet2").Range("A1:M3")
        Set dvCell = Worksheets("Sheet2").Range("s1")
        Set inputRange = Evaluate(dvCell.Validation.Formula1)

        For Each c In inputRange
            For i = 1 To 5
            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 = c.Value & RangetoHTML(rng) & sig
                    .Display
                End With
            Next i
        Next c

        Set OApp = Nothing
        Set OMail = Nothing

        End Sub



    **Funtion for the signature**
    Private Function ReadSignature(sigName As String) As String
               Dim oFSO, oTextStream, oSig As Object
               Dim appDataDir, sig, sigPath, fileName As String
               appDataDir = Environ("APPDATA") & "\Microsoft\Signatures"
               sigPath = appDataDir & "\" & sigName

               Set oFSO = CreateObject("Scripting.FileSystemObject")
               Set oTextStream = oFSO.OpenTextFile(sigPath)
               sig = oTextStream.ReadAll
               ReadSignature = sig
            End Function



**Funtion for create HTML format from excel and create email body**
        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
            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

有什么想法吗？