用于计算昨天电子邮件的vba宏

我正在寻找一个vba宏来计算昨天收到的收件箱中的电子邮件数量

SentAt time倾向于在接近午夜时发送电子邮件，以此来抛开我的号码

一旦我有了这个计数，我需要将其添加到另外20个左右具有相同设置的邮箱的电子邮件总数中

当前脚本将填充邮箱中的所有电子邮件（无论日期如何），然后将按日期显示该文件夹中的电子邮件数量，因此这不是我真正需要的

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 objFolder = objnSpace.Folders("Mailbox - IT Support Center").Folders("Onshore - Jim").Folders("completed1")
    If Err.Number <> 0 Then
    Err.Clear
    MsgBox "No such folder."
    Exit Sub
    End If

EmailCount = objFolder.Items.Count

MsgBox "Number of emails in the folder: " & EmailCount, , "email count"

Dim dateStr As String
Dim myItems As Outlook.Items
Dim dict As Object
Dim msg As String
Set dict = CreateObject("Scripting.Dictionary")
Set myItems = objFolder.Items
myItems.SetColumns ("ReceivedTime")
' Determine date of each message:
For Each myItem In myItems
    dateStr = GetDate(myItem.ReceivedTime)
    If Not dict.Exists(dateStr) Then
        dict(dateStr) = 0
    End If
    dict(dateStr) = CLng(dict(dateStr)) + 1
Next myItem

' Output counts per day:
msg = ""
For Each o In dict.Keys
    msg = msg & o & ": " & dict(o) & " items" & vbCrLf
Next
MsgBox msg

Set objFolder = Nothing
Set objnSpace = Nothing
Set objOutlook = Nothing

End Sub

Sub HowManyEmails（）
Dim objOutlook为对象，objnSpace为对象，objFolder为MAPIFolder
将电子邮件计数为整数
设置objOutlook=CreateObject（“Outlook.Application”）
设置objnSpace=objOutlook.GetNamespace（“MAPI”）
出错时继续下一步
设置objFolder=objnSpace.Folders（“邮箱-IT支持中心”）.Folders（“岸上-吉姆”）.Folders（“已完成1”）
如果错误号为0，则
呃，明白了
MsgBox“没有这样的文件夹。”
出口接头
如果结束
EmailCount=objFolder.Items.Count
MsgBox“文件夹中的电子邮件数：”&EmailCount，“电子邮件数”
Dim dateStr作为字符串
将myItems暗显为Outlook.Items
作为对象的Dim dict
作为字符串的Dim msg
Set dict=CreateObject（“Scripting.Dictionary”）
设置myItems=objFolder.Items
myItems.SetColumns（“ReceivedTime”）
'确定每条消息的日期：
对于myItems中的每个myItem
dateStr=GetDate（myItem.ReceivedTime）
如果不存在dict.Exists（dateStr），则
dict（dateStr）=0
如果结束
dict（dateStr）=CLng（dict（dateStr））+1
下一个我的项目
'每天的输出计数：
msg=“”
对于dict.键中的每个o
msg=msg&o&“：”&dict（o）&“items”&vbCrLf
下一个
MsgBox味精
设置objFolder=Nothing
设置objnSpace=Nothing
设置objOutlook=Nothing
端接头

---

让我们尝试简化您的代码：

Sub HowManyEmails()

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

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

On Error Resume Next
Set objFolder = objnSpace.GetDefaultFolder(olFolderInbox).Folders("Onshore - Jim").Folders("completed1")
On Error GoTo 0

If objFolder Is Nothing Then MsgBox "No Such Folder": Exit Sub

For Each MailItem In objFolder.Items
    If DatePart("d", Date - 1) = DatePart("d", MailItem.ReceivedTime) Then EmailCount = EmailCount + 1
Next

MsgBox EmailCount
Set objOutlook = Nothing
Set objnSpace = Nothing
Set objFolder = Nothing

End Sub

这将统计昨天收到并存储在指定文件夹中的所有邮件。
我添加了

