Como copiar y pegar imagen de un rango de celdas al cuerpo del Outlook?
Les paso el siguiente código para ver si me pueden ayudar... Esta macro funcionaba a la perfección hasta que me cambiaron el computador con otras versiones de windows (2010) y office (2016). El problema es que en la carpeta indicada para que me guarde la imagen temporal ahora la guarda en blanco y por ende pega en el cuerpo del correo la imagen en blanco. Le busque la vuelta y no la encuentro. Gracias de antemano.
----------Va el codigo-----------
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 & "height=23 width=813>" & _
"<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
1 Respuesta
[Hola
Esta línea:
"<img src=cid:" & imag & "height=23 width=813>" & _
Cámbiala por esta:
"<img src='cid:'" & .Attachments.Item(1).Filename & "'' height=813 width=75>" & _
Ah, ojo, no necesariamente dará el resultado esperado pero inténtalo.
Abraham Valencia
PD1: Es Windows 10, no 2010
PD2: En versiones recientes ocurre mucho lo que mencionas por lo que algunos ahora recomendamos usar las "Propiedades asociadas" del Outlook a través del objeto Outlook, claro, es un poco más complicado que usar solo lo mostrado
Hola gracias por tu tiempo, pero el error no viene en el pegado de la imagen en el cuerpo del correo, sino que cuando guarda el archivo en la carpeta que le indicas la guarda en blanco..
Creo que la falla debería estar en las siguientes líneas. (Lo raro que funcionaba a la perfección antes de que me cambiaran el computador con versiones más recientes)
-------------------------------Código--------------------------
Set h1 = ActiveSheet
ruta = RUTAGUARDAR
imag = "temporal.jpeg"
arch = ruta & imag
rango = "A1:K53"
h1.Range(rango).CopyPicture
Set h2 = Sheets.Add
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
Ya encontré el error pero no estoy pudiendo encontrar el código compatible.
El problema esta en la línea "h2.Shapes.AddChart", la reemplace por "h2.paste" y me pega la imagen correctamente en la nueva hoja de excel pero el chartobjects no es compatible.
Saben de algún otro código que no sea el Shapes. ¿AddChart?
h1.Range(rango).CopyPicture
Set h2 = Sheets.Add
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
No es un problema del código, sino de los datos/rangos de tu archivo. Colócalo en algún "Drive" y envía el enlace por aquí. Si deseas borra la información que no desees compartir pero NO elimines filas/columnas u hojas porque lo importante es ver la actual disposición de tus datos porque probablemente el rango que intentas convertir en imagen pues, esté vacío.
Abraham Valencia
Abraham no es problema, te detallo el link.
Confírmame el acceso por favor.
https://drive.google.com/file/d/1ps-BUZpsCKsqdc1rNvFOmOeqKUoP-alv/view?usp=sharing
[Hola
Pues el dilema es el orden de unas líneas. Mira estas dos líneas y déjalas en este orden:
H2. Shapes. AddChart H1. Range(rango). CopyPicture
Tú las tienes al contrario y al copiar los datos primero y después insertar una hoja, la bandeja del cortapapeles queda vacía y por eso la imagen está blanco, ya que no pega nada.
Saludos]
Abraham Valencia
