none
Dúvida - VBA para gerar e-mail RRS feed

  • Pergunta

  • Boa noite,

    Tenho um código que gera um e-mail a partir de um arquivo do excel. Ele basicamente executa duas funções:

    1) Criar um arquivo de PDF a ser anexado no e-mail

    2) Gerar um e-mail copiando uma seleção do excel para o corpo do e-mail.

    Contudo essa seleção do excel acaba copiando apenas o texto, e não as imagens ali presentes (um gráfico e um cabeçalho). Vocês poderiam me ajudar a analisar o código e verificar o que deve ser alterado para que na cópia do texto as imagens também apareçam?

    Muito obrigada,

    Sub Create_Email()
    Dim sheet_name As String
    Dim range_value As String

    'Cria ppt
    i = 0
    Dim opptapp As Object
    ' Reference existing instance of PowerPoint
    Set PPApp = CreateObject("Powerpoint.Application")
    PPApp.Visible = True
    ' Reference active presentation
    Set PPPres = PPApp.Presentations.Add

    'insere produto
    ThisWorkbook.Activate
    sheet_name = ActiveSheet.Name
    product_sheet = sheet_name
    range_value = Application.WorksheetFunction.VLookup(sheet_name, Worksheets("aux").Range("C3:D30"), 2, 0)
    Sliderange sheet_name, range_value

    'insere termos
    ThisWorkbook.Activate
    Worksheets("Def.").Activate
    sheet_name = ActiveSheet.Name
    range_value = Application.WorksheetFunction.VLookup(sheet_name, Worksheets("aux").Range("C3:D30"), 2, 0)
    Sliderange sheet_name, range_value

    'insere disclaimer
    ThisWorkbook.Activate
    Worksheets("Disclaimer").Activate
    sheet_name = ActiveSheet.Name
    range_value = Application.WorksheetFunction.VLookup(sheet_name, Worksheets("aux").Range("C3:D30"), 2, 0)
    Sliderange sheet_name, range_value

    'Salva pdf
    PPPres.Slides(1).Delete
    PPPres.Slides(1).Select
    PPPres.SaveAs "c:\temp\COE.pdf", ppSaveAsPDF
    Application.DisplayAlerts = False
    PPApp.ActiveWindow.WindowState = ppWindowMinimized
    PPPres.Close
    PPApp.Quit
    Set PPPres = Nothing
    Set PPApp = Nothing

    'Corta corpo do email
    ThisWorkbook.Activate
    Worksheets(product_sheet).Activate
    fi = 10
    For fi = 1 To 29
        If Cells(fi, 2) = "" Then Exit For
    Next fi
    For li = fi To 28
        If Cells(li, 2) = "Os valores constantes dos cenários e cotação indicativa são meramente informativos e não devem ser considerados como expectativa de retorno" Then Exit For
    Next li

       'Gera Corpo de texto HTML
        Dim MyBody, MyBody1
        Dim Wk, Wk1, Sh, Sh1
        Dim ws As Worksheet
        Dim cht As Object
        Dim strPath As String
       
        Worksheets("M-CDCP-S").Activate
        Application.DisplayAlerts = False
        Range("A1").Select
        Wk = ActiveWorkbook.Name
        Sh = ActiveSheet.Name
        strPath = "C:\Temp\"
       
        Workbooks.Add
        Wk1 = ActiveWorkbook.Name
        ActiveSheet.Name = "HTML_Body"
        Sh1 = ActiveSheet.Name
       
        ActiveWindow.DisplayGridlines = False
        For Each Sh1 In Workbooks(Wk1).Sheets
            If UCase(Left$(Sh1.Name, 5)) = "SHEET" Then
                Application.DisplayAlerts = False
                Sh1.Delete
                Application.DisplayAlerts = True
            End If
        Next
        Sh1 = ActiveSheet.Name
       
        Workbooks(Wk).Activate
        Sheets(Sh).Activate
        'Intervalo s ser colado no corpo do email
        Range(Cells(fi, 2), Cells(li, 12)).Copy

        Workbooks(Wk1).Activate
        Sheets(Sh1).Activate
        Range("A2").Select
        Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
            False, Transpose:=False
        Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _
            False, Transpose:=False
        Application.CutCopyMode = False

        If Application.Version = "11.0" Then
            ' Make HTML Body 2003
                ActiveWorkbook.HTMLProject.HTMLProjectItems.Item(1).SaveCopyAs "temp.txt"
                Close #40
                Open strPath & "temp.txt" For Input As #40
        Else
            ' Make HTML Body Excel 2007
                With ActiveWorkbook.PublishObjects.Add(xlSourceSheet, strPath & "temp.htm", _
                    "HTML_Body", "", xlHtmlStatic, "cotacao", "")
                    .Publish (True)
                    .AutoRepublish = False
                End With
                Close #40
                Open strPath & "temp.htm" For Input As #40
        End If
       
        Do While Not EOF(40)
           Line Input #40, MyBody1
           MyBody = MyBody & MyBody1 & Chr(13)
        Loop
        Close #40

        Workbooks(Wk1).Close SaveChanges:=False

        'Gera imagem para exportação em jpg
        Set ws = ActiveSheet
        Set cht = Charts
       
        Range(Cells(fi, 2), Cells(li, 12)).CopyPicture Appearance:=xlScreen, Format:=xlPicture
        ActiveSheet.Paste
        Selection.Name = "temp_pic"
        'ActiveSheet.Shapes.Range(Array("temp_pic")).Select
        'ActiveSheet.Shapes("temp_pic").Export Filename:="C:\temp\temp.jpg", FilterName:="jpeg"
           
         'Insere nova área
         With ws.Shapes("temp_pic")
             .Copy
             Set cht = ws.ChartObjects.Add(0, 0, .Width, .Height)
         End With
       
        'Cola imagem na nova área para exportação
         With cht
              .Chart.Paste
              .Chart.Export Filename:=strPath & "temp.jpg", FilterName:="jpg"
              .Delete
         End With
        
         ws.Shapes("temp_pic").Delete
        
         Application.DisplayAlerts = True
         Range("A1").Select

    'Gera email
    Dim appOutlook As Object
    Dim olMail As Object

        On Error Resume Next
        Set appOutlook = GetObject(, "Outlook.Application")
       
        If appOutlook Is Nothing Then
           Set appOutlook = CreateObject("Outlook.Application")
        End If
       
        On Error GoTo 0
        Set olMail = appOutlook.CreateItem(0)
        'A imagem não será visualizada no display do email, somente após o envio.
        'olMail.HTMLBody = "<align=left>" & MyBody & "</>"               'Somente corpo email
        olMail.HTMLBody = "<IMG src='C:\temp\temp.jpg'>"               'Somente Imagem
        'olMail.HTMLBody = MyBody & "<IMG src='C:\temp\temp.jpg'>"      'Corpo e imagem
       
        strPath = "C:\Temp\"
        olMail.attachments.Add strPath & "COE.pdf"
        olMail.Display
       
        'Application.SendKeys "{tab}{tab}{tab}{tab}^v", True
        'Kill "C:\temp\COE.pdf"
        'Kill "C:\temp\temp.jpg"
        Application.ScreenUpdating = True
       
    End Sub

    terça-feira, 19 de agosto de 2014 23:03