Excel VBA-按關鍵字，按發件人計數電子郵件中的關鍵字

Question

解：

Option Compare Text

Sub Count_Emails()

Dim oNS As Outlook.Namespace
Dim oTaskFolder As Outlook.MAPIFolder
Dim oItems As Outlook.Items
Dim oFoldToSearch As Object
Dim intCounter As Integer
Dim oWS As Worksheet
Dim dStartDate, dEnddate As Date
Dim CharityBG, CureBG, PartySJ, WooWooSJ As Integer

Set oWS = Sheets("Sheet1")
Set oNS = GetNamespace("MAPI")
Set oTaskFolder = oNS.Folders("bill.gates@microsoft.com")
Set oFoldToSearch = oTaskFolder.Folders("Inbox").Folders("New Folder")
Set oItems = oFoldToSearch.Items

intCounter = 1
dStartDate = oWS.Range("A1").Value
dEnddate = oWS.Range("B1").Value

Do

    With oWS

        If DateSerial(Year(oItems(intCounter).ReceivedTime), Month(oItems(intCounter).ReceivedTime), Day(oItems(intCounter).ReceivedTime)) >= dStartDate And _
           DateSerial(Year(oItems(intCounter).ReceivedTime), Month(oItems(intCounter).ReceivedTime), Day(oItems(intCounter).ReceivedTime)) <= dEnddate And _
           oItems(intCounter).Subject Like "*Charity Work*" And oItems(intCounter).SenderName = "Bill Gates" Then
           CharityBG = CharityBG + 1
        End If
        If DateSerial(Year(oItems(intCounter).ReceivedTime), Month(oItems(intCounter).ReceivedTime), Day(oItems(intCounter).ReceivedTime)) >= dStartDate And _
           DateSerial(Year(oItems(intCounter).ReceivedTime), Month(oItems(intCounter).ReceivedTime), Day(oItems(intCounter).ReceivedTime)) <= dEnddate And _
           oItems(intCounter).Subject Like "*Curing Malaria*" And oItems(intCounter).SenderName = "Bill Gates" Then
           CureBG = CureBG + 1
        End If

        If DateSerial(Year(oItems(intCounter).ReceivedTime), Month(oItems(intCounter).ReceivedTime), Day(oItems(intCounter).ReceivedTime)) >= dStartDate And _
           DateSerial(Year(oItems(intCounter).ReceivedTime), Month(oItems(intCounter).ReceivedTime), Day(oItems(intCounter).ReceivedTime)) <= dEnddate And _
           oItems(intCounter).Subject Like "*Ghost Party*" And oItems(intCounter).SenderName = "Steve Jobs" Then
           PartySJ = PartySJ + 1
        End If
        If DateSerial(Year(oItems(intCounter).ReceivedTime), Month(oItems(intCounter).ReceivedTime), Day(oItems(intCounter).ReceivedTime)) >= dStartDate And _
           DateSerial(Year(oItems(intCounter).ReceivedTime), Month(oItems(intCounter).ReceivedTime), Day(oItems(intCounter).ReceivedTime)) <= dEnddate And _
           oItems(intCounter).Subject Like "*WoooOOOooo*" And oItems(intCounter).SenderName = "Steve Jobs" Then
           WooWooSJ = WooWooSJ + 1
        End If

    End With

    intCounter = intCounter + 1

Loop Until intCounter >= oItems.Count + 1

Set oNS = Nothing
Set oTaskFolder = Nothing
Set oAutomation = Nothing
Set oItems = Nothing
oWS.Range("A2").Value = CharityBG
oWS.Range("A3").Value = CureBG
oWS.Range("B2").Value = PartySJ
oWS.Range("B3").Value = WooWooSJ

End Sub

題：

我創建了一個excel VBA腳本，該腳本查看郵箱的文件夾，使用兩個excel單元格中的日期范圍，查找與發件人匹配的電子郵件，在主題行中查找關鍵字，統計出現的次數並將其寫入excel單元格。

使用電子郵件地址作為條件之一會出現問題。 如果我只是在尋找關鍵字，則無需指定發送者即可使用。 如果嘗試發送方和關鍵字，則返回0。如果嘗試使用MailItem.SenderEmailAddress，則無論如何都返回10。 我究竟做錯了什么？

Option Compare Text

Sub HowManyDatedEmailsv2()
Dim objOutlook As Object, objnSpace As Object, objFolder As Object
Dim EmailCount As Integer
Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace = objOutlook.GetNameSpace("MAPI")

   On Error Resume Next
   Set objFolder = objnSpace.Folders("\\Email Address 1\\").Folders("Inbox").Folders("Enquiries")
   Set myItems = objFolder.Items.Restrict("[SenderEmailAddress] <> '\\Email Address 2\\'")
   If Err.Number <> 0 Then
   Err.Clear
   MsgBox "No such folder."
   Exit Sub
   End If

