Cómo extraer todos los correos para mandar tarjetas de Año Nuevo.

Quería mandar un correo de «Feliz 2012» a todas las personas que me mandaron un correo este año. Para eso necesitaba una lista, así que modifiqué ligeramente el código de dos sitios muy útiles que menciono a continuación. Con eso obtuve un archivo de texto que pude abrir en Excel para quitar a todos los amables spameros que me han mandado correo no solicitado, y luego casi todos los «no-reply», «admin», «reply», «info», «automated». Pero bueno, lo importante era tener la lista.

De este lugar tomé el código:

Get email address of all users from all mails in Outlook Folder

De este saqué vbNewLine:
http://www.nsbasic.com/desktop/info/Specifications.html

Se oprime Alt-F11 y en el explorador de proyectos (que aparece oprimiendo Ctrl-R) se pega el código, en «este proyecto de Outlook».

Es importante especificar una ruta y nombre de archivo válidos en la instrucción Const de la primera línea.

Const c_archivo = "F:\Users\armando\Desktop\email addresses 2.txt"

Sub GetALLEmailAddresses()
    Dim objFolder1 As MAPIFolder
    Dim strEmail1 As String
    Dim strEmails1 As String
    Dim objItem As Object
    Dim writeText As Boolean

    Set objFolder1 = Application.GetNamespace("Mapi").PickFolder
    strEmails1 = GetMessages(objFolder1, True)
    'strEmails1 = GetMessageEmails(objFolder1, True)
    Debug.Print strEmails1
    writeText = SaveTextToFile(c_archivo, strEmails1, True)
End Sub

'this is verbatem from http://www.freevbcode.com/ShowCode.Asp, it saves the files to a text file
Public Function SaveTextToFile(FileFullPath As String, _
    sText As String, Optional Overwrite As Boolean = False) As _
    Boolean
    'Purpose: Save Text to a file
    'Parameters:
    '- FileFullPath - Directory/FileName to save file to
    '- sText - Text to write to file
    '- Overwrite (optional): If true, if the file exists, it
    'is overwritten. If false,
    'contents are appended to file
    'if the file exists
    'Returns: True if successful, false otherwise
    'Example:
    'SaveTextToFile "C:\My Documents\MyFile.txt", "Hello There"
    On Error GoTo ErrorHandler
    Dim iFileNumber As Integer
    iFileNumber = FreeFile
    If Overwrite Then
        Open FileFullPath For Output As #iFileNumber
    Else
        Open FileFullPath For Append As #iFileNumber
    End If
    Print #iFileNumber, sText
    SaveTextToFile = True
ErrorHandler:
    Close #iFileNumber
End Function

'This is the GetMessages that takes a folder and returns a list of the "name, e=mail, subject"s
Public Function GetMessages(oFolder As MAPIFolder, ByVal bRecursive As Boolean) As String
    Dim objFolder As Outlook.MAPIFolder
    Dim strEmail As String
    Dim strEmails As String
    Dim strName As String
    Dim strSubject As String
    Dim strAll As String
    Dim strItemAll As String
    Dim objItem As Object
    Dim objFolders As Outlook.Folders
    Set objFolders = oFolder.Folders
    For Each objFolder In objFolders
        For Each objItem In objFolder.Items
            If objItem.Class = olMail Then
                strEmail = objItem.SenderEmailAddress
                strName = objItem.SenderName
                strSubject = objItem.Subject
                ' ALFC I only want the emails.
                'strItemAll = strName + "," + strEmail + "," + strSubject
                strItemAll = strName & "|" & strEmail & vbNewLine
                strAll = strAll & vbNewLine & strItemAll
            End If
        Next
        If bRecursive Then
            ' Might want to compare this to strEmails instead of just appending.
            strAll = strAll + GetMessages(objFolder, bRecursive)
        End If
    Next
    GetMessages = strAll
End Function

'This is the the function that returns a list of ";" delimited e-mails with no duplicates.
Public Function getMessageEmails(oFolder As MAPIFolder, ByVal bRecursive As Boolean) As String
    Dim objFolder As Outlook.MAPIFolder
    Dim strEmail As String
    Dim strEmails As String
    Dim objItem As Object
    Dim objFolders As Outlook.Folders
    Set objFolders = oFolder.Folders
    For Each objFolder In objFolders
        For Each objItem In objFolder.Items
            If objItem.Class = olMail Then
                strEmail = objItem.SenderEmailAddress
                If InStr(strEmails, strEmail) = 0 Then strEmails = strEmails + strEmail + ";"""
            End If
        Next
        If bRecursive Then
            ' Might want to compare this to strEmails instead of just appending.
            strEmails = strEmails + getMessageEmails(objFolder, bRecursive)
        End If
    Next
    getMessageEmails = strEmails
End Function