Añadir attach para enviar mail desde Excel
Tengo esta macro que conseguí en la red. Desde Excel lanza Outlook con la información que incluyo en el código, envía un email a varios destinatarios, me personaliza y formatea el titulo, me deja escribir varias líneas en el mensaje... Etc, pero lo que no he podido aplicar es como adjuntar una de las hojas.
Por favor ¿me podrías ayudar con este tema?
Gracias de antemano
Saludos
Copio el código
Private Declare Function ShellExecute Lib "shell32.dll" _
Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long
Sub SendEmail ()
Dim Email As String, Subj As String
Dim Msg As String, URL As String
Dim r As String, Archivo As String
Application.ScreenUpdating = False
On Error Resume Next
'Mostramos hojas ocultas
Sheets("Hoja2").Visible = True
Sheets("Hoja1").Visible = True
'Declaramos
r = Sheets("Hoja3").Range("J8").Value
Email = "[email protected], [email protected], [email protected]"
Subj = "Titulo del mail "
Subj = Subj & Format(r, "00-0000") & "."
Archivo = Sheets("Hoja1")
'Composición del mensaje
Msg = ""
Msg = Msg & "Hola a todos" & vbCrLf & vbCrLf
Msg = Msg & "Adjunto envío pedido "
Msg = Msg & Format(r, "00-0000") & "." & vbCrLf & vbCrLf
Msg = Msg & "Saludos"
Subj = Application.WorksheetFunction.Substitute(Subj, "", "%20"")
Msg = Application.WorksheetFunction.Substitute(Msg, "", "%20")
Msg = Application.WorksheetFunction.Substitute(Msg, vbCrLf, "%OD%OA")
'Construimos la URL
URL = "mailto:" & Email & "?subject=" & Subj & "&body=" & Msg
'Ejecuta la URL (inicia el cliente de email)
ShellExecute 0&, vbNullString, URL, vbNullString, vbNullString, vbNormalFocus
'Espera dos segundos antes de enviar
Application.Wait (Now + TimeValue("0:00:02"))
Application.SendKeys "%s"
'Ocultamos de nuevo las hojas
Sheets("Hoja2").Visible = False
Sheets("Hoja1").Visible = False
Application.ScreenUpdating = True
End Sub
Por favor ¿me podrías ayudar con este tema?
Gracias de antemano
Saludos
Copio el código
Private Declare Function ShellExecute Lib "shell32.dll" _
Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long
Sub SendEmail ()
Dim Email As String, Subj As String
Dim Msg As String, URL As String
Dim r As String, Archivo As String
Application.ScreenUpdating = False
On Error Resume Next
'Mostramos hojas ocultas
Sheets("Hoja2").Visible = True
Sheets("Hoja1").Visible = True
'Declaramos
r = Sheets("Hoja3").Range("J8").Value
Email = "[email protected], [email protected], [email protected]"
Subj = "Titulo del mail "
Subj = Subj & Format(r, "00-0000") & "."
Archivo = Sheets("Hoja1")
'Composición del mensaje
Msg = ""
Msg = Msg & "Hola a todos" & vbCrLf & vbCrLf
Msg = Msg & "Adjunto envío pedido "
Msg = Msg & Format(r, "00-0000") & "." & vbCrLf & vbCrLf
Msg = Msg & "Saludos"
Subj = Application.WorksheetFunction.Substitute(Subj, "", "%20"")
Msg = Application.WorksheetFunction.Substitute(Msg, "", "%20")
Msg = Application.WorksheetFunction.Substitute(Msg, vbCrLf, "%OD%OA")
'Construimos la URL
URL = "mailto:" & Email & "?subject=" & Subj & "&body=" & Msg
'Ejecuta la URL (inicia el cliente de email)
ShellExecute 0&, vbNullString, URL, vbNullString, vbNullString, vbNormalFocus
'Espera dos segundos antes de enviar
Application.Wait (Now + TimeValue("0:00:02"))
Application.SendKeys "%s"
'Ocultamos de nuevo las hojas
Sheets("Hoja2").Visible = False
Sheets("Hoja1").Visible = False
Application.ScreenUpdating = True
End Sub
1 respuesta
Respuesta de Enrique Bernal
1