Sub ObtenerContactosOutlookExpress()
Dim objOutlook As Outlook.Application
Dim objNamespace As Outlook.NameSpace
Dim objAddressList As Outlook.AddressList
Dim objContactsFolder As Outlook.MAPIFolder
Dim objContactItem As Outlook.ContactItem
Dim db As DAO.Database
Dim rs As DAO.Recordset
' Crea una instancia de la aplicación Outlook
Set objOutlook = New Outlook.Application
' Obtiene el objeto de espacio de nombres MAPI
Set objNamespace = objOutlook.GetNamespace("MAPI")
' Obtiene la lista de direcciones predeterminada
Set objAddressList = objNamespace.GetDefaultFolder(olFolderContacts).AddressList
' Obtiene la carpeta de contactos
Set objContactsFolder = objAddressList.GetContactsFolder
' Abre la base de datos de Access
Set db = CurrentDb
' Abre un recordset en la tabla donde deseas almacenar los contactos (puede ser una tabla existente o crear una nueva)
Set rs = db.OpenRecordset("NombreTabla")
' Recorre todos los contactos en la carpeta de contactos
For Each objContactItem In objContactsFolder.Items
' Verifica si el contacto tiene una dirección de correo electrónico y no está duplicado
If objContactItem.Email1Address <> "" And Not ContactoDuplicado(objContactItem.Email1Address, rs) Then
' Agrega el contacto al recordset o tabla
rs.AddNew
rs("Nombre") = objContactItem.FirstName
rs("Apellido") = objContactItem.LastName
rs("Email") = objContactItem.Email1Address
' Otros campos que desees agregar
' ...
rs.Update
End If
' Libera la memoria del objeto de contacto
Set objContactItem = Nothing
Next objContactItem
' Cierra el recordset y la base de datos
rs.Close
Set rs = Nothing
Set db = Nothing
' Cierra la conexión de Outlook
objNamespace.Logoff
Set objNamespace = Nothing
Set objOutlook = Nothing
MsgBox "Los contactos de Outlook Express se han importado correctamente.", vbInformation
Exit Sub
Err_Handler:
MsgBox "Error al importar los contactos de Outlook Express.", vbExclamation
End Sub
Function ContactoDuplicado(ByVal email As String, ByVal rs As DAO.Recordset) As Boolean
' Verifica si el contacto ya existe en el recordset o tabla
rs.MoveFirst
Do Until rs.EOF
If rs("Email") = email Then
ContactoDuplicado = True
Exit Function
End If
rs.MoveNext
Loop
ContactoDuplicado = False
End Function