Descargar la libreta de direcciones global de Outlook a un fichero plano tabulado


En estos tiempos de cambios laborales no está demás tener una copia de seguridad de los contactos de email.

Este script graba en un fichero de texto plano, delimitado por tabuladores, una “AddressList” de Outlook.
En
Set AdL = Session.AddressLists("Lista global de direcciones")
“Lista global de direcciones” debería ser cambiado por la lista global de tu organización.
Las tres líneas de arriba, que están comentadas, te pueden ayudar a encontrar el nombre de la lista.

La verdadera utilidad de este script es importar el .txt en excel y poder segmentar comunicación con un filtro automático.

.zip para descargar

Option Explicit
' Run Outlook, Press Alt+F11 to open VBA

Public Sub GetAddressListContacts()
'Fuente http://msdn.microsoft.com/en-us/library/office/bb175075(v=office.12).aspx
On Error GoTo On_Error

Dim Session As Outlook.NameSpace
Dim AdL As Outlook.AddressList
Dim AdE As Outlook.AddressEntry
Dim oExUser As Outlook.ExchangeUser
Dim FileNum As Integer
Dim tmp As String

FileNum = FreeFile
Open "c:\corporate_contacts.txt" For Output As #FileNum

Set Session = Application.Session
'For Each AdL In Session.AddressLists
' Debug.Print AdL.Name
'Next

Set AdL = Session.AddressLists("Lista global de direcciones")
Print #FileNum, "PrimarySmtpAddress" + vbTab + "FirstName" + vbTab + "LastName" + vbTab + "CompanyName" + vbTab + "Department" + vbTab + "JobTitle" + vbTab + "OfficeLocation" + vbTab + "StateOrProvince" + vbTab + "City"
For Each AdE In AdL.AddressEntries
Set oExUser = AdE.GetExchangeUser

If Not oExUser Is Nothing Then
With oExUser
If .PrimarySmtpAddress = "xalert@eservicios.indra.es" Then
Debug.Assert 1
End If
tmp = .PrimarySmtpAddress + vbTab _
+ .FirstName + vbTab _
+ .LastName + vbTab _
+ .CompanyName + vbTab _
+ .Department + vbTab _
+ .JobTitle + vbTab _
+ .OfficeLocation + vbTab _
+ .StateOrProvince + vbTab _
+ .City
End With
Print #FileNum, tmp
End If

Next

Exiting:
Close #FileNum
Exit Sub
On_Error:
MsgBox "error=" & Err.Number & " " & Err.Description
Resume Exiting

End Sub