Enviar e-Mail con VBA y Access

Solicito su ayuda para resolver un problema que tengo, en una base de datos tengo unos elementos con fecha de vencimiento y deseo que se envíe un correo electrónico 5 días antes de que se cumpla la fecha.
Me gustaría saber cual es el código para enviar un e-mail con VBA desde access donde se adjunte el informe que contiene los productos a vencer.
También acepto cualquier sugerencia pues no tengo mucha experiencia programando y me cuesta un poco entender el código.

3 Respuestas

Respuesta
1
Yo utilizo el siguiente código en una base de datos.
Te cuento. Tengo en una tabla de la base de datos el nombre del destinatario, el asunto, el texto del correo y la dirección de los ficheros adjuntos.
Para enviar los correos utiliza las funciones 'mapi', que tienes que añadirlas en las referencias (en el menú de herramientas). Si no te aparecen, busca MSMAPI32.ocx en Windows\system32.
El código es:
Option Compare Database
Option Explicit
Sub enviarTodosLosCorreos()
    Dim rs As Recordset
    Dim miMail As New MAPISession
    miMail.SignOn
    Set rs = CurrentDb().OpenRecordset("select * from smf_mail_destinos where smf_mail_enviar and not smf_mail_enviado")
    If Not rs.EOF Then
        rs.MoveLast
        rs.MoveFirst
    End If
    SysCmd acSysCmdInitMeter, "Enviando correo", rs.RecordCount
    Do While Not rs.EOF
        SysCmd acSysCmdUpdateMeter, rs.AbsolutePosition + 1
        DoEvents
        EnviarCorreo miMail, rs
        Rs. MoveNext
    Loop
    Rs. Close
    SysCmd acSysCmdClearStatus
    MiMail. SignOff
End Sub
Sub enviarCorreo(ByRef miMail As MAPISession, ByRef rs As Recordset)
    Static snAbierto As Boolean
    Dim miMensaje As New MAPIMessages
    miMensaje.SessionID = miMail.SessionID
    miMensaje.Compose
    ' Destinatario
    miMensaje.RecipIndex = miMensaje.RecipCount
    miMensaje.RecipType = 1
    miMensaje.RecipDisplayName = rs!smf_mail_destinatario
    On Error Resume Next
    miMensaje.ResolveName ' Comprueba el nombre del destinatario
    On Error GoTo 0
    If Err Then
        MsgBox "¡¡¡Error!!!" & vbCrLf & _
               "No se ha encontrado el destinatario:" & vbCrLf & rs!smf_mail_destinatario & vbCrLf & vbCrLf & _
               "Se eliminará de la lista de destinatarios", vbExclamation + vbOKOnly, "Enviar correo"
        miMensaje.Action = 14
    End If
    ' Asunto, texto y acuse de recibo
    miMensaje.MsgSubject = rs!smf_mail_asunto
    miMensaje.MsgNoteText = Space(10) & vbCrLf & rs!smf_mail_texto
    miMensaje.MsgReceiptRequested = True
    ' Ficheros adjuntos
    miMensaje.AttachmentPosition = 0
    ' Comprobamos si hay que añadir el fichero adjunto 01
    If Not IsNull(rs!smf_mail_adjuntar01) Then
        miMensaje.AttachmentPosition = miMensaje.AttachmentPosition + 1
        miMensaje.AttachmentIndex = miMensaje.AttachmentCount
        miMensaje.AttachmentName = smf_sin_path(rs!smf_mail_adjuntar01)
        miMensaje.AttachmentPathName = rs!smf_mail_adjuntar01
    End If
    ' O el fichero 2
    If Not IsNull(rs!smf_mail_adjuntar02) Then
        miMensaje.AttachmentPosition = miMensaje.AttachmentPosition + 1
        miMensaje.AttachmentIndex = miMensaje.AttachmentCount
        miMensaje.AttachmentName = smf_sin_path(rs!smf_mail_adjuntar02)
        miMensaje.AttachmentPathName = rs!smf_mail_adjuntar02
    End If
    miMensaje.AttachmentType = 0
    miMensaje.Send ' Envía el mensaje
    rs.Edit
    rs!smf_mail_enviado = True ' Marco el registro de la tabla como enviado
    rs.Update
