Envío de un informe Access por correo Outlook

Código Visual Basic en Access para el envío de un informe mediante un correo electrónico de Outlook.

Se podrá elegir la cuenta de Outlook a usar indicando el remitente

Introducción

  • El código de todas las funciones iría dentro de un módulo de Access
  • En el presente ejemplo se supone que hay un informe Factura que se puede filtrar por el campo id_factura
  • Hay 2 versiones de la función EnviaCorreoOutlook según tenga referencia a Outlook explíta o implícita.

1) Envía el informe por correo

En este ejemplo se envía el informe de factura con identificador 10 al correo pepe@correo.es

  Call EnviaInformeFactura(10, "pepe@correo.es")

Y esta es la función usada:

Public Function EnviaInformeFactura( _
  ByVal IdFactura as Long, _
  ByVal Correo as String _
) As Boolean
	
  Dim ruta As String
  Dim asunto As Boolean
  Dim cuerpo As Boolean
  Dim ok As Boolean

  ruta = GuardaInformeFactura(IdFactura)  
  asunto = "Factura " & IdFactura  
  cuerpo = "Le adjunto factura con id=" & IdFactura
  ok = EnviaCorreoOutlook(Correo, asunto, cuerpo, Array(ruta))

  EnviaInformeFactura = ok

End Function

A continuación veremos en detalle las funciones (2)GuardaInformeFactura y (3)EnviaCorreoOutlook.

2) Guarda el informe en un PDF

  • La siguiente función guarda una factura en un fichero PDF.
  • El PDF se crea a partir de un hipotético informe Access Factura filtrado por su campo id_factura.
  • Retorna la ruta del archivo PDF creado.
  • El archivo PDF se guardará en la subcarpeta InformesPDF ubicada en el directorio de la BD.
Public Function GuardaInformeFactura(ByVal IdFactura as Long) As String

  Const INFORME = "Factura"

  Dim ruta as String

  ruta = ObtenRutaBD() & "InformesPDF\factura_" & IdFactura & ".pdf"

  DoCmd.OpenReport INFORME, acViewPreview, _
    WhereCondition:="id_factura=" & IdFactura, _
    WindowMode:=acHidden

  DoCmd.OutputTo objecttype:=acOutputReport, _
    objectName:=INFORME, _
    outputformat:=acFormatPDF, _
    outputFile:=ruta

  DoCmd.Close acReport, INFORME

  GuardaInformeFactura = ruta

End Function

Obtiene la ruta de la base de datos

Extrae la carpeta dónde se encuentra la presente base de datos Access.

