Estou com um código para copiar a página do Excel, mas não consigo colocar minha assinatura.
Sub Send_Range_Or_Whole_Worksheet_with_MailEnvelope_SI()
'Working in Excel 2002-2016
Dim AWorksheet As Worksheet
Dim Sendrng As Range
Dim rng As Range
On Error GoTo StopMacro
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Fill in the Worksheet/range you want to mail
'Note: if you use one cell it will send the whole worksheet
Set Sendrng = Worksheets("QUADRO_SI").Range("A1:Z296")
'Remember the activesheet
Set AWorksheet = ActiveSheet
strbody = "Prezados" & vbNewLine & vbNewLine & _
"" & vbNewLine & _
"Segue situação atualizada do Zoneamento das SIs, ver abaixo:" & vbNewLine & _
"" & vbNewLine & _
""
XDATE = Date
With Sendrng
' Select the worksheet with the range you want to send
.Parent.Select
'Remember the ActiveCell on that worksheet
Set rng = ActiveCell
'Select the range you want to mail
.Select
' Create the mail and send it
ActiveWorkbook.EnvelopeVisible = True
With .Parent.MailEnvelope
' Set the optional introduction field thats adds
' some header text to the email body.
.Introduction = strbody
With .Item
.To = ""
.Cc = ""
.BCC = ""
.Subject = "Acompanhamento do relatório de Zoneamento das SIs - " & XDATE
'.HTMLBody = "<P>Prezados,</P>" & "Segue relatório de Alarmes extraidos no PAIOL nessa semana, em anexo." & "<br>" & .HTMLBody
.Attachments.Add ("d:\Relatório de SIs.pdf")
.Send
End With
End With
'select the original ActiveCell
rng.Select
End With
'Activate the sheet that was active before you run the macro
AWorksheet.Select
StopMacro:
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
ActiveWorkbook.EnvelopeVisible = False
Set OutMail = Nothing
Set OutApp = Nothing
End Sub