如何从Outlook已发送和已接收邮件中导出全部邮箱地址？

一、解决LATAM键盘无法用ALT+F11打开VBA编辑器的问题 #

• 通过Outlook菜单打开：文件 → 选项 → 自定义功能区 → 勾选「开发工具」→ 确定后，顶部会出现「开发工具」选项卡，点击其中的「Visual Basic」按钮即可打开编辑器。
• 通过Windows搜索打开：直接搜索「Microsoft Visual Basic for Applications」，找到对应Outlook的程序启动。

二、VBA脚本实现提取邮箱并导出CSV #

以下脚本会遍历收件箱和已发送邮件文件夹，提取所有唯一邮箱地址并导出到桌面的CSV文件，无需管理员权限：

Sub ExtractUniqueEmailAddresses()
    Dim objOutlook As Object
    Dim objNamespace As Object
    Dim objInbox As Object
    Dim objSentItems As Object
    Dim objMail As Object
    Dim dictEmails As Object
    Dim strOutputPath As String
    
    ' 初始化Outlook对象
    Set objOutlook = CreateObject("Outlook.Application")
    Set objNamespace = objOutlook.GetNamespace("MAPI")
    Set objInbox = objNamespace.GetDefaultFolder(6) ' 6代表收件箱
    Set objSentItems = objNamespace.GetDefaultFolder(5) ' 5代表已发送邮件
    Set dictEmails = CreateObject("Scripting.Dictionary")
    
    ' 设置CSV输出路径（桌面）
    strOutputPath = Environ("USERPROFILE") & "\Desktop\UniqueEmails.csv"
    
    ' 遍历收件箱邮件
    For Each objMail In objInbox.Items
        ProcessEmail objMail, dictEmails
    Next
    
    ' 遍历已发送邮件
    For Each objMail In objSentItems.Items
        ProcessEmail objMail, dictEmails
    Next
    
    ' 导出到CSV文件
    Open strOutputPath For Output As #1
    Print #1, "Email Address" ' CSV表头
    For Each key In dictEmails.Keys
        Print #1, key
    Next
    Close #1
    
    MsgBox "提取完成！文件已保存到：" & strOutputPath, vbInformation
    
    ' 释放对象
    Set objMail = Nothing
    Set objInbox = Nothing
    Set objSentItems = Nothing
    Set objNamespace = Nothing
    Set objOutlook = Nothing
    Set dictEmails = Nothing
End Sub

Sub ProcessEmail(objMail As Object, dictEmails As Object)
    Dim objRecipient As Object
    Dim strEmail As String
    
    ' 提取收件人邮箱
    For Each objRecipient In objMail.Recipients
        strEmail = objRecipient.Address
        If strEmail <> "" And Not dictEmails.Exists(strEmail) Then
            dictEmails.Add strEmail, True
        End If
    Next
    
    ' 提取发件人邮箱
    strEmail = objMail.SenderEmailAddress
    If strEmail <> "" And Not dictEmails.Exists(strEmail) Then
        dictEmails.Add strEmail, True
    End If
End Sub

使用步骤：

• 打开VBA编辑器后，右键点击Project窗格中的「VBAProject(Outlook)」→ 插入 → 模块。
• 将上述代码粘贴到模块中，按F5运行，或点击编辑器工具栏的运行按钮。

三、Power Automate流程实现（无需VBA） #

该流程无需管理员权限，适用于Outlook网页版或桌面版：

1. 新建「云流」，触发选择「手动触发流」。
2. 添加步骤「获取邮件（V3）」，选择收件箱文件夹，设置顶数（如1000，按需调整）。
3. 重复步骤2，选择已发送邮件文件夹。
4. 添加步骤「组合」，将两个邮件列表合并为一个数组。
5. 添加步骤「选择」，映射提取字段：
   • 发件人邮箱：items()?['from']?['emailAddress']?['address']
   • 收件人邮箱数组：items()?['toRecipients']
6. 添加步骤「应用到每一个」，遍历收件人邮箱数组，提取单个邮箱地址并追加到临时数组。
7. 添加步骤「创建数组」，合并发件人和收件人的所有邮箱地址。
8. 添加步骤「应用到每一个」，遍历数组，用「追加到变量」存储邮箱地址（追加前判断变量中是否已存在该地址实现去重）。
9. 添加步骤「创建CSV表」，将去重后的邮箱数组转换为CSV格式。
10. 添加步骤「创建文件」，选择OneDrive或本地路径，保存为CSV文件。

四、无代码替代方法 #

• 使用Outlook搜索+Excel去重：
  1. 在Outlook搜索框输入from:* OR to:*，获取所有包含发件人/收件人的邮件。
  2. 点击「文件」→ 导出 → 导出到Excel。
  3. 在Excel中提取邮箱列，点击「数据」→ 删除重复项。
  4. 将处理后的表格另存为CSV文件。

内容的提问来源于stack exchange，提问作者Enrique Aquiles Matsumoto