在Outlook电子邮件中插入Excel中的问候语

问：

通常，我在电子邮件中获取问候语没有问题，但是这给了我一个问题。请参阅下面的工作表图像和代码。否则代码可以完美地执行，但是如果我尝试添加TimeofDayGreeting，它将无法执行。我还尝试定义一个字符串 strname，并以这种方式插入它，甚至将其直接放在任何 body、body1、body2 中，但它就是没有显示出来。我可能错过了一些愚蠢的东西，希望另一双眼睛能指出来。谢谢

TL的;DR--我希望代码将 col 1/place a time of day greeting 中的名字作为问候语放在电子邮件中。

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