在Outlook邮件中插入Excel来源的时段问候语及姓名

我正尝试为以下可运行的VBA代码添加TimeOfDayGreeting功能，希望在邮件问候语中加入Excel第1列的姓名及时段问候语。但尝试定义字符串strname插入内容，或是直接将内容放入body、body1、body2等变量中，问候语均未显示。

数据示例 #

当前代码 #

Option Explicit

Const NAME_COL As Long = 1
Const VOUCHER_COL As Long = 4
Const DATE_COL As Long = 12
Const CHKNUM_COL As Long = 11
Const AMT_COL As Long = 8
Const TOADDR_COL As Long = 14

Sub Example()
Dim statusWS As Worksheet
Set statusWS = ActiveWorkbook.Worksheets("Check Reconciliation Status")
PrepareData statusWS


'--- only do this once
Dim outlookApp As Outlook.Application
Set outlookApp = AttachToOutlookApplication

Dim addresses As Dictionary
Set addresses = GetEmailAddresses(statusWS)


Dim emailAddr As Variant
For Each emailAddr In addresses
    '--- create the email now that everything is ready
    Dim email As Outlook.MailItem
    Set email = outlookApp.CreateItem(olMailItem)
    With email
        .To = emailAddr
        .Subject = "Open Vouchers"
        .HTMLBody = BuildEmailBody(statusWS, addresses(emailAddr))
        '--- send it now
        '    (if you want to send it later, you have to
        '     keep track of all the emails you create)
        .Display
    End With
Next emailAddr
End Sub


Sub PrepareData(ByRef ws As Worksheet)
With ws
    .Rows("1:6").Delete
    .Range("A1:N1").AutoFilter
    .AutoFilter.Sort.SortFields.Clear
    .AutoFilter.Sort.SortFields.Add2 key:=Range("A1"), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortTextAsNumbers
    With .AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    .Rows("2:5").Delete Shift:=xlUp
    .Range("i2") = "Yes"
    
    '--- it only makes sense to find the last row after all the
    '    other prep and deletions are complete
    Dim lastRow As Long
    lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    .Range("I2").AutoFill Destination:=Range("I2:I" & lastRow)
End With
End Sub

Function GetEmailAddresses(ByRef ws As Worksheet) As Dictionary
Dim addrs As Dictionary
Set addrs = New Dictionary

With ws
    Dim lastRow As Long
    lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    
    '--- each entry in the dictionary is keyed by the email address
    '    and the item value is a CSV list of row numbers
    Dim i As Long
    For i = 2 To lastRow
        Dim toAddr As String
        toAddr = .Cells(i, TOADDR_COL).Value
        If addrs.Exists(toAddr) Then
            Dim theRows As String
            theRows = addrs(toAddr)
            addrs(toAddr) = addrs(toAddr) & "," & CStr(i)
        Else
            addrs.Add toAddr, CStr(i)
        End If
    Next i
End With
Set GetEmailAddresses = addrs
End Function

Function BuildEmailBody(ByRef ws As Worksheet, _
                    ByRef rowNumbers As String) As String

Const body1 As String = "<Font face = TimesNewRoman p style=font-size:18.5px color = " & _
                        "#0033CC)"
Const body2 As String = "<Font face = TimesNewRoman p style=font-size:18.5px color = " & _
                        "#0033CC)<br><br>You are receiving this email because our " & _
                        "records show you have an uncashed check as follows: "
Const body3 As String = "<B><br><br>Please reply to this email to request a new check. If your address has changed, please provide your current address for mailing." & _
                        "<br><br>***If we do not receive a reply from you within " & _
                        "the next 30 days, the amount of this check will be submitted to the state as abandoned property.<br><br>"
With ws
    Dim rowNum As Variant
    rowNum = Split(rowNumbers, ",")
    
    Dim body As String
    body = body1 & TimeOfDayGreeting & .Cells(rowNum(LBound(rowNum)), NAME_COL) & "," & body2

    Dim i As Long
    For i = LBound(rowNum) To UBound(rowNum)
        body = body & "<br><br>Voucher #:  " & .Cells(rowNum(i), VOUCHER_COL)
        body = body & "<br>Check Date:  " & Format(.Cells(rowNum(i), DATE_COL), "dd-mmm-yyyy")
        body = body & "<br>Voucher Amount:  " & Format(.Cells(rowNum(i), AMT_COL), "$#,##0.00")
    Next i
