- 09 Ago 2019 às 12:15
#46681
Prezados, boa tarde,
Realizei uma macro para enviar a planilha no anexo do email, porém preciso que seja inserido também no corpo do email a tabela em imagem para que possa enviar para as pessoas responsáveis.
Esta tabela tem que estar abaixo mensagem.
Macro
Sub SendWorkSheet()
'Update 20190803
Dim xFile As String
Dim xFormat As Long
Dim Wb As Workbook
Dim Wb2 As Workbook
Dim FilePath As String
Dim FileName As String
Dim OutlookApp As Object
Dim OutlookMail As Object
Dim grafico As ChartObject
Dim objoutlook As Object
On Error Resume Next
Application.ScreenUpdating = False
Set Wb = Application.ActiveWorkbook
ActiveSheet.Copy
Set Wb2 = Application.ActiveWorkbook
Select Case Wb.FileFormat
Case xlOpenXMLWorkbook:
xFile = ".xlsx"
xFormat = xlOpenXMLWorkbook
Case xlOpenXMLWorkbookMacroEnabled:
If Wb2.HasVBProject Then
xFile = ".xlsm"
xFormat = xlOpenXMLWorkbookMacroEnabled
Else
xFile = ".xlsx"
xFormat = xlOpenXMLWorkbook
End If
Case Excel8:
xFile = ".xls"
xFormat = Excel8
Case xlExcel12:
xFile = ".xlsb"
xFormat = xlExcel12
End Select
FilePath = Environ$("temp") & "\"
FileName = Wb.Name & Format(Now, " - dd-mmm-yy")
'Caso necessite de dia e hora. Ex.: FileName = Wb.Name & Format(Now, "dd-mmm-yy h-mm-ss")
Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookMail = OutlookApp.CreateItem(0)
Wb2.SaveAs FilePath & FileName & xFile, FileFormat:=xFormat
With OutlookMail
.To = ""
.CC = ""
.BCC = "xxxx@xxxx.com.br"
.Subject = "Teste"
.Body = "Segue relatório de Volume"
.Attachments.Add Wb2.FullName
.Display
'Enviar o email automaticamente (diretamente) ".Send" // para ler o email e depois enviar ".Display"
End With
Wb2.Close
Kill FilePath & FileName & xFile
Set OutlookMail = Nothing
Set OutlookApp = Nothing
Application.ScreenUpdating = True
End Sub
Poderiam me ajudar nesta situação?
Att
Realizei uma macro para enviar a planilha no anexo do email, porém preciso que seja inserido também no corpo do email a tabela em imagem para que possa enviar para as pessoas responsáveis.
Esta tabela tem que estar abaixo mensagem.
Macro
Sub SendWorkSheet()
'Update 20190803
Dim xFile As String
Dim xFormat As Long
Dim Wb As Workbook
Dim Wb2 As Workbook
Dim FilePath As String
Dim FileName As String
Dim OutlookApp As Object
Dim OutlookMail As Object
Dim grafico As ChartObject
Dim objoutlook As Object
On Error Resume Next
Application.ScreenUpdating = False
Set Wb = Application.ActiveWorkbook
ActiveSheet.Copy
Set Wb2 = Application.ActiveWorkbook
Select Case Wb.FileFormat
Case xlOpenXMLWorkbook:
xFile = ".xlsx"
xFormat = xlOpenXMLWorkbook
Case xlOpenXMLWorkbookMacroEnabled:
If Wb2.HasVBProject Then
xFile = ".xlsm"
xFormat = xlOpenXMLWorkbookMacroEnabled
Else
xFile = ".xlsx"
xFormat = xlOpenXMLWorkbook
End If
Case Excel8:
xFile = ".xls"
xFormat = Excel8
Case xlExcel12:
xFile = ".xlsb"
xFormat = xlExcel12
End Select
FilePath = Environ$("temp") & "\"
FileName = Wb.Name & Format(Now, " - dd-mmm-yy")
'Caso necessite de dia e hora. Ex.: FileName = Wb.Name & Format(Now, "dd-mmm-yy h-mm-ss")
Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookMail = OutlookApp.CreateItem(0)
Wb2.SaveAs FilePath & FileName & xFile, FileFormat:=xFormat
With OutlookMail
.To = ""
.CC = ""
.BCC = "xxxx@xxxx.com.br"
.Subject = "Teste"
.Body = "Segue relatório de Volume"
.Attachments.Add Wb2.FullName
.Display
'Enviar o email automaticamente (diretamente) ".Send" // para ler o email e depois enviar ".Display"
End With
Wb2.Close
Kill FilePath & FileName & xFile
Set OutlookMail = Nothing
Set OutlookApp = Nothing
Application.ScreenUpdating = True
End Sub
Poderiam me ajudar nesta situação?
Att
Você não está autorizado a ver ou baixar esse anexo.