按发件人统计Outlook电子邮件&；Excel VBA中的日期

目标是每月查找发件人发送的电子邮件总数/计数

下面的代码检索按月计数的日期/时间

如何在工作表上按发件人名称显示

我不确定我是否要用两本字典？如果是，则不知道如何解决该问题

Sub ReferSpecificFolder()
    'Declare Outlook application & folder object variables.
    Dim objOutlook as Object, objnSpace as Object, objFolder As Outlook.MAPIFolder
    Dim olItem As Variant 'Object
    Dim dictDate as Object

    Set objOutlook = CreateObject("Outlook.Application")
    Set objnSpace=objOutlook.GetNamespace("MAPI")
    Set objFolder = objOutlook.GetNamespace("MAPI").Folders("xyz@microsoft.com").Folders("Sales - 2020")
    Set dictDate=CreateObject("Scripting.Dictionary")
    Set myItems = objFolder.Items

    On Error Resume Next
    If Err.Number <> 0 Then
        Err.Clear
        MsgBox "No such folder!"
        Exit Sub
    End If

    If fldr.Items.Count = 0 Then
        MsgBox "There were no messages found in your folders"
        Exit Sub
    End If

    'Select the sheet to enter the data
    Dim wbData As Worksheet
    Dim LastRow As Long

    Set wbData = ThisWorkbook.Sheets("Rawdata - Time Period")
    LastRow = wbData.Range("A" & wbData.Rows.Count).End(xlUp).Row + 1

   myItems.SetColumns("SenderName, SentOn")
    For Each i In myItems
        dateStr=GetDate(i.SentOn)
        strSender=i.SenderName
        If Not dictDate.Exists(dateStr) Then
            dictDate(dateStr)=0
        End If
        dictDate(dateStr)=CLng(dictDate(dateStr))+1
    Next i

    For Each o In dictDate.keys
        LastRow = wbData.Range("A" & wbData.Rows.Count).End(xlUp).Row + 1
        With wbData
            .Cells(LastRow, 1) = o 'Received Date
            .Cells(LastRow, 3) = dictDate(o) 'Count
        End With
    Next o

    Set fldr = Nothing
    Set olItem = Nothing
    Set olApp = Nothing

    MsgBox "DONE!"
End Sub

Function GetDate(dt as Date) as String
   GetDate=Year(dt) & "-" & Month(dt) & "-" & Day(dt) & " " & Hour(dt) & ":" & Minute(dt)
End Function

子文件夹（）
'声明Outlook应用程序和文件夹对象变量。
Dim objOutlook作为对象，objnSpace作为对象，objFolder作为Outlook.MAPIFolder
Dim作为变体对象
将日期作为对象
设置objOutlook=CreateObject（“Outlook.Application”）
设置objnSpace=objOutlook.GetNamespace（“MAPI”）
设置objFolder=objOutlook.GetNamespace（“MAPI”）.Folders（“xyz@microsoft.com文件夹（“销售-2020”）
Set dictDate=CreateObject（“Scripting.Dictionary”）
设置myItems=objFolder.Items
出错时继续下一步
如果错误号为0，则
呃，明白了
MsgBox“没有这样的文件夹！”
出口接头
如果结束
如果fldr.Items.Count=0，则
MsgBox“在您的文件夹中找不到邮件”
出口接头
如果结束
'选择要输入数据的工作表
将wbData设置为工作表
最后一排一样长
设置wbData=ThisWorkbook.Sheets（“原始数据-时间段”）
LastRow=wbData.Range（“A”&wbData.Rows.Count）。结束（xlUp）。行+1
myItems.SetColumns（“SenderName，SentOn”）
对于myItems中的每个i
dateStr=GetDate（i.SentOn）
strSender=i.SenderName
如果不存在dictDate.Exists（dateStr），则
dictDate（dateStr）=0
如果结束
dictDate（dateStr）=CLng（dictDate（dateStr））+1
接下来我
对于dictDate.keys中的每个o
LastRow=wbData.Range（“A”&wbData.Rows.Count）。结束（xlUp）。行+1
使用wbData
.单元格（最后一行，1）=o'接收日期
.单元格（最后一行，3）=日期（o）计数
以
下一个o
设置fldr=无
设置m=无
设置olApp=Nothing
MsgBox“完成！”
端接头
函数GetDate（dt作为日期）作为字符串
GetDate=年（dt）&“-”月（dt）&“-”日（dt）&“&”小时（dt）&“：”分钟（dt）
端函数