.GetDefaultFolder（olFolderInbox）

假设您的子文件夹位于

收件箱中

这样，outlook就可以准确地知道在哪里搜索。

但是，如果您访问的不是收件箱文件夹，而是邮箱中的另一个文件夹，该怎么办？
上面的代码将不起作用，您需要这样的代码：

Sub HowManyMails()

Dim objOutlook As Object, objnSpace As Object, objFolder, objNotInbox As MAPIFolder
Dim MailItem
Dim EmailCount As Integer
Dim strFolderName

Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace = objOutlook.GetNamespace("MAPI")
Set objFolder = objnSpace.GetDefaultFolder(olFolderInbox) 'reference to default folder

strFolderName = objFolder.Parent 'referrence to Inbox's parent which is Mailbox

On Error Resume Next
Set objNotInbox = objnSpace.Folders(strFolderName).Folders("Onshore - Jim").Folders("completed1")
On Error GoTo 0

If objNotInbox Is Nothing Then MsgBox "No Such Folder": Exit Sub

For Each MailItem In objNotInbox.Items
    If DatePart("d", Date - 1) = DatePart("d", MailItem.ReceivedTime) Then EmailCount = EmailCount + 1
Next

MsgBox EmailCount
Set objOutlook = Nothing
Set objnSpace = Nothing
Set objFolder = Nothing

End Sub

上述内容将统计

邮箱（“邮箱-IT支持中心”）中文件夹中的邮件数量，该文件夹与
收件箱（“岸上-吉姆”文件夹）的级别相同。

我删除了硬编码的邮箱名称，使其更具动态性，只需将其引用到
收件箱
父文件夹，即
邮箱


希望这是你开始得到你想要的

附加：（循环邮箱中的所有文件夹）

在上面的代码中，我假设您的文件夹不在
收件箱中


如果文件夹位于收件箱中，请修改第一个代码。
在
GetDate
中有什么？也许您可以将
GetDate（myItem.ReceivedTime）
与
GetDate（Date（）-1）
进行比较，以确定是否昨天收到了邮件。最终，我要做的是将前一天的所有“已完成”邮箱计数相加。到已完成邮箱的路径完全相同，但人员的姓名不同。请帮助您只需添加包含文件夹名称的数组。然后创建另一个循环来迭代每个文件夹。请参阅我更新的帖子。文件夹的实际路径是.Folders（“邮箱-IT支持中心”）.Folders（“岸上-吉姆”）.Folders（“完成1”）。所以唯一改变的是每一个的名字。FolderName（1）=“岸上-Jim”可能需要设置Tweek，还需要设置objNotInbox=objnSpace.Folders（strFolderName.Folders）（FolderName（i））.Folders（“completed1”）让我知道并感谢您提供的数组，它可以工作，只需要文件夹路径，我不确定父文件夹是否正确。是的。我不确定文件夹的路径，只是猜测而已。我只是告诉你怎么做，剩下的编辑就留给你了。：）
Sub HowManyMails()

Dim objOutlook As Object, objnSpace As Object, objFolder, objNotInbox As MAPIFolder
Dim MailItem
Dim EmailCount As Integer
Dim strFolderName
Dim FolderName() As Variant
Dim i As Integer

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

strFolderName = objFolder.Parent

ReDim FolderName(3) 'change this to how many folders you have

'assign each folder name on the array elements
FolderName(1) = "OnShore - Jim" 
FolderName(2) = "OnShore - John"
FolderName(3) = "OnShore - Ben"

'loop through each foldername
For i = 1 To 3
    On Error Resume Next
    Set objNotInbox = objnSpace.Folders(strFolderName).Folders(FolderName(i)).Folders("completed1")
    On Error GoTo 0

    If objNotInbox Is Nothing Then GoTo skip

    For Each MailItem In objNotInbox.Items
        If DatePart("d", Date - 1) = DatePart("d", MailItem.ReceivedTime) Then EmailCount = EmailCount + 1
    Next
skip:
Next

MsgBox EmailCount

End Sub