VBA 函数总是返回 TRUE

Question

我有这个函数循环遍历我的 Outlook 收件箱，如果有符合我设定条件的电子邮件，则返回 Boolean 作为最终结果。 即使条件错误，该函数也始终返回 true。我将.Sender 替换为xxxxxxx，它也返回True。

GetSMTPAddressForRecipients 来自 MSDN 仅将 Sub 更改为 Function GetSMTPAddressForRecipients(mail As Outlook.MailItem)

我做错了什么？

Function CheckInbox(ByVal fpemail As Variant) As Boolean

CheckInbox = False

Dim objOutlook As Object, objNamespace As Object, objFolder As Object
Dim EmailCount As Integer
Set objOutlook = CreateObject("Outlook.Application")
Set objNamespace = objOutlook.GetNamespace("MAPI")

On Error Resume Next
Set objFolder = objNamespace.GetDefaultFolder(olFolderInbox)

Dim tdyDate As Date
Dim checkDate As Date
tdyDate = Format(Now(), "Short Date")
checkDate = DateAdd("d", -7, tdyDate) ' DateAdd(interval,number,date)

 Dim iCount As Integer, DateCount As Integer
 EmailCount = objFolder.Items.Count
 DateCount = 0

 ' loop the mailbox
 For iCount = 1 To EmailCount
 'check for sender.email type first, mine is 'EX'
 With objFolder.Items(iCount)
    If DateSerial(Year(.ReceivedTime), Month(.ReceivedTime), Day(.ReceivedTime)) >= checkDate And _
       DateSerial(Year(.ReceivedTime), Month(.ReceivedTime), Day(.ReceivedTime)) <= tdyDate And _
       .Subject Like "Test Subject" And _
       .Sender.GetExchangeUser.PrimarySmtpAddress = "xxxxxxx" And _
       GetSMTPAddressForRecipients(.To) = fpemail Then
       CheckInbox = True
       Exit Function
    Else
       CheckInbox = False
    End If
 End With
 Next iCount

Set objFolder = Nothing
Set objNamespace = Nothing
Set objOutlook = Nothing

End Function

Answer 1

这些是您可能需要考虑的事情：

1. 首先进行早期绑定以确保您正确访问属性。
   您如何做到这一点？只需在 Tools>References 下添加对 Outlook 库 的引用。

   Microsoft Outlook XX.0 对象库

2. 现在，请确保您正在使用 Outlook MailItem 对象。您可以尝试在循环中插入检查。类似的东西：

   Dim objItem As Outlook.MailItem '/* add declaration to make use of intellisense */
   
   '/* backward loop, but starts with most recent email */
   For iCount = EmailCount To 1 Step -1 
       ' check for sender.email type first, mine is 'EX'
       If TypeOf objFolder.Items(iCount) Is MailItem Then
           Set objItem = objFolder.Items(iCount)
           With objItem
               '...rest of code here
   
           End With
       End if
   Next
   

   我不知道，但是您先发表了评论以检查类型，但从未见过执行此操作的代码，因此我检查了项目的类型。

3. 您不需要使用DateSerial 和所有其他函数来比较日期。你可以简单地：

   If Format(.ReceivedTime, "Short Date") >= checkdate Then
   

4. 我不知道您是否正在测试 Subject 中的字符串 Test Subject 或等于它。首先，我认为应该是：

   And .Subject Like "*Test Subject*"
   

   Above 返回所有带有 Test Subject 的主题。或者更好：

   And Instr(.Subject, "Test Subject") <> 0 
   

   如果您试图让MailItem 与Subject 等于测试主题，那么只需使用：

   And .Subject = "Test Subject"
   

5. 确保您确实从中检索到某些内容（应该是电子邮件地址）。

   .Sender.GetExchangeUser.PrimarySmtpAddress
   

6. GetSMTPAddressForRecipients 过程需要 MailItem，但您提供了 MailItem To property（您说您按原样使用它，只是将其转换为函数）。另请注意，该过程将使MailItem 中的所有收件人都被测试。为什么首先需要 SMTP 地址？我建议你只使用名称？类似的东西：

   And Instr(.To, "John Doe") <> 0 
   

   其中 John Doe 是收件人指定的名称。

---

重构你的函数：

Function CheckInbox(ByVal fpemail As String) As Boolean

    Dim objOutlook As Outlook.Application 'As Object
    Dim objNamespace As Outlook.Namespace 'As Object
    Dim objFolder As Outlook.Folder 'As Object
    '/* added declarations */
    Dim objItem As Outlook.MailItem
    Dim objRecip As Outlook.Recipient
    Dim EmailCount As Integer

    '/* I assumed Outlook is already running, revert to your code other wise */    
    Set objOutlook = GetObject(, "Outlook.Application")
    Set objNamespace = objOutlook.GetNamespace("MAPI")

    Set objFolder = objNamespace.GetDefaultFolder(olFolderInbox)

    Dim tdyDate As Date
    Dim checkDate As Date
    tdyDate = Format(Now(), "Short Date")
    checkDate = DateAdd("d", -7, tdyDate)

    Dim iCount As Integer, DateCount As Integer
    EmailCount = objFolder.Items.Count
    DateCount = 0

    '/* loop the mailbox, same as your code */
    For iCount = EmailCount To 1 Step -1
        '/* Check for the type */
        If TypeOf objFolder.Items(iCount) Is MailItem Then
            '/* Set the object, get intellisense */
            Set objItem = objFolder.Items(iCount)
            With objItem
               If Format(.ReceivedTime, "Short Date") >= checkDate _
               And Format(.ReceivedTime, "Short Date") <= tdyDate _
               And InStr(.Subject, "Test Subject") <> 0 _
               And .Sender.GetExchangeUser.PrimarySmtpAddress = "xxxxxxx" _
               And EvaluateRecipientSMTP(.Recipients, fpemail) Then
               '/* we use below function here */ 
                  CheckInbox = True
                  Exit Function
               Else
                  CheckInbox = False
               End If
            End With
        End If
    Next iCount

    Set objFolder = Nothing
    Set objNamespace = Nothing
    Set objOutlook = Nothing

End Function

---

Edit1：额外功能

Private Function EvaluateRecipientSMTP(objAllRecip As Outlook.Recipients, _
                                       fpemail As String) As Boolean

    Dim objRecip As Outlook.Recipient
    Dim objExUser As Outlook.ExchangeUser
    Dim objExDisUser As Outlook.ExchangeDistributionList

    For Each objRecip In objAllRecip
        Select Case objRecip.AddressEntry.AddressEntryUserType
        '/* OlAddressEntryUserType.olExchangeUserAddressEntry or
        'OlAddressEntryUserType.olOutlookContactAddressEntry */
        Case 0, 10
            Set objExUser = objRecip.AddressEntry.GetExchangeUser
            If Not objExUser Is Nothing Then
                If objExUser.PrimarySmtpAddress = fpemail Then
                    EvaluateRecipientSMTP = True
                    Exit For
                End If
            End If
        '/* OlAddressEntryUserType.olExchangeDistributionListAddressEntry */
        Case 1
            Set objExDisUser = objRecip.AddressEntry.GetExchangeDistributionList
            If Not objExDisUser Is Nothing Then
                If objExDisUser.PrimarySmtpAddress = fpemail Then
                    EvaluateRecipientSMTP = True
                    Exit For
                End If
            End If
        '/* recipient not part of your exchange server */
        Case Else
        '/* Do nothing */
        End Select
    Next
End Function

重要：

1. 上面的fpemail 是String 类型，这是您要查找的收件人姓名。
2. 对于上述第 5 项，您可能需要考虑 YowE3K's 建议。
3. 不要忘记设置参考。