En este desarrollo pongo de manifiesto mi experiencia para conectar visual basic con outlook al objeto de enviar cartas personalizadas, a medida desde una aplicación en access utilizando outlook como cliente de correo.
La aplicación va mas allá de un simple mailing, pues está adaptada a la funcionalidad concreta que se persigue. El objeto de mostrarla aquí es que se pueda ver el estilo de código que he desarrollado para conseguir dicho propósito.
Option Compare Database
‘Option Explicit
Dim con As AutConnMgr
Dim emu As AutSess
Function escribir_carta()
Dim MYWS As Workspace
Dim MYDB As Database
Dim xnombre_completo As String
Dim X_FICHEROS As Recordset
Dim X_TEMP As Recordset
Dim objWord As Object
Dim rngWord As Object
Set MYWS = DBEngine.Workspaces(0)
Set MYDB = MYWS.Databases(0)
Set X_FICHEROS = MYDB.OpenRecordset(«OFICINA_UNICA»)
‘DEFINO OBJETO WORD, O SEA VARIABLE QUE SIMBOLIZA EL DOCUMENTO WORD CON EL QUE ESTOY TRABAJANDO EN UN INSTANTE DADO
Set objWord = CreateObject(«Word.Application»)
X_FICHEROS.MoveFirst
Do While Not X_FICHEROS.EOF
xnombrefichero = X_FICHEROS.Fields(«OFICINA»).Value
‘ASOCIO AL OBJETO WORD UN DOCUMENTO WORD CONCRETO Y LO ABRO
objWord.Documents.Open «F:\CONTROL\CARTAS_UAGR\OCI_20190326\» & xnombrefichero & «.docx»
‘HAGO VISIBLE EL DOCUMENTO WORD
objWord.Visible = True
‘ACTIVO DOCUMENTO WORD
objWord.Application.Activate
‘DEFINO CONTENIDO DE DOCUMENTO WORD ASIGNÁNDOLO A UNA VARIABLE DE OBJETO
Set rngWord = objWord.ActiveDocument.content
On Error Resume Next
DoCmd.RunSQL «DELETE * FROM XYZ;»
On Error GoTo 0
sql1 = «SELECT OFICINA_CLIENTE_UNICO.OFICINA, OFICINA_CLIENTE_UNICO.ID_CLIENTE, OFICINA_CLIENTE_UNICO.NOMBRE_CLIENTE INTO XYZ FROM OFICINA_CLIENTE_UNICO WHERE OFICINA_CLIENTE_UNICO.OFICINA=» & «‘» & xnombrefichero & «‘» & » ORDER BY OFICINA_CLIENTE_UNICO.OFICINA;»
DoCmd.RunSQL sql1
Set X_TEMP = MYDB.OpenRecordset(«XYZ»)
X_TEMP.MoveFirst
i = 0
Do While Not X_TEMP.EOF
‘DESPLAZO EL CURSOR A UNA LINEA
rngWord.Paragraphs(14 + i).Range.InsertAfter X_TEMP.Fields(«ID_CLIENTE»).Value & » – » & X_TEMP.Fields(«NOMBRE_CLIENTE»).Value & vbLf
i = i + 1
X_TEMP.MoveNext
Loop
Set X_TEMP = Nothing
‘GRABO CAMBIOS EN DOCUMENTO WORD
objWord.ActiveDocument.Save
‘CIERRO DOCUMENTO WORD
objWord.ActiveDocument.Close
X_FICHEROS.MoveNext
Loop
‘CIERRO WORD
objWord.Quit
‘LIBERO OBJETO
Set objWord = Nothing
MYDB.Close
MYWS.Close
End Function
Function convertir_documentos()
Dim MYWS As Workspace
Dim MYDB As Database
Dim xnombre_completo As String
Dim XFICHEROS As Recordset
Dim objWord As Object
Set MYWS = DBEngine.Workspaces(0)
Set MYDB = MYWS.Databases(0)
Set XFICHEROS = MYDB.OpenRecordset(«OFICINA_UNICA»)
XFICHEROS.MoveFirst
Set objWord = CreateObject(«Word.Application»)
Do While Not XFICHEROS.EOF
xnombre_completo = «F:\CONTROL\CARTAS_UAGR\OCI_20190326\» & XFICHEROS.Fields(«OFICINA»).Value & «.docx»
objWord.Documents.Open xnombre_completo
objWord.Visible = True
objWord.Application.Activate
objWord.ActiveDocument.saveas2 xnombre_completo & «.pdf», 17
objWord.ActiveDocument.Close
XFICHEROS.MoveNext
Loop
objWord.Quit
Set objWord = Nothing
XFICHEROS.Close
MYDB.Close
MYWS.Close
End Function
Function generar_cartas()
Dim fs
Dim MYWS As Workspace
Dim MYDB As Database
Dim XFICHEROS As Recordset
Dim yorigen, ydestino As String
Set MYWS = DBEngine.Workspaces(0)
Set MYDB = MYWS.Databases(0)
Set XFICHEROS = MYDB.OpenRecordset(«OFICINA_UNICA»)
Set fs = CreateObject(«Scripting.FileSystemObject»)
XFICHEROS.MoveFirst
Do While Not XFICHEROS.EOF
xoficina = XFICHEROS.Fields(«OFICINA»).Value
yorigen = «F:\CONTROL\CARTAS_UAGR\» & «MODELO_UAGR.docx»
ydestino = «F:\CONTROL\CARTAS_UAGR\OCI_20190326\» & xoficina & «.docx»
fs.copyfile yorigen, ydestino
XFICHEROS.MoveNext
Loop
Set XFICHEROS = Nothing
Set fs = Nothing
MYDB.Close
MYWS.Close
End Function
Function enviar_correos_UAGR()
Dim MYWS As Workspace
Dim MYDB As Database
Dim XFICHEROS As Recordset
Dim objOutlook As Object
Dim objItem As Object
Dim objNamespace As Object
Dim myItem As Object
Dim myItem_modelo As Object
Dim myAttachments As Object
Dim xcuentas_de_correo As Object
Dim myFolder_modelos As Object
Dim myFolder_pendientes As Object
Dim myFolder_enviados As Object
Set objOutlook = CreateObject(«Outlook.Application»)
Set objNamespace = objOutlook.GetNamespace(«MAPI»)
objNamespace.Logon , , True, True
Set MYWS = DBEngine.Workspaces(0)
Set MYDB = MYWS.Databases(0)
Set XFICHEROS = MYDB.OpenRecordset(«CUENTAS»)
xrespuesta = MsgBox(«ATENCIÓN: se van a generar y guardar en una carpeta para su posterior envío:¿Proceder a la generación y guardado de los correos?», vbYesNoCancel)
Set myFolder_modelos = objNamespace.Folders(«xxx@yyy.es»).Folders(«Bandeja de Entrada»).Folders(«5. PEPS»).Folders(«MODELO_CARTA_AUTORIZACION»)
Set myFolder_pendientes = objNamespace.Folders(«xxx@yyy.es»).Folders(«Bandeja de Entrada»).Folders(«5. PEPS»).Folders(«PENDIENTES_ENVIO»)
Set myItems = myFolder_modelos.Items
If xrespuesta = 6 Then
XFICHEROS.MoveFirst
Do While Not XFICHEROS.EOF
Set myItem_modelo = myItems(«Refª.: Clientes sujetos a autorización previa para mantener relaciones comerciales»).Copy
Set myAttachments = myItem_modelo.Attachments
myItem_modelo.To = XFICHEROS.Fields(«EMAIL_OFICINA»).Value
myItem_modelo.cc = XFICHEROS.Fields(«EMAIL_DIRECTOR»).Value & «;» & XFICHEROS.Fields(«EMAIL_SUBDIRECTOR»).Value
ADJUNTO1 = XFICHEROS.Fields(«NOMBRE_COMPLETO»).Value
myAttachments.Add ADJUNTO1
myItem_modelo.Move myFolder_pendientes
XFICHEROS.MoveNext
Loop
End If
Set objOutlook = Nothing
Set objItem = Nothing
Set objNamespace = Nothing
Set myItem = Nothing
Set myFolder_modelos = Nothing
Set myFolder_pendientes = Nothing
Set myFolder_enviados = Nothing
MYDB.Close
MYWS.Close
MsgBox «TERMINADO *** GENERACIÓN DE CORREOS ***»
End Function
Function generar_adjunto()
Dim MYWS As Workspace
Dim MYDB As Database
Dim XFICHEROS As Recordset
Set MYWS = DBEngine.Workspaces(0)
Set MYDB = MYWS.Databases(0)
Set XFICHEROS = MYDB.OpenRecordset(«CUENTAS»)
XFICHEROS.MoveFirst
Do While Not XFICHEROS.EOF
XFICHEROS.Edit
XFICHEROS.Fields(«NOMBRE_COMPLETO»).Value = «F:\CONTROL\CARTAS_UAGR\OCI_20190326\» & XFICHEROS.Fields(«SUCURSAL»).Value & «.docx.pdf»
XFICHEROS.Update
XFICHEROS.MoveNext
Loop
MYDB.Close
MYWS.Close
End Function