End Sub
Function smf_sin_path(ByVal nomFich As String) As String
    Do While InStr(nomFich, "\") > 0
        nomFich = Right$(nomFich, Len(nomFich) - InStr(nomFich, "\"))
    Loop
    smf_sin_path = nomFich
End Function
Santiago ante todo muchas gracias por tu ayuda, tu código esta un poco avanzado para mi nivel de conocimiento pero ahí estoy intentando entenderlo. Al respecto tengo unas preguntas:
- smf_mail_destinos es una tabla?
- smf_mail_destinatario es un atributo de la tabla "smf_mail_destinos" que contiene las direcciones de destino?
- ¿smf_mail_adjuntar01 es un atributo de la tabla "smf_mail_destinos" que contiene los path de los archivos a adjuntar?
- Yo solo necesito adjuntar un informe de la base de datos, como se haría en ese caso.
Muchas gracias por todo.
A ver, smf_mail_destinos es una tabla de access que tiene, los siguientes campos:
- smf_mail_destinatario (dirección de la persona de destino)
- smf_mail_asunto (asunto del correo)
- smf_mail_texto (texto que aparece en el cuerpo del correo)
- smf_mail_adjuntar01 (nombre del primer fichero adjunto)
- smf_mail_adjuntar02 (nombre del segundo fichero adjunto)
... hasta 10 ficheros adjuntos posibles ...
- Smf_mail_enviar (marca para saber si tengo que enviar el correo)
- Smf_mail_enviado (marca para saber si se ha mandado el correo)
Esta es una forma de preparar un envío masivo de correos, pero dependiendo de cada caso interesa hacerlo de una forma u otra.
Habría que ver el contenido de las tablas de tu base de datos para poder adaptarla.
Entre otras cosas tendrás que poner en algún sitio una marca de 'aviso enviado' o mejor, 'fecha de último aviso' (o ambas).
En cuando a adjuntar un informe de Access, no sé puede hacer por las buenas. Supongo que tendrías que exportar el informe a un fichero 'rtf' o 'pdf' y adjuntarlo al correo.
Pero esas cosas hay que decidirlas en función del diseño de tu base de datos.
Pues Santiago te sigo agradeciendo la ayuda y sobre todo la paciencia, ya entiendo un poco mejor la cosa, mi base de datos es lo más sencilla, tiene apenas tres tablas en las cuales voy a manejar los DNS que la empresa donde trabajo piensa adquirir con su fecha de vencimiento, y lo que necesito es que se envíe un correo cuando falten 10 días para que se cumpla la fecha, de forma automática, entonces por medio de una consulta saco los DNS que vencen en los próximos 10 días y la presento en un informe, y ese informe quiero que se adjunte al correo.
Como ves no es muy complicado, he visto varios códigos para el envío de correos y uno que otro me funciona, pero en ninguno he logrado adjuntar el informe, pero si le pongo que adjunte un archivo completo con el path respectivo ahí si lo adjunta, entonces si me puedes colaborar con ese asunto te lo agradecería.
Un Saludo.
Lo más que te puedo ofrecer es que, si me mandas una copia de la base de datos (compactada y comprimida en zip), la echaré un vistazo y te empiezo a escribir el código que necesites (luego te tocaría ajustarlo a ti).
Pero no puedo asegurarte que lo tenga en esta semana porque estoy muy liado.
Muchas gracias por tu ayuda, me sirvió para darme una idea de como hacer lo que quiero, no quiero inportunarte pues necesito que funcione lo más pronto posible, cualquier duda pequeña que tenga estaré consultando.
Muchas gracias
Respuesta

Al probar el código y me da error en el rs. Pongo el codigo:

Private Sub btn347_Click()
enviarTodosLosCorreos
End Sub

Sub enviarTodosLosCorreos()
Dim rs As Recordset 'Variable para selector de registro

Set rs = CurrentDb().OpenRecordset("select * from PROVEEDOR_pru where CORREO1 is not null")
'No se para que sirve
If Not rs.EOF Then
rs.MoveLast
rs.MoveFirst
End If

'Mensaje en la barra del estado
SysCmd acSysCmdInitMeter, "Enviando correo", rs.RecordCount
'Mientras el registro no se al último (rs.EOF) repetir el bucle:
Do While Not rs.EOF
SysCmd acSysCmdUpdateMeter, rs.AbsolutePosition + 1
EnvioEmail_347 , rs
rs.MoveNext
Loop

rs.Close
SysCmd acSysCmdClearStatus
End Sub

Private Function EnvioEmail_347() As Boolean
On Error GoTo ManipulaError
Dim oApp As Outlook.Application
Dim oMail As Outlook.MailItem
If Me.CORREO1 <> "" Then
Set oApp = CreateObject("Outlook.Application")
Set oMail = oApp.CreateItem(olMailItem)
With oMail
.To = Me.CORREO1
.Subject = Me.NOMBRE & " 347"
.Body = "Estimado proveedor:" + vbCrLf + vbCrLf + "Le adjuntamos el 347 para su validación"
'If Not IsNull(Me.TxtArchivo) Then
'.Attachments.Add CStr(Me.TxtArchivo)
'End If
.Send
End With
Set oApp = Nothing
EnvioEmail = True
Else
MsgBox "EL CLIENTE NO TIENE EMAIL REGISTRADO", vbExclamation, "Error"
End If
Salir:
Exit Function
ManipulaError:
MsgBox Err.Number & " : " & Err.Description
End Function

Respuesta

Si el error lo da en la línea que declara a 'rs' (Dim rs As Recordset ) se la puede cambiara por esta:

Dim rs As DAO.Recordset 

El hilo es del año 2009 y hay pequeños cambios evolutivos en el transcurso de catorce años (2009 ==> 2023).

Nota: en el código publicado hay errores que (asumo) se generaron al copiarlos, afectan a la función 'EnvioEmail_347' que esta declarada así:

Private Function EnvioEmail_347() As Boolean

Y se la intenta utilizar así:

EnvioEmail_347 , rs

1.- Es una función no una subfunción (Sub)

2.- La función tal como esta declarada no admite parámetros

Para que admitiese parámetros se la tendría que declarar así:

Private Function EnvioEmail_347(una-variable-para-recibir-el-parámetro) As Boolean

Y para utilizarla, así: 

EnvioEmail_347 (rs) 

xx = EnvioEmail_347 (rs) ' y xx obtendría el valor booleano que retornase la función

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas