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

我看不到你在哪里设置＆＃39; SenderEmailAddress＆＃39;但是我使用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

我已经使用此对象留下了一些您有权访问的项目。希望这有帮助

Excel VBA - 按发件人的关键字计算电子邮件中的关键字

1 个答案: