Macro enviar archivo PDF con cuerpo sin quitar la firma predefinida
Tengo un macro para enviar mi archivo en formato pdf con asunto predefinido
Pero en el cuerpo del correo quiero colocar lo escrito en una celda especifica pero sin que me quite la firma de outlook
Les dejo mi macro
Sub ENVIAR_OUTLOOCK_PDF()
Dim strTitulo As String
Dim Continuar As String
Dim TransRowRng As Range
Dim NewRow As Integer
Dim Limpiar As String
'
strTitulo = "CARTERA_DE_CLIENTES"
'
'
Set TransRowRng = ThisWorkbook.Worksheets("Cartera_de_Clientes").Cells(1, 1).CurrentRegion
NewRow = TransRowRng.Rows.Count + 1
With ThisWorkbook.Worksheets("Cartera_de_Clientes")
.Cells(NewRow, 1).Value = Date
.Cells(NewRow, 2).Value = ThisWorkbook.Sheets(1).Range("K9")
.Cells(NewRow, 3).Value = ThisWorkbook.Sheets(1).Range("K12")
.Cells(NewRow, 4).Value = ThisWorkbook.Sheets(1).Range("K13")
.Cells(NewRow, 5).Value = ThisWorkbook.Sheets(1).Range("K14")
.Cells(NewRow, 6).Value = ThisWorkbook.Sheets(1).Range("AR41")
.Cells(NewRow, 7).Value = ThisWorkbook.Sheets(1).Range("H42")
.Cells(NewRow, 8).Value = ThisWorkbook.Sheets(1).Range("H43")
.Cells(NewRow, 9).Value = ThisWorkbook.Sheets(1).Range("H44")
End With
Set TransRowRng = ThisWorkbook.Worksheets("Cat_Cotizados").Cells(1, 1).CurrentRegion
NewRow = TransRowRng.Rows.Count + 1
With ThisWorkbook.Worksheets("Cat_Cotizados")
.Cells(NewRow, 1).Value = Date
.Cells(NewRow, 2).Value = ThisWorkbook.Sheets(1).Range("j22")
.Cells(NewRow, 3).Value = ThisWorkbook.Sheets(1).Range("AG22")
.Cells(NewRow, 4).Value = ThisWorkbook.Sheets(1).Range("j23")
.Cells(NewRow, 5).Value = ThisWorkbook.Sheets(1).Range("AG23")
.Cells(NewRow, 6).Value = ThisWorkbook.Sheets(1).Range("j24")
.Cells(NewRow, 7).Value = ThisWorkbook.Sheets(1).Range("AG24")
.Cells(NewRow, 8).Value = ThisWorkbook.Sheets(1).Range("j25")
.Cells(NewRow, 9).Value = ThisWorkbook.Sheets(1).Range("AG25")
.Cells(NewRow, 10).Value = ThisWorkbook.Sheets(1).Range("J26")
.Cells(NewRow, 11).Value = ThisWorkbook.Sheets(1).Range("AG26")
.Cells(NewRow, 12).Value = ThisWorkbook.Sheets(1).Range("J27")
.Cells(NewRow, 13).Value = ThisWorkbook.Sheets(1).Range("AG27")
.Cells(NewRow, 14).Value = ThisWorkbook.Sheets(1).Range("J28")
.Cells(NewRow, 15).Value = ThisWorkbook.Sheets(1).Range("AG28")
.Cells(NewRow, 16).Value = ThisWorkbook.Sheets(1).Range("J29")
.Cells(NewRow, 17).Value = ThisWorkbook.Sheets(1).Range("AG29")
.Cells(NewRow, 18).Value = ThisWorkbook.Sheets(1).Range("J30")
.Cells(NewRow, 19).Value = ThisWorkbook.Sheets(1).Range("AG30")
.Cells(NewRow, 20).Value = ThisWorkbook.Sheets(1).Range("J31")
.Cells(NewRow, 21).Value = ThisWorkbook.Sheets(1).Range("AG31")
.Cells(NewRow, 22).Value = ThisWorkbook.Sheets(1).Range("J32")
.Cells(NewRow, 23).Value = ThisWorkbook.Sheets(1).Range("AG32")
.Cells(NewRow, 24).Value = ThisWorkbook.Sheets(1).Range("J33")
.Cells(NewRow, 25).Value = ThisWorkbook.Sheets(1).Range("AG33")
.Cells(NewRow, 26).Value = ThisWorkbook.Sheets(1).Range("J34")
.Cells(NewRow, 27).Value = ThisWorkbook.Sheets(1).Range("AG34")
.Cells(NewRow, 28).Value = ThisWorkbook.Sheets(1).Range("J35")
.Cells(NewRow, 29).Value = ThisWorkbook.Sheets(1).Range("AG35")
.Cells(NewRow, 30).Value = ThisWorkbook.Sheets(1).Range("J36")
.Cells(NewRow, 31).Value = ThisWorkbook.Sheets(1).Range("AG36")
.Cells(NewRow, 32).Value = ThisWorkbook.Sheets(1).Range("J37")
.Cells(NewRow, 33).Value = ThisWorkbook.Sheets(1).Range("AG37")
.Cells(NewRow, 34).Value = ThisWorkbook.Sheets(1).Range("J38")
.Cells(NewRow, 35).Value = ThisWorkbook.Sheets(1).Range("AG38")
.Cells(NewRow, 36).Value = ThisWorkbook.Sheets(1).Range("J39")
.Cells(NewRow, 37).Value = ThisWorkbook.Sheets(1).Range("AG39")
End With
If rpta = vbYes Then
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
"C:\Users\hmx0049\Documents\Cotizaciones 2015\11 Cotizaciones Noviembre\Hafele - " & Format(Now, "dd-mm-yyyy-hh.mm.ss") & ".pdf", Quality:= _
xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False
MsgBox "Se ha guardado correctamente.", vbQuestion + vbYesNo + vbYesNo, "HAFELE"
End If
'Enviar una hoja por correo
'por.dam
Application.ScreenUpdating = False
Application.DisplayAlerts = False
des = Range("k14")
body = Range("H42")
Set h2 = ActiveSheet
wpath = ThisWorkbook.Path & "\"
nombre = h2.Name
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=wpath & nombre & ".pdf", _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
Set dam1 = CreateObject("outlook.application")
Set dam2 = dam1.createitem(olmailitem)
dam2.to = des 'Destinatarios¡
dam2.Subject = "HAFELE COTIZACION" '"Asunto"
dam2.body = body
dam2.Attachments.Add wpath & nombre & ".pdf"
dam2.display
dam2.send
DoEvents
Kill wpath & nombre & ".pdf"
DoEvents
MsgBox "El Documento fue enviado .", vbQuestion + vbYesNo + vbYesNo, "HAFELE OUTLOOK"
End Sub
Como verán la macro hace varias cosas y la he armado gracias a sus foros
2 Respuestas
Te dejo esté código para que incluyas la firma en tus correos. De la macro que ya tienes, te recomiendo separarla en dos, en una deja todo lo que armas y exportas a PDF y usa la que te paso para el envío de los correos.
Sub EnviaCorreoFirma()
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]"
.CC = ""
.BCC = ""
.Subject = "Prueba de correo"
.Body = sCuerpo & vbNewLine & vbNewLine & sFirma
.Attachments.Add ("C:\Cotización.pdf")
.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 SubNota: Considera que cada que envíes un correo se mostrará un mensaje de seguridad.
Este ejemplo
http://www.programarexcel.com/2015/07/enviar-mail-con-excel-mediante-outlook.html
Acá tienes otros, veo que eres autodidacta entre todas vas a poder armar tu respuesta.
http://www.programarexcel.com/2015/02/enviar-mail-con-excel-desde-outlook-con.html
http://www.programarexcel.com/2015/10/enviar-mail-mediante-outlook-con-imagen.html
http://www.programarexcel.com/2015/03/excel-enviar-mail-mediante-outlook.html
http://www.programarexcel.com/2015/02/como-enviar-desde-excel-mail-con.html