Macro para copiar rango de celdas en Outlook no funciona aleatoriamente.-
Hace unos días hice una planilla en excel 2013 con la siguiente macro para copiar un rango de celdas en un correo en outlook 2013 y mostrarlo, para después enviarlo manualmente:
Sub correo()
Range("a1:f20").Copy
Set parte1 = CreateObject("outlook.application")
Set parte2 = parte1.createitem(olmailitem)
parte2.to = "[email protected]"
parte2.Subject = "asunto de mensaje"
parte2.display
Application.SendKeys "^v"
Set parte1 = Nothing
Set parte2 = Nothing
End SubProbe la macro y funciona perfectamente.
El problema es que esta planilla la están usando actualmente 4 usuarios y aleatoriamente se encuentran con el siguiente problema:
Cuando hacen un click en el botón que ejecuta la macro, se abre un nuevo email con los datos de destinatario y asunto, pero queda en segundo plano, y el rango de celdas se pega en la misma planilla, en la celda que estaba activa.
La planilla no tiene otra macro más que esta.
Los usuarios usan terminales con Windows 7, Office 2010 o 2013, y solo el Office abierto.
Reiniciar el Office o Windows no hace diferencia.
En algunos casos, note que luego del error, si entro a la macro solo a verla, cierro el VB e intento nuevamente la ejecución soluciona el problema, pero aleatoriamente se vuelve a repetir.
Demás esta decir que en mi terminal funciona perfecto y no pude replicar el error.
Cualquier ayuda, les voy a quedar eternamente agradecido.
1 Respuesta
H o l a:
Entiendo que el problema está en el pegado de los datos.
Te anexo otras alternativas que no utilizan el pegado de celdas.
Alternativa 1. Lo que hace es crear una imagen de las celdas y entonces inserta la imagen al correo:
Sub EnviarCorreo()
'Por.Dante Amor
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set h1 = ActiveSheet
Set h2 = Sheets.Add
'
ruta = ThisWorkbook.Path & "\"
imag = "temporal.jpeg"
arch = ruta & imag
'
rango = "A1:F20"
'
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
'
Set dam = CreateObject("Outlook.Application").createitem(0)
dam.To = "[email protected]" 'Destinatarios
dam.Subject = "asunto de mensaje" 'Asunto
dam.Attachments.Add arch
dam.HTMLBody = _
"<HTML> " & _
"<BODY>" & _
"<img src=cid:" & imag & ">" & _
"<P>" & _
"</P>" & _
"</BODY> " & _
"</HTML>"
dam.display 'El correo se muestra
Set dam = Nothing
End SubAlternativa 2. Lo que hace es pasar celda por celda en formato HTML al correo:
Sub EnviarCorreoCeldas()
'Por.Dante Amor
Set r = Range("A1:F20")
Set dam = CreateObject("outlook.application").createitem(0)
dam.To = "[email protected]" 'Destinatarios
dam.Subject = "asunto de mensaje" '"Asunto"
'
f = r.Rows.Count
c = r.Columns.Count
tabla = "<table border><tr>"
For i = 1 To r.Rows.Count
For j = 1 To r.Columns.Count
tabla = tabla & "<td>" & r.Cells(i, j) & "</td>"
Next
tabla = tabla & "</tr>"
Next
tabla = tabla & "</table>"
'
dam.HTMLBody = _
"<HTML> " & _
"<BODY>" & _
"<P>" & tabla & "</P>" & _
"</BODY> " & _
"</HTML>"
dam.display 'El correo se muestra
Set dam = Nothing
End SubPrueba las 2 alternativas y revisa cuál es la que te funciona mejor.
':) S a l u d o s . D a n t e A m o r ':) Si es lo que necesitas. Recuerda valorar la respuesta. G r a c i a s.
