Lista Global Direcciones Outlook

[febrero59]

Necesito poder extraer desde Excel VBA la lista global de direcciones de Outlook.

No consigo información.

¿Alguien puede darme una pista?

Juan Luis.

[Héctor Miguel]

mira si te sirve algo de lo comentado en esta añeja conversación

saludos,

hector.

[Antoni]

Macro adaptada de la  Página de Ron de Bruin. (creo)

No te olvides de añadir la referencia Microsoft Outlook Library xx.x

 

Sub ImportarContactosOutlook(): On Error Resume Next

Application.ScreenUpdating = False

Dim olApp As Object 'Outlook.Application
Dim olContacts As Object 'Outlook.MAPIFolder
Dim olContact As Object 'Outlook.ContactItem
Dim i As Integer

Set olApp = New Outlook.Application
Set olContacts = olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts)
Cells.Clear

'importar contactos
For i = 1 To olContacts.items.Count
  If TypeOf olContacts.items.Item(i) Is Outlook.ContactItem Then
    Set olContact = olContacts.items.Item(i)
    Cells(i, 1) = olContact.FullName
    Cells(i, 2) = olContact.Email1Address
    Cells(i, 3) = olContact.JobTitle
    Cells(i, 4) = olContact.CompanyName
    Cells(i, 5) = olContact.HomeTelephoneNumber
    Cells(i, 6) = olContact.MobileTelephoneNumber
    Cells(i, 7) = olContact.BusinessTelephoneNumber
    Cells(i, 8) = olContact.BusinessFaxNumber
    Cells(i, 9) = olContact.BusinessAddressStreet
    Cells(i, 10) = olContact.BusinessAddressPostalCode
    Cells(i, 11) = olContact.BusinessAddressCity
    Cells(i, 12) = olContact.BusinessAddressCountry
    Cells(i, 13) = olContact.HomeAddressStreet
    Cells(i, 14) = olContact.HomeAddressPostalCode
    Cells(i, 15) = olContact.HomeAddressCity
    Cells(i, 16) = olContact.HomeAddressCountry
  End If
Next

'eliminar variables de los objetos
Set olContact = Nothing
Set olContacts = Nothing
Set olApp = Nothing

'ordenar lista por Nombre
Cells.Sort Key1:=Range("A2")
Rows(1).Insert

'rotulos
Cells(1, 1) = "Nombre"
Cells(1, 2) = "E-mail"
Cells(1, 3) = "Título"
Cells(1, 4) = "Empresa"
Cells(1, 5) = "Tel (casa)"
Cells(1, 6) = "Tel (móbil)"
Cells(1, 7) = "Tel (trabajo)"
Cells(1, 8) = "Fax (trabajo)"
Cells(1, 9) = "Dir. (empresa)"
Cells(1, 10) = "Postal (empresa)"
Cells(1, 11) = "Ciudad (empresa)"
Cells(1, 12) = "País (empresa)"
Cells(1, 13) = "Dir. (casa)"
Cells(1, 14) = "Postal (casa)"
Cells(1, 15) = "Ciudad (casa)"
Cells(1, 16) = "País (Casa)"

End Sub

 

[febrero59]

Uau!!! Sorprendente.

Hasta el lunes no puedo hacer la prueba.

Comentaré. Muchas gracias,

Juan.