Guru do Excel e Power BI

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:O15").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
    'fjpeg = ThisWorkbook.Path & _
          "\Teste.jpeg"
          
    'localização e nome do ficheiro de imagem
    fjpeg = Environ("temp") & "\Teste.jpeg"
          
    'exportar grafico
    tmpChart.Export Filename:=fjpeg, FilterName:="jpeg"
    
    '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 " & fjpeg, _
   '        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

Function GetBoiler(ByVal sFile As String) As String
    
    Dim fso As Object
    Dim ts As Object
   
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
        GetBoiler = ts.readall
        ts.Close
        
End Function

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)
   
    On Error Resume Next
    With OutMail
       'Envindo para os enderecos abaixos
        .To = ""
              
       'Enviando com Copia para o enderecos abaixos
        .CC = ""
        
       'Enviando com Copia Oculta para o enderecos abaixos
        .BCC = ""
        
       'Titulo do Email
        .Subject = Relatorio
        
       'Corpo do Email
        .HTMLBody = strbody & "<BR><BR>" & _
        "<img src='" & Environ("temp") & "\Teste.jpeg'>" & _
        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.jpeg")

End Sub