Copiar y pegar imagen en cuerpo de Outlook.
Dejo mi siguiente consulta para quien me pueda dar una mano con el siguiente código.
En realidad funcionaba a la perfección hasta que me cambiaron el computador a versiones de office más recientes.
Les copio y pego el código completo y luego les cito donde esta el problema.
-----------------------Código-------------------
Sub ReporteNPS()
Dim objOutlook As Object
Dim objMail As Object
Dim objOutlookAttach As Object
Dim diaActual As Date
Dim rango As String
Dim ASC As Integer
RUTANPS = Worksheets("MACRO").Range("B11").Value
ARCHIVONPS = Worksheets("MACRO").Range("B14").Value
NPS = Worksheets("MACRO").Range("B11").Value & Worksheets("MACRO").Range("B14").Value
RUTAGUARDAR = Worksheets("MACRO").Range("B17").Value
LIBRO = 1
RUTAGUARDAR1 = Worksheets("MACRO").Range("B20").Value
diaActual = Now
CANTIDADDEFILASASC = WorksheetFunction.CountA(Sheets("ASCs").Range("A:A"))
CONTADOR = 2
Do While CONTADOR < CANTIDADDEFILASASC
Worksheets("Report").Select
Worksheets("Report").Range("C3") = Worksheets("ASCs").Range("C" & CONTADOR).Value
Calculate
If Worksheets("Report").Range("G6").Value = 0 Then
CONTADOR = CONTADOR + 1
Else
ASCNAME = Worksheets("ASCs").Range("C" & CONTADOR).Value
ActiveSheet.Calculate
'EN LA HOJA Base_NPS FILTRA POR ASC
Worksheets("Base_NPS").Select
Worksheets("Base_NPS").Range("A:Z").AutoFilter Field:=1, Criteria1:=ASCNAME
'SELECCIONA TODO LOS DATOS
Range("A1").Select
Selection.End(xlUp).Select
Selection.End(xlUp).Select
Selection.End(xlToLeft).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
'COPIA
Selection.Copy
'CREA SOLAPA NUEVA CON NOMBRE DEL DEALER Y PEGA LOS DATOS COPIADOS
Worksheets.Add.Name = ASCNAME
ActiveSheet.Paste
Cells.Select
Cells.EntireColumn.AutoFit
Sheets(ASCNAME).Move
'SELECCIONA LIBRO CREADO, GUARDA Y CIERRA
Windows("Libro" & LIBRO).Activate
Application.DisplayAlerts = False
ChDir RUTAGUARDAR1
ActiveWorkbook.SaveAs Filename:=RUTAGUARDAR & ASCNAME & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWindow.Close
strReportName = RUTAGUARDAR & ASCNAME & ".xlsx"
Worksheets("Report").Select
Set h1 = ActiveSheet
Set h2 = Sheets.Add
ruta = RUTAGUARDAR
imag = "temporal.jpg"
arch = ruta & imag
rango = "A1:K53"
h1.Range(rango).CopyPicture
h2.Shapes.AddChart
With h2.ChartObjects(1)
.Width = h1.Range(rango).Width
.Height = h1.Range(rango).Height
.Chart.Paste
.Chart.Export arch
.Delete
End With
h2.Delete
'CREA EMAIL
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(olMailItem)
'Para
objMail.To = Worksheets("ASCs").Range("E" & CONTADOR).Value
'Copia
objMail.CC = Worksheets("ASCs").Range("F2").Value
'CopiaOculta
'objMail.BCC = Worksheets("ASCs").Range("").Value
'Asunto
objMail.Subject = ASCNAME & "- Reporte NPS " & Format(diaActual, "MMMM/YY")
'ADJUNTO
objMail.Attachments.Add arch
objMail.Attachments.Add strReportName
'Cuerpo
objMail.HtmlBody = "Buenas tardes,<br><br> Compartimos el resultado de NPS desde el dia 1 hasta el " & Format(diaActual, "DD/MMMM") & _
"<HTML> " & _
"<BODY>" & _
"<img src=cid:" & imag & ">" & _
"<P>" & _
"</P>" & _
"</BODY><br><br> " & _
"Saludos.-" & _
"</HTML>"
'MOSTRAR
objMail.Display
DoEvents
'CERRAR OBJETOS DE MAIL
Set objMail = Nothing
Set objOutlook = Nothing
'Exit Sub
CONTADOR = CONTADOR + 1
LIBRO = LIBRO + 1
End If
'DESFILTRA COLUMNA ASC
Worksheets("Base_NPS").Select
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
Loop
End Sub
-----------------------------Aquí donde le encontré el problema----------------------
h1.Range(rango).CopyPicture
h2.Shapes.AddChart
With h2.ChartObjects(1)
.Width = h1.Range(rango).Width
.Height = h1.Range(rango).Height
.Chart.Paste
.Chart.Export arch
.Delete
End With
h2.Delete
--------------------------------------------------------------------------------
En esta parte es donde genera una nueva hoja y pega un objeto y luego al objeto le pega la imagen copiada, pero la pega en blanco y por ende luego la pega en blanco también al cuerpo del mail.
El código ".Chart.Paste" ya no me funciona más... La pega en blanco.
