获取outlook中所有文件夹，所有邮件的地址列表到excel

hu_robin

很好，只是速度有点慢。

peizhsh005

学习了。谢谢！

billzhaopa

好贴，收藏，感谢。

踏破拖鞋

测试正常  挺方便的  谢谢版主奉献

eq7200

1.速度有点慢
2.准确度有差

eq7200

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