End With
body = body & body3
BuildEmailBody = body
End Function

Function EmailSignature() As String
'    Dim sigCheck As String
'    sigCheck = Environ("appdata") & "\Microsoft\Signatures\Uncashed Checks.htm"
'
'    If Dir(sigCheck) <> vbNullString Then
'        EmailSignature = GetBoiler(sigString)
'    Else
    EmailSignature = vbNullString
'    End If
End Function

Function TimeOfDayGreeting() As String
Select Case Time
  Case 0.25 To 0.5
       TimeOfDayGreeting = "Good morning "
  Case 0.5 To 0.71
       TimeOfDayGreeting = "Good afternoon "
  Case Else
       TimeOfDayGreeting = "Good evening "
End Select
End Function

Public Function OutlookIsRunning() As Boolean
'--- quick check to see if an instance of Outlook is running
Dim msApp As Object
On Error Resume Next
Set msApp = GetObject(, "Outlook.Application")
If Err > 0 Then
    '--- not running
    OutlookIsRunning = False
Else
    '--- running
    OutlookIsRunning = True
End If
End Function

Public Function AttachToOutlookApplication() As Outlook.Application
'--- finds an existing and running instance of Outlook, or starts
'    the application if one is not already running
Dim msApp As Outlook.Application
On Error Resume Next
Set msApp = GetObject(, "Outlook.Application")
If Err > 0 Then
    '--- we have to start one
    '    an exception will be raised if the application is not installed
    Set msApp = CreateObject("Outlook.Application")
End If
Set AttachToOutlookApplication = msApp
End Function

预期效果示例 #

问题分析与修复方案 #

核心问题点 #

1. HTML标签语法错误：body1中的标签写法混乱，多余右括号且未正确嵌套p与Font标签，导致后续内容无法正常渲染。
2. 函数调用缺失括号：TimeOfDayGreeting是函数，调用时必须加括号TimeOfDayGreeting()，否则不会执行函数返回问候语。

修复后的BuildEmailBody函数 #

Function BuildEmailBody(ByRef ws As Worksheet, _
                    ByRef rowNumbers As String) As String

' 修正HTML标签语法，统一使用标准CSS样式写法
Const body1 As String = "<p style='font-size:18.5px; color:#0033CC; font-family:Times New Roman;'>"
Const body2 As String = "<br><br>You are receiving this email because our records show you have an uncashed check as follows:</p>"
Const body3 As String = "<p><br><br><B>Please reply to this email to request a new check. If your address has changed, please provide your current address for mailing." & _
                        "<br><br>***If we do not receive a reply from you within the next 30 days, the amount of this check will be submitted to the state as abandoned property.</B><br><br></p>"
With ws
    Dim rowNum As Variant
    rowNum = Split(rowNumbers, ",")
    
    ' 提取当前邮箱对应的第一个联系人姓名
    Dim recipientName As String
    recipientName = .Cells(rowNum(LBound(rowNum)), NAME_COL).Value
    
    Dim body As String
    ' 调用函数时添加括号，确保获取正确的时段问候语
    body = body1 & TimeOfDayGreeting() & recipientName & "," & body2

    Dim i As Long
    For i = LBound(rowNum) To UBound(rowNum)
        ' 为账单信息统一添加字体样式，保证格式一致性
        body = body & "<p style='font-family:Times New Roman; font-size:18.5px;'>" & _
               "<br>Voucher #:  " & .Cells(rowNum(i), VOUCHER_COL) & _
               "<br>Check Date:  " & Format(.Cells(rowNum(i), DATE_COL), "dd-mmm-yyyy") & _
               "<br>Voucher Amount:  " & Format(.Cells(rowNum(i), AMT_COL), "$#,##0.00") & "</p>"
    Next i
End With
body = body & body3
BuildEmailBody = body
End Function

优化说明 #

• 统一HTML标签格式，避免语法错误导致的内容不显示问题；
• 提取联系人姓名到单独变量，提升代码可读性；
• 为账单信息添加统一字体样式，保证邮件整体格式一致。

内容的提问来源于stack exchange，提问作者learningthisstuff