Macro al copiar rango mantenga el formato al pegar cuerpo de correo.
Tengo este código, donde lo que hace es copia un rango del excel y lo pega en el cuerpo del correo.
El drama es que llegue hasta que respete los colores y las formas, pero los tamaños me los modifica osea si una línea la armo a 3 píxeles la copia al también original del excel.
¿Hay forma de que respete tal cual se la creo en el cuadro del excel? ¿Qué no modifique?
Espero su pronta respuesta.
Sub Mail_SEA_FLETEPAMPA()
Dim nombrearchivo As String
Dim rng As Range
Dim Arng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim trBody As String
Dim user1 As String
Dim hora As Double
Dim saludo As String
Set rng = Nothing
Set rng = Sheets("hoja1").Range("B9:E15")
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Set OutkAttach = OutApp.CreateItem(Attachments)
With OutMail
.To = ""
.CC = "i"
.BCC = ""
.Subject = "SEA_Fletes:/" & Sheets("PAMPA").Range("C9") & " " & ("Envio N°") & " " & Sheets("PAMPA").Range("C11") & " " & ("Fecha") & " " & Format(Now, "d-m-yy") & " " & Range("C1").Value
.Attachments.Add (nombrearchivo)
.HTMLBody = saludo & RangetoHTML(rng) & strbody
.Display 'or use .Send
End With
End Sub
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2013
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
Dim strbody As String
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , True, True
.Cells(1).PasteSpecial xlPasteFormats, , True, True
.Cells(1).Select
.DrawingObjects.Delete
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
1 Respuesta
Lo que hace la macro es copiar tu rango de celdas y pegarlo en una hoja de un nuevo libro, después toma ese libro y lo convierte a Html.
Si quieres cambiar el formato de las celdas, las filas, las columnas, etc, deberás hacerlo en esta parte del código:
With TempWB.Sheets(1) .Cells(1).PasteSpecial Paste:=8 .Cells(1).PasteSpecial xlPasteValues, , True, True .Cells(1).PasteSpecial xlPasteFormats, , True, True .Cells(1).Select .DrawingObjects.Delete End With
Hola Dante,
Entiendo a ese cuadro lo pase por este otro, que me recomendás como para que me respete el formato original sin cambios, los más que necesito es que no me cambie los formatos de pixeles.
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2013
Dim fso As Object
Dim ts As Object
Dim TempFile As String, ddo As Long
Dim TempWB As Workbook
Dim strbody As String
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
' Temporary publish the rng range to a htm file
ddo = ActiveWorkbook.DisplayDrawingObjects
ActiveWorkbook.DisplayDrawingObjects = xlHide
With ActiveWorkbook.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=ActiveSheet.Name, _
Source:=Union(rng, rng).Address, _
HtmlType:=xlHtmlStatic)
.Publish True
.Delete
End With
ActiveWorkbook.DisplayDrawingObjects = ddo
With CreateObject("Scripting.FileSystemObject").GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = Replace(.ReadAll, "align=center x:publishsource=", "align=left x:publishsource=")
.Close
End With
'Delete the htm file we used in this function
Kill TempFile
End Function
No entiendo qué hiciste.
Lo que intento explicar es que debes copiar las celdas originales al archivo temporal y adecuar los formatos.
Hola dante, buenos días
De nuevo con este código, le intento cambiar de todas formas, pero no logro dar que me copie tal cual los datos originales. ¿Dónde crees que le estoy errando? Trabaje donde me indicaste.
rng.Copy Set TempWB = Workbooks.Add(1) With TempWB.Sheets(1) .Cells(1).PasteSpecial Paste:=xlPasteAll .Cells(1).PasteSpecial Paste:=xlPasteColumnWidths .Cells(1).PasteSpecial Paste:=xlPasteAllMergingConditionalFormats .Cells(1).PasteSpecial Paste:=xlPasteFormats Application.CutCopyMode = True .DrawingObjects.Delete End With
y el codigo con el que trabajo es el publicado mas arriba, lo que hace es copia datos de un libro y lo adjunta en el cuerpo de correo electrónico, pero me modifica el ancho de las celdas el de las columnas me mantiene igual
Lo que intento explicar es que debes copiar las celdas originales al archivo temporal y adecuar los formatos.
Y si en lugar de copiar los formatos. Aplicas el formato que quieres en cada celda, es decir, si la celda A1 la quieres con fondo amarillo, entonces en el archivo temporal.
With TempWB.Sheets(1)
. Range("A1"). Interior.ColorIndex = 6Prueba con algunas celdas.
Dante, te entiendo y comprendo a lo que me indicas, lo que en este caso necesito es que los alto de las celdas sean algunos mas de lo normal, mira te pego una imagen para que veas.
En el código que tengo, me copia y pega los rangos predeterminados, lo que necesito es alterar esos pixeles, en este ejemplo el px es de 22,5 y el estándar es de 12px.
aguardo...
Entiendo que es algo laborioso, pero esa macro que tienes no está diseñada para eso.
Tendrás que replicar cada uno de los formatos que quieres, celdas, colores, letras, alto filas, ancho de columnas.
Aquí tengo un ejemplo para recorrer cada fila tomar el alto de fila de una hoja y ajustar el alto de fila en otra hoja:
Para dante Amor, Ampliar macro para la generación de boletas en excel
Otra opción es poner el rango en el correo y tal vez anexar el archivo de excel para que se vean todos los formatos.
Gracias dante, mira se soluciono con lo siguiente...
.range("a1").rowheight = 25Aprovecho para consultarte, no se si lo entiendes al código, realiza un correo y usa Function rangeHTML para pegar los datos al correo, ¿existe algo mejor?
No que yo haya visto.
Esa función es la que anda por todas las redes para pegar rangos de celdas.
Otra opción es que guardes el rango de celdas como imagen y después poner la imagen en el cuerpo del correo.
Exportar rango variable desde Excel a JPEG
Aquí un ejemplo para poner una imagen (logo) en el cuerpo del correo.
Para dante Amor, Ampliar macro para la generación de boletas en excel
