[VBA] Envio de gráfico por email + corpo do email

[victorrgds]

Fala galera, beleza?

 

Então, eu possuo um código VBA que envia email de acordo com a data.

 

Nessa pasta que contém o código, são gerados indicadores que posteriormente são enviados por email (copy paste no outlook e adequação do corpo do email).

 

Eu gostaria de saber como eu posso automatizar o envio desse email...beleza, alterar o corpo do email no código vba eu sei e tal, mas eu gostaria que o gráfico também fosse no corpo do email concatenando algumas informações contidas na planilha...

 

Alguma dica?

 

Abs,

 

Código que utilizo só para envio do email:

Private Sub Workbook_Open()        Const tempo As Integer = 5 'a caixa de mensagem será exibida durante 5 seg    Dim rsp As Integer    Dim SimOuNao As String    Dim QuestionToMessageBox As String    Dim OutApp As Object    Dim OutMail As Object    Dim texto As String    Dim frsData As String, rngData As Range, k As Long, addK As Boolean    Dim linha As Long, msg As Long    Set OutApp = CreateObject("Outlook.Application")k = 9Do  Set rngData = Sheets("Projetos").Columns(k).Find(Date, LookIn:=xlValues)    If Not rngData Is Nothing Then      frsData = rngData.Address      linha = rngData.Row      Do        If rngData.Interior.ColorIndex <> 50 Then             texto = "Prezado(a) " & Sheets("Projetos").Cells(linha, 4) & "," & vbCrLf & vbCrLf & _                    "A fase de " & Sheets("Projetos").Cells(linha, 7) & " do projeto " & _                    Sheets("Projetos").Cells(linha, 2) & " foi concluida. " & vbCrLf & vbCrLf & _                    "Qualidade e Metodologia"                    Set OutMail = OutApp.CreateItem(0)          With OutMail            .To = Sheets("Projetos").Cells(linha, 1).Value            .CC = ""            .BCC = ""            .Subject = "Informe de Projeto"            .Body = texto            .Send  'Utilize Send para enviar o email sem abrir o Outlook          End With            msg = msg + 1            rngData.Interior.ColorIndex = 50         End If            Set rngData = Sheets("Projetos").Columns(k).FindNext(rngData)            linha = rngData.Row           Loop While Not rngData Is Nothing And rngData.Address <> frsData   End If'If addK Then k = k + 2 Else: k = k + 3'addK = True    k = k + 2Loop While k < 31'MsgBox "enviadas " & msg & " mensagens"rsp = CreateObject("WScript.Shell").PopUp( _      "enviadas " & msg & " mensagens" & vbLf & vbLf & _      "Deseja inserir dados no Controle de mapas?", tempo, _        "R E S P O N D A", 4 + 32)If rsp = 6 Then 'se a resposta for "Sim"  MsgBox "Planilha Liberada": Exit SubElse: ActiveWorkbook.Save: ThisWorkbook.Close: Application.Quit 'se a resposta for "Não" ou se não houver respostaEnd If'QuestionToMessageBox = "Deseja inserir dados no Controle de mapas?" 'SimOuNao = MsgBox(QuestionToMessageBox, vbYesNo, "Inserir Dados?")        'If SimOuNao = vbNo Then         'MsgBox "Planilha salva e Finalizada"         'ActiveWorkbook.Save         'Application.Quit        'Else            'MsgBox "Planilha Liberada"    'End IfEnd Sub

[victorrgds]

Dicas? Sugestões? rs

 

Abs,

[victorrgds]

Alguem galera?

 

Pesquisei no google tb, mas nada que atenda minha necessidade foi encontrado...

 

abs,

[victorrgds]

Resolvi, tai o código caso alguem precise:

Sub Send_Range()      Dim texto As String   Dim titulo As String   Dim remetente As String      ' Select the range of cells on the active worksheet.   Worksheets("Plan1").ChartObjects(1).Chart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture         ActiveWorkbook.EnvelopeVisible = True      If Sheets("Capa").Cells(15, 4).Value = "Transacional" Then    remetente = Sheets("Guia de Uso").Cells(27, 5)            Else: remetente = Sheets("Guia de Uso").Cells(28, 5)   End If      titulo = "Report CUP Solicitação  " & "[" & Sheets("Capa").Cells(14, 4) & "]"      texto = "Prezados, " & vbCrLf & vbCrLf & _           "Realizamos o controle de uso de processo para a demanda - " & Sheets("Capa").Cells(14, 4) & _           "e informamos abaixo os resultados coletados:"           With ActiveSheet.MailEnvelope            .Introduction = texto            .Item.To = remetente            .Item.Subject = titulo            .Item.Send        End With        End Sub

Abs,