这将生成一个发件人字典，然后生成一个与发件人字典中每个条目对应的日期字典

“代码>选项显式”考虑此强制 “工具|选项|编辑器”选项卡 '需要变量声明 ' “如果是，请声明为变体 ' 子引用SpecificFolderSender（） '早期绑定，必须设置对的引用 'Microsoft Outlook XX.X对象库 Dim objOutlook作为Outlook.Application 将objnSpace设置为Outlook.Namespace 将objFolder设置为Outlook.Folder 作为对象 以MJ为对象 将myItems暗显为Outlook.Items 将myItemsDate设置为Outlook.Items 作为字符串的Dim strFilter 将日期作为对象 dimo作为变体 Dim dateStr作为字符串 将发送者视为对象 dimpas变体 作为字符串的暗淡strSender 设置objOutlook=CreateObject（“Outlook.Application”） 设置objnSpace=objOutlook.GetNamespace（“MAPI”） '用于解决预期错误的特定目的 '由于找不到objFolder 出错时继续下一步 设置objFolder=objnSpace.Folders（“xyz@microsoft.com文件夹（“销售-2020”） 如果错误号为0，则 呃，明白了 “MsgBox”没有这样的文件夹 “出口接头 设置objFolder=objnSpace.PickFolder 如果objFolder为Nothing，则退出Sub 如果结束 “考虑强制紧跟错误再继续下一步 '返回正常错误处理 错误转到0 设置myItems=objFolder.Items 调试.打印vbCr&“myItems.Count:”&myItems.Count 如果objFolder.Items.Count=0，则 MsgBox“在”&objFolder.FolderPath中未找到任何邮件 出口接头 如果结束 Set dictSender=CreateObject（“Scripting.Dictionary”） '仅限于邮件项目 '0x001A001F ' https://stackoverflow.com/questions/61793354/delete-items-in-outlook-by-type-or-message-class 'strFilter=“@SQL=“”http://schemas.microsoft.com/mapi/proptag/0x001A001F“”如“IPM.Note” '设置myItems=myItems.Restrict（strFilter） '0x001A001E ““PR_消息_类”http://schemas.microsoft.com/mapi/proptag/0x001A001E ' https://www.slipstick.com/developer/read-mapi-properties-exposed-outlooks-object-model/ strFilter=“@SQL=“”http://schemas.microsoft.com/mapi/proptag/0x001A001E“”如“IPM.Note” Set myItems=myItems.Restrict（strFilter） 调试。打印vbCr和“邮件项” 调试。打印“myItems.Count:&myItems.Count” myItems.Sort“[SenderName]”，False Set dictDate=CreateObject（“Scripting.Dictionary”） 设置myItemsDate=myItems 调试。打印“myItemsDate.Count:”&myItemsDate.Count '要输入数据的工作表 将wbData设置为工作表 最后一排一样长 设置wbData=ThisWorkbook.Sheets（“原始数据-时间段”） LastRow=wbData.Range（“A”&wbData.Rows.Count）。结束（xlUp）。行+1 “发件人姓名词典” 调试。打印“发件人字典” '使用SetColumns方法，Outlook仅检查已缓存的属性， '并提供对这些属性的快速只读访问。 ' https://docs.microsoft.com/en-us/office/vba/api/outlook.items.setcolumns myItems.SetColumns（“SenderName”） 对于myItems中的每个MJ strSender=mj.SenderName 如果发送者不存在（strSender），则 Debug.Print“”&strSender dictSender（strSender）=0 如果结束 dictSender（strSender）=CLng（dictSender（strSender））+1 下一个 '迭代唯一的发件人名称 对于dictSender.keys中的每个p 调试。打印“的日期字典：”&p myItems.Sort“[SentOn]”，False myItemsDate。