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.
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
