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
