Mensaje enviado por José Braulio Moreno Suárez <jbmoreno@supercable.es> el 22/11/2001
Esto marcha, queda más o menos así (crear contactos desde *.mdb)
'* * * * * * * * * * * * * * * * * * * * * * * * * * *
'* Este módulo Crea contactos en Outlook *
'* recorriendo una Base de Datos *.mdb *
'* Debe estar instalada la biblioteca de referencias *
'* Microsoft DAO 3.6 Objetc Library *
'* * * * * * * * * * * * * * * * * * * * * * * * * * *
Sub BuscarContactosDeBaseDeDatos()
'Establece las variables
Dim dbsBaseDeDatos As Database
Dim rstTablaBaseDeDatos As Recordset
Dim strTablaBaseDeDatos As String
Dim strCampoNombreCompletoDeTablaBaseDeDatos As String
Dim strConsultaCampoDeTablaBaseDeDatos As String
'Establece los valores de las variables
strTablaBaseDeDatos = "C:\WGOLDEN\DATOS\FART3D.mdb"
strConsultaCampoDeTablaBaseDeDatos = "SELECT Agentes.Codigo,
Agentes.Nombre, Agentes.Domicilio, Agentes.[C Postal],
Agentes.Poblacion, Agentes.Pais, Agentes.Telefono1, Agentes.Telefono2,
Agentes.Fax, Agentes.EMail, Agentes.[Pagina Web] FROM Agentes ORDER BY
Agentes.Nombre" 'Copia una Sentencia SQL de Access
Set dbsBaseDeDatos = OpenDatabase(strTablaBaseDeDatos)
Set rstTablaBaseDeDatos =
dbsBaseDeDatos.OpenRecordset(strConsultaCampoDeTablaBaseDeDatos,
dbOpenSnapshot)
'Llena el Recordset
With rstTablaBaseDeDatos
.MoveLast
.MoveFirst
'Recorre todos los Registros y crea el contacto
For Contacto = 1 To .RecordCount
strCampoNombreCompletoDeTablaBaseDeDatos = !Nombre
.MoveNext
'Llama a la Rutina que crea el Contacto en Outlook
CrearContactoEnOutlook
(strCampoNombreCompletoDeTablaBaseDeDatos)
Next Contacto
.Close
End With
'Cierra la base de datos abierta
dbsBaseDeDatos.Close
End Sub
Sub CrearContactoEnOutlook(strCampoNombreCompletoDeTablaBaseDeDatos As
String)
'Establece los Objetos y carpetas de Outlook donde se van a crear los
contactos
Set myOlApp = CreateObject("Outlook.Application")
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(olFolderContacts)
Set myItem = myOlApp.CreateItem(olContactItem)
'Establece los valores de los Campos del Formulario Contactos de Outlook
With myItem
.FullName = strCampoNombreCompletoDeTablaBaseDeDatos 'Nombre
completo
'Salva los Objetos
myItem.Save
End With
End Sub