Libreta de direcciones...
Te comento : a través de una macro de excel necesito saber el contenido de la libreta de direcciones del outlook... Y ponele cargarlo en una hoja o en una lista desplegable o... Bueno muchísimas cosas más.
Respuesta de anders
1
Esta macro importa algunos datos (¿qué hay demasiados?) De los 'Contacts' ¿de Outlook? Espero que esto solucione tu problema, si no buscamos otra solución.
¿No olvides marcar? Microsoft Outlook x.xx Object library? En el editor VBA (¿Herramientas? Referencias).
Saludos
Anders
[ xltoday.net ]
?******************************************
Sub ImportarContactos()
Dim olApp As Outlook.Application
Dim olContacts As Outlook.MAPIFolder
Dim olContact As Outlook.ContactItem
Dim i As Integer
Set olApp = New Outlook.Application
Set olContacts = olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts)
'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)"
'importar contact items
For i = 2 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"), Order1:=xlAscending, Header:=xlGuess
End Sub
?******************************************
¿No olvides marcar? Microsoft Outlook x.xx Object library? En el editor VBA (¿Herramientas? Referencias).
Saludos
Anders
[ xltoday.net ]
?******************************************
Sub ImportarContactos()
Dim olApp As Outlook.Application
Dim olContacts As Outlook.MAPIFolder
Dim olContact As Outlook.ContactItem
Dim i As Integer
Set olApp = New Outlook.Application
Set olContacts = olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts)
'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)"
'importar contact items
For i = 2 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"), Order1:=xlAscending, Header:=xlGuess
End Sub
?******************************************
Maravilloso... por lo visto hay bastantes restricciones para esto (= seguridad)... un mensaje me avisaba que "algo" estaba accediendo a mi libreta de direcciones :) MUY BUENO GRACIAS!
