Question

我编写了代码来检查包含与特定日期对应的邮件的Outlook文件夹。

日期值位于单元格C3:C6中，并由do until循环调用。邮箱位于B3:B6中，并由for for next循环调用。

不知何故，宏没有得到今天日期的邮件数量，而今天收集的邮箱中有几封邮件。

Sub HowManyDatedEmails()

' Set Variables
Dim objOutlook As Object, objnSpace As Object, objFolder As Object
Dim EmailCount As Integer, DateCount As Integer, iCount As Integer
Dim myDate As Date
Dim arrEmailDates()

' Get Outlook Object
Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace = objOutlook.GetNamespace("MAPI")

For b = 3 To Range("C:C").Count
    ' Get Folder Object
    On Error Resume Next
    Set objFolder = objnSpace.Folders(Range("C" & b).Value).Folders("Inbox")
    If Err.Number <> 0 Then
        Err.Clear
        MsgBox "No such folder."
        Set objFolder = Nothing
        Set objnSpace = Nothing
        Set objOutlook = Nothing
        Exit Sub
    End If

    ' Put ReceivedTimes in array
    EmailCount = objFolder.Items.Count
    For iCount = 1 To EmailCount
        With objFolder.Items(iCount)
            ReDim Preserve arrEmailDates(iCount - 1)
            arrEmailDates(iCount - 1) = DateSerial(Year(.ReceivedTime), Month(.ReceivedTime), Day(.ReceivedTime))
        End With
    Next iCount

    ' Clear Outlook objects
    Set objFolder = Nothing
    Set objnSpace = Nothing
    Set objOutlook = Nothing

    ' Count the emails dates equal to active cell

    Range("D3").Select

    Do Until IsEmpty(ActiveCell)

        DateCount = 0
        myDate = ActiveCell.Value

        For i = 0 To UBound(arrEmailDates) - 1
            If arrEmailDates(i) = myDate Then DateCount = DateCount + 1
        Next i

        Selection.Offset(0, 1).Activate
        ActiveCell.Value = DateCount
        Selection.Offset(1, -1).Activate
    Loop
Next b
End Sub

Answer 1

尝试使用以下代码，您可以根据您的要求更改If条件，此处在D列中今天将粘贴日期，如果收到的日期大于D列中的日期，代码将提取电子邮件。

代码：

Sub HowManyDatedEmails()
Dim OutlookApp As Outlook.Application
Dim OutlookNamespace As Namespace
Dim wb As Workbook, ws As Worksheet
Dim Folder As MAPIFolder
Dim OutlookMail As Variant
Dim i As Integer
Set wb = ThisWorkbook
Set ws = wb.Sheets("Mail")
Set OutlookApp = New Outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
Set Folder = OutlookNamespace.GetDefaultFolder(olFolderInbox)
i = 1
For Each OutlookMail In Folder.Items
    If OutlookMail.ReceivedTime > ws.Range("D" & i).Value And OutlookMail.Subject <> ws.Range("B" & i).Value Then
        ws.Range("B1").Offset(i, 0).Value = OutlookMail.Subject
        ws.Range("C1").Offset(i, 0).Value = OutlookMail.ReceivedTime
        ws.Range("D1").Offset(i, 0).Value = OutlookMail.ReceivedTime
        ws.Range("E1").Offset(i, 0).Value = OutlookMail.SenderName
        ws.Range("F1").Offset(i, 0).Value = OutlookMail.Body
        i = i + 1
    End If
Next OutlookMail
Set Folder = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing
End Sub

谢谢

为什么检索今天电子邮件的数量会返回零？

1 个答案: