excel - 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. 首先进行早期绑定(bind)，以确保您正确访问属性。
   如何做到这一点？只需在工具>引用下添加对Outlook 库的引用即可。

   Microsoft Outlook XX.0 Object Library

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. 我不知道您是否正在使用字符串 TestSubject 或与其相等的字符串来测试 Subject。首先，我认为应该是:

   And .Subject Like "*Test Subject*"
   

   上面返回所有带有测试主题的主题。或者更好:

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

   如果您尝试获取 MailItem 且 Subject 等于 测试主题，则只需使用:

   And .Subject = "Test Subject"
   

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

   .Sender.GetExchangeUser.PrimarySmtpAddress
   

6. GetSMTPAddressForRecipients 过程需要一个 MailItem，但您提供了 MailItem To 属性(您说您按原样使用它，只是将其转换为函数)。另请注意，该过程将获取正在测试的 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

---

编辑1:额外功能

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. 不要忘记设置引用。