首页 文章

从outlook中提取电子邮件地址

提问于
浏览
0

我正在尝试提取Outlook收件箱中所有电子邮件的电子邮件地址 . 我在互联网上找到了这个代码 .

Sub GetALLEmailAddresses()

Dim objFolder As MAPIFolder
Dim strEmail As String
Dim strEmails As String
''' Requires reference to Microsoft Scripting Runtime
Dim dic As New Dictionary
Dim objItem As Object

''Set objFolder = Application.ActiveExplorer.Selection
Set objFolder = Application.GetNamespace("Mapi").PickFolder

For Each objItem In objFolder.Items

   If objItem.Class = olMail Then

       strEmail = objItem.SenderEmailAddress

       If Not dic.Exists(strEmail) Then

           strEmails = strEmails + strEmail + vbCrLf

           dic.Add strEmail, ""

       End If

我正在使用outlook 2007.当我使用F5从Outlook Visual Basic编辑器运行此代码时,我在以下行中收到错误 .

Dim dic As New Dictionary

"user defined type not defined"

4 回答

  • -1

    我在下面提供了更新的代码

    • 将收件箱电子邮件地址转储为CSV文件“ c:\emails.csv " (the current code provides no " outlook”以获取收集的地址

    • 上面的代码根据您的请求在选定的文件夹而不是收件箱中工作

    [Update: For clarity this is your old code that uses "early binding", setting this reference is unnecessary for my updated code below which uses "late binding"]

    A部分:您现有的代码(早期绑定)

    就您收到的错误而言:

    上面的代码示例使用早期绑定,此注释"Requires reference to Microsoft Scripting Runtime"表明您需要设置引用

    • 转到“工具”菜单

    • 选择'References'

    • 检查"Microdoft Scripting Runtime"

    enter image description here
    B部分:我的新代码(后期绑定 - 不需要设置引用)

    工作守则

    Sub GetALLEmailAddresses() 
    Dim objFolder As MAPIFolder
    Dim strEmail As String
    Dim strEmails As String
    Dim objDic As Object
    Dim objItem As Object
    Dim objFSO As Object
    Dim objTF As Object
    
    Set objDic = CreateObject("scripting.dictionary")
    Set objFSO = CreateObject("scripting.filesystemobject")
    Set objTF = objFSO.createtextfile("C:\emails.csv", 2)
    Set objFolder = Application.GetNamespace("Mapi").GetDefaultFolder(olFolderInbox)
    For Each objItem In objFolder.Items
        If objItem.Class = olMail Then
            strEmail = objItem.SenderEmailAddress
            If Not objDic.Exists(strEmail) Then
                objTF.writeline strEmail
                objDic.Add strEmail, ""
            End If
        End If
    Next
    objTF.Close
    End Sub
    
  • 2

    将文件导出到C:\ Users \ Tony \ Documents \ sent file.CSV

    然后使用红宝石

    email_array = []
    r = Regexp.new(/\b[a-zA-Z0-9._%+-]+@[a-zA-Z0-9.-]+\.[a-zA-Z]{2,4}\b/) 
    CSV.open('C:\Users\Tony\Documents\sent file.CSV', 'r') do |row|
        email_array << row.to_s.scan(r)                           
    end
    puts email_array.flatten.uniq.inspect
    
  • 0

    这是使用Exchange的更新版本 . 它将Exchange格式地址转换为普通电子邮件地址(使用@符号) .

    ' requires reference to Microsoft Scripting Runtime 
    Option Explicit
    
    Sub Write_Out_Email_Addresses()
        ' dictionary for storing email addresses
        Dim email_list As New Scripting.Dictionary
    
        ' file for output
        Dim fso As New Scripting.FileSystemObject
        Dim out_file As Scripting.TextStream
        Set out_file = fso.CreateTextFile("C:\emails.csv", True)
    
        ' open the inbox
        Dim ns As Outlook.NameSpace
        Set ns = Application.GetNamespace("MAPI")
        Dim inbox As MAPIFolder
        Set inbox = ns.GetDefaultFolder(olFolderInbox)
    
        ' loop through all items (some of which are not emails)
        Dim outlook_item As Object
        For Each outlook_item In inbox.Items
            ' only look at emails
            If outlook_item.Class = olMail Then
    
                ' extract the email address
                Dim email_address As String
                email_address = GetSmtpAddress(outlook_item, ns)
    
                ' add new email addresses to the dictionary and write out
                If Not email_list.Exists(email_address) Then
                    out_file.WriteLine email_address
                    email_list.Add email_address, ""
                End If
            End If
        Next
        out_file.Close
    End Sub
    
    ' get email address form a Mailoutlook_item
    ' this entails converting exchange format addresses
    ' (like " /O=ROOT/OU=ADMIN GROUP/CN=RECIPIENTS/CN=FIRST.LAST")
    ' to proper email addresses
    Function GetSmtpAddress(outlook_item As Outlook.MailItem, ns As Outlook.NameSpace) As String
    
        Dim success As Boolean
        success = False
    
        ' errors can happen if a user has subsequently been removed from Exchange
        On Error GoTo err_handler
    
        Dim email_address As String
        email_address = outlook_item.SenderEmailAddress
    
        ' if it's an Exchange format address
        If UCase(outlook_item.SenderEmailType) = "EX" Then
            ' create a recipient
            Dim recip As Outlook.Recipient
            Set recip = ns.CreateRecipient(outlook_item.SenderEmailAddress)
    
            ' extract the email address
            Dim user As Outlook.ExchangeUser
            Set user = recip.AddressEntry.GetExchangeUser()
            email_address = user.PrimarySmtpAddress
            email_address = user.Name + " <" + user.PrimarySmtpAddress + ">"
            success = True
        End If
    
    err_handler:
        GetSmtpAddress = email_address
    End Function
    

    感谢http://forums.codeguru.com/showthread.php?441008-Extract-sender-s-email-address-from-an-Exchange-email和Brettdj

  • 4

    在Outlook中,将文件夹导出到csv文件,然后在Excel中打开 . 一个简单的MID函数应该能够提取电子邮件地址,如果它还没有放在“从”列中 .

相关问题