Public Function ObtenRutaBD() As String

    Dim path As String     

    path = DBEngine.Workspaces(0).Databases(0).Name   

    ObtenRutaBD = Left(path, InStrRev(path, "\"))

End Function

3A) Envío de correo mediante referencia a Outlook

Referencia a Outlook

  • Ves al menú de código VBA (ALT+F11) de la BD Access
  • Selecciona en el menú: Herramientas > Referencias
  • Añade la referencia Microsoft Outlook ¿? Object Library

referencia_outlook.png

Esto activará los objetos de Outlook.
Puedes echar un vistazo a los mismos mediante el Examinador de objetos (F2).

Función de envío de correo

Const REMITENTE_PREDETERMINADO = "remitente@correo.es"

Public Function EnviaCorreoOutlook( _
    Para As String, _
    Asunto As String, _
    Cuerpo As String, _
    Optional Adjuntos As Variant = "", _
    Optional Remitente As String = "") _
As Boolean
    
    On Error GoTo Errores
    DoCmd.Hourglass True

    Dim programa As Outlook.Application
    Dim correo   As Outlook.MailItem
    Dim indice   As Integer
   
    '1) Iniciar
    Set programa = New Outlook.Application
    Set correo = programa.CreateItem(Outlook.olMailItem)

    '2) Parametrizar
    correo.Recipients.Add(Para)
    correo.subject = Asunto
    correo.body = Cuerpo
    'correo.DeleteAfterSubmit = True 'Borrar después de ser enviado
    'correo.OriginatorDeliveryReportRequested = True 'Destinatario solicitó acuse de recibo
    'correo.ReadReceiptRequested = True 'Remitente solicita confirmación de lectura
    correo.RecipientReassignmentProhibited = True 'El destinatario no puede reenviar el correo

    '3) Archivos adjuntos
    If IsArray(Adjuntos) Then
        For indice = LBound(Adjuntos) To UBound(Adjuntos)
            If Dir(CStr(Adjuntos(indice))) <> "" Then 'Comprueba de que exista el archivo adjunto
                correo.Attachments.Add CStr(Adjuntos(indice))
            End If
        Next
    End If
        
    '4) Remitente
    If Remitente = "" Then 
        Remitente = REMITENTE_PREDETERMINADO
    End If
    If Remitente <> "" Then
	Dim hayRemitente As Boolean
        Dim cuentas  As Outlook.Accounts
        Set cuentas = programa.GetNamespace("MAPI").Session.Accounts        
        For indice = 1 To cuentas.Count
            If cuentas(indice).SmtpAddress = Remitente Then
                correo.SendUsingAccount = cuentas(indice) 'Usa una cuenta existente en Outlook
                hayRemitente = True
                Exit For
            End If
        Next
        If Not hayRemitente Then
            correo.SentOnBehalfOfName = Remitente 'En el caso de que no haya una cuenta de Outlook
        End If
        Set cuentas = Nothing
    End If
    
    '5) Acción
    'correo.Display
    'correo.Save
    correo.Send
    
    EnviaCorreoOutlook = True
    
Salida:
    On Error Resume Next
    DoCmd.Hourglass False

    Set correo = Nothing
    Set programa = Nothing

    Exit Function

Errores:
    MsgBox "Error nº" & Err.Number & vbCrLf & Err.Description, _
      vbCritical, "Error nº" & Err.Number & " en EnviaCorreoOutlook"
    Resume Salida

End Function

3B) Envío de correo sin activar la referencia a Outlook

  • Al no usar la referencia de Outlook:
    • Evitamos problemas cuando cambie de versión
    • Habremos desactivado las ayudas al escribir código
  • En este caso como no existe la clase Outlook tenemos que usar la clase genérica Object
  • Tendremos que averiguar el valor de las constantes Outlook utilizadas
'Referencias manuales a Outlook
Const Outlook_olMailItem = 0

Const REMITENTE_PREDETERMINADO = "remitente@correo.es"

Public Function EnviaCorreoOutlook( _
    Para As String, _
    Asunto As String, _
    Cuerpo As String, _
    Optional Adjuntos As Variant = "", _
    Optional Remitente As String = "") _
As Boolean
    
    On Error GoTo Errores
    DoCmd.Hourglass True

    Dim programa As Object 'Outlook.Application
    Dim correo   As Object 'Outlook.MailItem
    Dim indice   As Integer
   
    '1) Iniciar
    Set programa = CreateObject("Outlook.Application")
    Set correo = programa.CreateItem(Outlook_olMailItem) 'Outlook.olMailItem

    '2) Parametrizar
    correo.Recipients.Add(Para)
    correo.subject = Asunto
    correo.body = Cuerpo
    'correo.DeleteAfterSubmit = True 'Borrar después de ser enviado
    'correo.OriginatorDeliveryReportRequested = True 'Destinatario solicitó acuse de recibo
    'correo.ReadReceiptRequested = True 'Remitente solicita confirmación de lectura
    correo.RecipientReassignmentProhibited = True 'El destinatario no puede reenviar el correo

    '3) Archivos adjuntos
    If IsArray(Adjuntos) Then
        For indice = LBound(Adjuntos) To UBound(Adjuntos)
            If Dir(CStr(Adjuntos(indice))) <> "" Then 'Comprueba de que exista el archivo adjunto
                correo.Attachments.Add CStr(Adjuntos(indice))
            End If
        Next
    End If
        
    '4) Remitente
    If Remitente = "" Then 
        Remitente = REMITENTE_PREDETERMINADO
    End If
    If Remitente <> "" Then
	Dim hayRemitente As Boolean
        Dim cuentas  As Object 'Outlook.Accounts
        Set cuentas = programa.GetNamespace("MAPI").Session.Accounts        
        For indice = 1 To cuentas.Count
            If cuentas(indice).SmtpAddress = Remitente Then
                Set correo.SendUsingAccount = cuentas(indice) 'Usa una cuenta existente en Outlook
                hayRemitente = True
                Exit For
            End If
        Next
        If Not hayRemitente Then
            correo.SentOnBehalfOfName = Remitente 'En el caso de que no haya una cuenta de Outlook
        End If
        Set cuentas = Nothing
    End If
            
    '5) Acción
    'correo.Display
    'correo.Save
    correo.Send
    
    EnviaCorreoOutlook = True
    
Salida:
    On Error Resume Next
    DoCmd.Hourglass False

    Set correo = Nothing
    Set programa = Nothing

    Exit Function

Errores:
    MsgBox "Error nº" & Err.Number & vbCrLf & Err.Description, _
      vbCritical, "Error nº" & Err.Number & " en EnviaCorreoOutlook"
    Resume Salida

End Function

4) Apéndice: Funciones extras para Outlook

Abre Outlook en la bandeja de CORREO_ENTRANTE o de CORREO_ENVIADO

'Referencias manuales a Outlook
Const Outlook_olFolderSentMail = 5 'Outlook.olFolderSentMail
Const Outlook_olFolderInbox = 6 'Outlook.olFolderInbox

Public Sub AbreOutlook(Optional Bandeja As String = "CORREO_ENTRANTE")

    Dim programa As Object 'Outlook.Application
    Dim espacio  As Object 'Outlook.NameSpace
    Dim carpeta  As Object 'Outlook.MAPIFolder
    
    Set programa = CreateObject("Outlook.Application")
    Set espacio = programa.GetNamespace("MAPI")
    
    If Bandeja = "CORREO_ENVIADO" Then
        Set carpeta = espacio.GetDefaultFolder(Outlook_olFolderSentMail) 
    Else
	Set carpeta = espacio.GetDefaultFolder(Outlook_olFolderInbox) 
    End If
    
    carpeta.Display
    
    Set carpeta = Nothing
    Set espacio = Nothing
    Set programa = Nothing

End Sub

Comprueba las cuentas de Outlook

Visualiza las cuentas de Outlook que existan y envía un correo de prueba en cada una

Public Sub TestCuentasOutlook()

    Const EMAIL = "mi_correo@correo.es"

    Dim programa As Outlook.Application
    Dim espacio As Outlook.NameSpace
    Dim cuentas As Outlook.Accounts
    Dim cuenta As Outlook.Account
    Dim correo As Outlook.MailItem
    Dim i As Integer

    Set programa = New Outlook.Application
    Set espacio = programa.GetNamespace("MAPI")
    Set cuentas = espacio.Session.Accounts
        
    Debug.Print cuentas.Count
    
    For i = 1 To cuentas.Count
        Set cuenta = cuentas(i)
        
        Debug.Print "Cuenta " & i
        Debug.Print "AccountType=" & cuenta.AccountType
        Debug.Print "DisplayName=" & cuenta.DisplayName
        Debug.Print "SmtpAddress=" & cuenta.SmtpAddress
        Debug.Print "UserName="    & cuenta.UserName
        
        Set correo = programa.CreateItem(Outlook.olMailItem)        
        correo.SendUsingAccount = cuenta 
        correo.Recipients.Add (EMAIL)
        correo.subject = "test " & cuenta.DisplayName
        correo.body = Now
        correo.Send        
        Debug.Print "Enviado correo a la cuenta " & cuenta.SmtpAddress
                           
    Next
    
    Set cuenta = Nothing
    Set cuentas = Nothing
    Set espacio = Nothing
    Set programa = Nothing

End Sub

En la siguiente imagen se muestran 2 cuentas de Outlook: primera@outlook.es y segunda@outlook.es.

cuentas_outlook.png

Comments

Proinf.net, ©2003-2020 ci 3.1.10 (CC) This work is licensed under Creative Commons This software is subject to the CC-GNU GPL