Boa noite!
Kledison,
Fiz uma adaptação, mas como sou leigo no assunto quando executo a macro ela aparece no corpo do e-mail, porém não envia o anexo. Segue macro:
Private Sub Gera_Imagem()
Dim tmpSheet As Worksheet
Dim tmpChart As Chart
Dim tmpImg As Object
Dim fjpeg As String
Dim margem As Integer
On Error GoTo erro
'Caso seja uma area fixa a copiar
Range("A1:L36").CopyPicture _
Appearance:=xlScreen, _
Format:=xlBitmap
'Usar a selecção activa
'Selection.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
'impede que se veja a acção acelerando o procedimento de cópia e exportação
Application.ScreenUpdating = False
'uma folha para colocarmos o grafico sem atrapalhar o resto
Set tmpSheet = Worksheets.Add
'colocar um grafico nesta nova folha
Charts.Add
'definições essenciais ao grafico, para que fique numa worksheet
'e não numa folha grafico
ActiveChart.Location Where:=xlLocationAsObject, Name:=tmpSheet.Name
'Colar a zona copiada para dentro da area do grafico
Set tmpChart = ActiveChart
With tmpChart
.Paste
Set tmpImg = Selection
With .ChartArea
'--------->
'(não essencial ao funcionamento da rotina)
'coloca um degrade no fundo do grafico
' .Fill.OneColorGradient _
' Style:=msoGradientHorizontal, _
' Variant:=1, _
' Degree:=0.231372549019608
'<----------
'sem linha de rebordo
.Border.LineStyle = xlNone
End With
'configurar a area do grafico acrescentando
'uma pequena borda ao redor da imagem centrando esta
margem = 1
With .Parent
.Height = tmpImg.Height + margem
.Width = tmpImg.Width + margem
End With
End With
'localização e nome do ficheiro de imagem
'png = ThisWorkbook.Path & _
"\Teste.png"
'localização e nome do ficheiro de imagem
fjpeg = Environ("temp") & "\Teste.png"
'exportar grafico
tmpChart.Export Filename:=fjpeg, FilterName:="png"
'eliminar a folha temporaria sem avisos
Application.DisplayAlerts = False
tmpSheet.Delete
Application.DisplayAlerts = True
'repor o estado normal
Application.ScreenUpdating = True
'aviso de operação terminada
' MsgBox "Seu Arquivo encontra-se em " & png, _
' vbInformation, _
' ".:: Exportação"
GoTo fim
erro:
MsgBox "Erro: " & Err.Description, _
vbCritical, _
"Erro: " & Err.Number
fim:
Set tmpSheet = Nothing
Set tmpChart = Nothing
Set tmpImg = Nothing
End Sub
Private Sub Email_Imagem()
'Não se esqueça de copiar o GetBoiler função no módulo.
'Trabalhar no Office 2000-2010
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim SigString As String
Dim Signature As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Dim Manha As String
Dim Tarde As String
Dim Noite As String
Dim Texto As String
Dim Relatorio As String
'Variável Armazena o Caminho
'Dim Diretorio1 As String
'Variável Armazena o Nome do Arquivo
'Dim NomeArquivo1 As String
'Variável com o Nome do Arquivo
'NomeArquivo1 = "Parcial"
'Variável com o Caminho completo do arquivo
'Diretorio1 = Caminho & "\" & Ano & "\" & MesNum & " - " & MesInt & "\" & NomeArquivo1 & "\" & NomeArquivo1 & "(" & Format(Now, "dd") & ").xlsx"
Relatório = "Situação_parcial"
Manhã = "Bom dia, Srs."
Tarde = "Boa tarde, Srs."
Noite = "Boa noite, Srs."
If TimeValue(Now) < TimeValue("12:00:00") Then
Texto = Manhã
ElseIf TimeValue(Now) > TimeValue("12:00:00") And TimeValue(Now) < TimeValue("18:00:00") Then
Texto = Tarde
ElseIf TimeValue(Now) > TimeValue("18:00:00") Then
Texto = Noite
End If
strbody = "<h4>" & Texto & "</h4>" & _
Relatório
'Caminho Assinatura C:\Users\EudesM\AppData\Roaming\Microsoft\Assinaturas
'Alterar apenas NomeAssinatura.htm para o nome da sua assinatura
If UsuarioRede = "EudesM" Then
SigString = Environ("appdata") & _
"\Microsoft\Assinaturas\EudesM.htm"
End If
If Dir(SigString) <> "" Then
Signature = SigString
Else
Signature = ""
End If
On Error Resume Next
With OutMail
'Enviando para os endereços abaixos
.To = "
email@gmail.com"
'Enviando com Cópia para o enderecos abaixos
.CC = ""
'Enviando com Cópia Oculta para o endereços abaixos
.BCC = ""
'Titulo do Email
.Subject = Relatório
'Corpo do Email
.HTMLBody = strbody & "<BR><BR>" & _
"<img src='" & Environ("temp") & "\Teste.png'>" & _
Signature
'Anexar aquivos
'.Attachments.Add (Diretorio1)
.Display 'Exibição do Display
'.Send 'Envio sem Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Sub Email_Com_Imagem()
Call Gera_Imagem
Call Email_Imagem
Kill (Environ("temp") & "\Teste.png")
End Sub
