|
Sub 导出根目录文件所有邮件发送人的信息QQ号871655978微信号13434111115()
On Error Resume Next
Dim App As New Outlook.Application, objFolders As Folder, objItem As Outlook.MailItem 'Outlook.MailItem
With CreateObject("scripting.dictionary") '创建字典引用
For Each objFolders In App.GetNamespace("MAPI").folders.Item(1).folders '遍历第一个用户的所有文件夹
For Each objItem In objFolders.Items '遍历文件夹内的所有邮件
i = i + 1 '计算邮件数量
.Item(objItem.SenderEmailAddress) = objItem.SenderName '通过字典记录发件人的邮箱地址及邮箱姓名
Next
Next
MsgBox i & "份邮件," & .Count & "个发件人"
[a1].Resize(.Count, 1) = WorksheetFunction.Transpose(.Keys) '导出关键到A列
[b1].Resize(.Count, 1) = WorksheetFunction.Transpose(.Items) '导出条目到B列
End With
End Sub |
|