Dim iCount, OnlineAT, CallinAT As Integer
Dim myDate1, myDate2 As Date
EmailCount = myItems.Count
OnlineAT = 0
CallinAT = 0
myDate1 = Sheets("Sheet1").Range("C5").Value
myDate2 = Sheets("Sheet1").Range("C6").Value
For iCount = 1 To EmailCount
With objFolder.Items(iCount)
    If DateSerial(Year(.ReceivedTime), Month(.ReceivedTime), Day(.ReceivedTime)) >= myDate1 And _
       DateSerial(Year(.ReceivedTime), Month(.ReceivedTime), Day(.ReceivedTime)) <= myDate2 And _
       SenderEmailAddress = "\\Email Address 1\\" And .Subject Like "*~Online*" Then
       OnlineAT = OnlineAT + 1
    End If
    If DateSerial(Year(.ReceivedTime), Month(.ReceivedTime), Day(.ReceivedTime)) >= myDate1 And _
       DateSerial(Year(.ReceivedTime), Month(.ReceivedTime), Day(.ReceivedTime)) <= myDate2 And _
       SenderEmailAddress = "\\Email Address 1\\" And .Subject Like "*~Callin*" Then
       CallinAT = CallinAT + 1
    End If
    End With
 Next iCount

Set objFolder = Nothing
Set objnSpace = Nothing
Set objOutlook = Nothing
Sheets("Summary").Range("C12").Value = OnlineAT
Sheets("Summary").Range("C13").Value = CallinAT

End Sub

Answer 1

我看不到您在何處設置“ SenderEmailAddress”，但是使用Outlook參考（ Microsoft Outlook 15.0 Object Library ）可以快速進行設置。 它與您嘗試執行的操作類似，我可以按預期獲得計數

Sub GetEmailDetails(ByVal strFolder)

    Dim oNS As Outlook.Namespace
    Dim oTaskFolder As Outlook.MAPIFolder
    Dim oItems As Outlook.Items
    Dim oFoldToSearch As Object
    Dim intCounter, intX As Integer
    Dim oWS As Worksheet: Set oWS = Worksheets(1)
    Dim dStartDate, dEnddate As Date
    Dim strSenderName As String

    Set oNS = GetNamespace("MAPI")
    Set oTaskFolder = oNS.GetDefaultFolder(olFolderInbox)
    Set oFoldToSearch = oTaskFolder.Folders(strFolder)
    Set oItems = oFoldToSearch.Items

    intCounter = 1
    intX = 2
    dStartDate = oWS.Cells(24, 3).Value
    dEnddate = oWS.Cells(25, 3).Value
    strSenderName = oWS.Cells(26, 3).Value
    Do

        With oWS

            ' If you wanted to check via email address and not the sender name, you can use this code
            'Dim strSenderEmail As String
            'If oItems(intCounter).SenderEmailType = "EX" Then
            '    strSenderEmail = oItems(intCounter).Sender.GetExchangeUser.PrimarySmtpAddress
            'Else
            '    strSenderEmail = oItems(intCounter).SenderEmailAddress
            'End If

            If DateSerial(Year(oItems(intCounter).ReceivedTime), Month(oItems(intCounter).ReceivedTime), Day(oItems(intCounter).ReceivedTime)) >= dStartDate And _
               DateSerial(Year(oItems(intCounter).ReceivedTime), Month(oItems(intCounter).ReceivedTime), Day(oItems(intCounter).ReceivedTime)) <= dEnddate And _
               oItems(intCounter).Subject Like "*Training Session*" And oItems(intCounter).SenderName = strSenderName Then

                .Cells(intX, 1).Value = oItems(intCounter).CreationTime
                .Cells(intX, 2).Value = oItems(intCounter).ReceivedTime
                .Cells(intX, 3).Value = oItems(intCounter).Subject
                .Cells(intX, 4).Value = oItems(intCounter).SenderName
                .Cells(intX, 5).Value = oItems(intCounter).SenderEmailAddress
                .Cells(intX, 6).Value = oItems(intCounter).CC
                .Cells(intX, 7).Value = oItems(intCounter).SenderEmailType
                '.Cells(intX, 8).Value = oItems(intCounter).Body

                intX = intX + 1

            End If

        End With

        intCounter = intCounter + 1

    Loop Until intCounter >= oItems.Count + 1

    Set oNS = Nothing
    Set oTaskFolder = Nothing
    Set oAutomation = Nothing
    Set oItems = Nothing

End Sub

我已經離開了您可以使用此對象訪問的一些項目。 希望這可以幫助