Pasar a excell libreta contactos MOutlook!!

05/09/2004 - 16:59 por CRIS | Informe spam
Hola:
Necesito convertir la libreta de contactos de microsof outlook Xp a excell.
GRACIAS:
CRIS
 

Leer las respuestas

#1 Héctor Miguel
05/09/2004 - 20:05 | Informe spam
hola, cris !

Necesito convertir la libreta de contactos de microsof outlook Xp a excell.



puedes hacer un listado con los nombres/direcciones/[...] de los contactos en outlook +/- como sigue...
1.- deberas establecer una referencia en el proyecto [vba] a la libreria de objetos: 'Microsoft Outlook x.0 Object Library'
2.- a partir de la celda activa, te creara un listado con Nombre, empresa, e-mail[, ...] de cada contacto
[la libreria tiene mas objetos, metodos, eventos y propiedades de utilidad, pero... -desconozco cuales necesites-]
3.- [de acuerdo con el nivel de proteccion establecido en outlook] es posible que te 'pida autorizacion' para leer los datos.

si cualquier duda o infirmacion adicional... ¿comentas?
saludos,
hector.
en un modulo de codigo 'normal' ==Sub ObtenerContactosOL()
Dim Programa As New Outlook.Application, _
Espacio As Outlook.NameSpace, _
Carpeta As Outlook.MAPIFolder, _
Contacto As Outlook.ContactItem, _
Siguiente As Long
ActiveCell = "Nombre"
ActiveCell.Offset(, 1) = "Empresa"
ActiveCell.Offset(, 2) = "e-Mail"
' ActiveCell.Offset(, n) = "otros Encabezados" <= amplia segun otras propiedades del objeto
Range(ActiveCell, ActiveCell.Offset(, 2)).Font.Bold = True ' cambia el 2 por 'n' encabezados utilizados
Set Programa = CreateObject("Outlook.Application")
Set Espacio = Programa.GetNamespace("MAPI")
Set Carpeta = Espacio.GetDefaultFolder(olFolderContacts)
For Siguiente = 2 To Carpeta.Items.Count
Set Contacto = Carpeta.Items(Siguiente)
With Contacto
If .FullName <> "" Then ActiveCell.Offset(Siguiente - 1) = .FullName _
Else ActiveCell.Offset(Siguiente - 1) = "Nombre NO establecido"
If .CompanyName <> "" Then ActiveCell.Offset(Siguiente - 1, 1) = .CompanyName _
Else ActiveCell.Offset(Siguiente - 1, 1) = "Empresa NO establecida"
If .Email1Address <> "" Then ActiveCell.Offset(Siguiente - 1, 2) = .Email1Address _
Else ActiveCell.Offset(Siguiente - 1, 2) = "e-Mail NO establecido"
' If .OtraPropiedad <> "" Then ActiveCell.Offset(Siguiente - 1, n) = .OtraPropiedad _
Else ActiveCell.Offset(Siguiente - 1, n) = "Propiedad NO establecida" ' <= OJO con la 'n'
End With
Next
Range(ActiveCell, ActiveCell.Offset(, 2)).EntireColumn.AutoFit
Set Contacto = Nothing
Set Carpeta = Nothing
Set Espacio = Nothing
Set Programa = Nothing
End Sub

Preguntas similares