Question

我在Outlook中有邮箱，我需要计算超过30天的电子邮件。

我有以下代码：

Sub HowManyEmails()

Dim objOutlook As Object, objnSpace As Object, objFolder As MAPIFolder
Dim EmailCount As Integer

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

On Error Resume Next

Set objFolder1 = objnSpace.Folders("Outlook Data File").Folders("Inbox")
If Err.Number <> 0 Then
    Err.Clear
    MsgBox "No such folder."
    Exit Sub
End If

For Each MailItem In objFolder1.Items
    If MailItem.ReceivedTime < (Date - 30) Then EmailCount = EmailCount + 1
Next

Sheets("Sheet1").Range("C2").Value = EmailCount

Set objOutlook = Nothing
Set objnSpace = Nothing
Set objFolder = Nothing
End Sub

MailItem.ReceivedTime < (Date - 30)无法正常工作。我认为这是因为Outlook中的ReceivedTime包含小时/分钟。

Answer 1

使用Items.Restrict Method (Outlook)然后设置按日期过滤不同。

实施例

Option Explicit
Public Sub Example()
    Dim olApp As Outlook.Application
    Dim olNs As Outlook.Namespace
    Dim Inbox As Outlook.MAPIFolder
    Dim Items As Outlook.Items
    Dim Filter As String
    Dim DateDiff As Long
    Dim i As Long

    Set olApp = CreateObject("Outlook.Application")
    Set olNs = olApp.GetNamespace("MAPI")
    Set Inbox = olNs.GetDefaultFolder(olFolderInbox)

    DateDiff = Now - 30
    Filter = "[SentOn]  < '" & Month(DateDiff) & _
                         "/" & Day(DateDiff) & _
                         "/" & Year(DateDiff) & "'"

    Set Items = Inbox.Items.Restrict(Filter)

    MsgBox Items.Count & " Items in " & Inbox.Name

    For i = Items.Count To 1 Step -1
        Debug.Print Items(i) 'Immediate Window
    Next
End Sub

使用Excel VBA计算超过30天的Outlook电子邮件/附件

1 个答案: