Macro enviar correo desde excel cargando archivos

Expertos buenos días su ayuda por favor:

Cuento con :

  • Un archivo llamado relación de facturas.xlsx.
  • Una relación de facturas guardas en PDF en la ruta D: /Factura/

La estructura del archivo excel es en columna C esta el (los) nombre de archivo tal cual esta guardado en la ruta D: /Factura/ . En la columnas I y J se ubican correo de destinatarios a los cuales deberé de enviar dichas facturas. En la columna H el destinatario al cual copiaré dichos envíos. Con los datos indicados, necesito la ayuda en lo siguiente:

  1. Al dar clic en un botón:
  2. Busque y cargue el archivo según columna C
  3. Que incluya los destinatarios según columna I y J
  4. Que incluya al que se copia según columna H
  5. En el asunto deberá de decir: COBRO DE FACTURA // PERIODO // MES
  6. En el tenor (ya lo tengo definido)

Como dato adicional mi correo corporativo lo aperturo desde GMAIL

1 Respuesta

Respuesta
1

Te dejo esté código para que envíes tus correos con los datos adjuntos. Te recomiendo que pongas en una columna la ruta completa de cada archivo adjunto que deseas enviar.

Sub EnviaCorreo()
'----------------------------------------------------
'No quites estas líneas son sólo para que sigas teniendo mis datos
'Creada por José Saúl Méndez Alonso
'[email protected]
'----------------------------------------------------
On Error GoTo Err_EnviaCorreoFirma
    Dim MSOAPP As Object
    Dim eMail As Object
    Dim sCuerpo As String
    Dim sRutaFirma As String
    Dim sFirma As String
    Set MSOAPP = CreateObject("Outlook.Application")
    MSOAPP.Session.Logon
    Set eMail = MSOAPP.CreateItem(0)
    sCuerpo = "Aquí agrega el mensaje del correo"
    'Este ejemplo es mi equipo con Windows 8.1 de 64b
    sRutaFirma = "C:\Users\" & Environ("UserName") & "\AppData\Roaming\Microsoft\sFirmas\dlmd.txt"
    'Esta puede ser otra ruta sobre todo en XP
    'sRutaFirma = "C:\Documents and Settings\" & Environ("username") & "\Application Data\Microsoft\Signatures\dlmd.txt"
    If Dir(sRutaFirma) <> "" Then
        sFirma = GetBoiler(sRutaFirma)
    Else
        sFirma = ""
    End If
    With eMail
        .To = "[email protected]" 'Aquí pones a los destinatarios
        .CC = ""
        .BCC = ""
        .Subject = "Prueba de correo" 'Aquí pones el asunto
        .Body = sCuerpo & vbNewLine & vbNewLine & sFirma 'Esto es por si deseas incluir una firma
        .Attachments.Add ("C:\Cotización.pdf") 'Aquí van los adjuntos
        .Send
    End With
    Set eMail = Nothing
    Set MSOAPP = Nothing
Exit_EnviaCorreoFirma:
    Exit Sub
Err_EnviaCorreoFirma:
   MsgBox "Se generó una excepeción " & Err.Number & " - " & Err.Description
End Sub

Nota: Considera que cada que envíes un correo se mostrará un mensaje de seguridad.

Te dejo otro código, espero te sea de utilidad

Talves necesites activar Microsoft CDO for windows 2000 library en VBA

Sub SendMail_Gmail()
Dim Email As CDO.Message
Set Email = New CDO.Message
correo = "[email protected]" 'Aquí va tu correo de gmail
passwd = "pwd" Áquí pones el password 
destino = "[email protected]" 'Aquí pones a los destinatarios
mensaje = Range("A1") 'Aquí pones los datos dependiendo de las celdas
cuerpo = Range("B1")
archivo = Range("C1") 'Aquí debes poner la ruta completa 
Email.Configuration.Fields(cdoSMTPServer) = "smtp.gmail.com"
Email.Configuration.Fields(cdoSendUsingMethod) = 2
With Email.Configuration.Fields
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = CLng(25)
    .Item("http://schemas.microsoft.com/cdo/" & "configuration/smtpauthenticate") = Abs(1)
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 30
    .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = correo
    .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = passwd
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
End With
With Email
    .To = destino
    .From = correo
    .Subject = mensaje
    .TextBody = cuerpo
    '.AddAttachment archivo
    .Configuration.Fields.Update
    On Error Resume Next
    .Send
End With
If Err.Number = 0 Then
    MsgBox "El mail se envió con éxito", vbInformation, "Informe"
Else
    MsgBox "Se produjo el siguiente error: " & Err.Description, vbCritical, "Error nro " & Err.Number
End If
End Sub

HOla buenos días:

Como seria en el caso que la carpeta factura esta en OneDrive?

Saludos,

Para el caso de tener la carpeta en OneDrive o Dropbox, te sugiero que en tu archivo de Excel, agregues una columna con el vínculo a dicho elemento, y en correo lo tomará como un hipervínculo.

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas