извлечь адрес электронной почты из внешнего вида

Question

Я пытаюсь извлечь адреса электронной почты из всех писем в моем почтовом ящике 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. Когда я запускаю этот код из редактора Outlook Visual Basic с помощью F5, я получаю сообщение об ошибке в следующей строке.

Dim dic As New Dictionary

"user defined type not defined"

Answer 1

Я предоставил обновленный код ниже

1. для вывода адресов электронной почты из папки «Входящие» в CSV-файл « c: \ emails.csv » (текущий код не предоставляет «перспективы» для собранных адресов
2. приведенный выше код работает с выбранной папкой, а не с папкой "Входящие" согласно вашему запросу

[Обновление: для ясности, это ваш старый код, который использует «раннее связывание», установка этой ссылки не нужна для моего обновленного кода ниже, который использует «позднее связывание»]

Часть A: Ваш существующий код (раннее связывание)

С точки зрения полученной вами ошибки:

В приведенном выше примере кода используется раннее связывание, этот комментарий "Требуется ссылка на Microsoft Scripting Runtime" указывает на то, что вам нужно установить ссылку

• Перейти в меню Сервис
• Выберите «Рекомендации»
• отметьте «Среда выполнения сценариев Microdoft»

Часть 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

Answer 2

экспорт файла в C: \ Users \ Tony \ Documents \ sent file.CSV

Тогда используйте ruby ​​

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

Answer 3

Вот обновленная версия для тех, кто использует 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

Answer 4

В outlook экспортируйте папку в файл csv, затем откройте в Excel. Простая функция MID должна быть в состоянии извлечь адрес электронной почты, если он еще не был помещен в столбец «от».