Palabras clave:
Excel, rango, copia, outlook, correoAutor:
Ron De BruinExtraído de:
Ron De BruinLa necesidad surge de pegar el contenido de un rango de un fichero Excel abierto como parte del cuerpo de un correo electrónico.
Después de muchas vueltas y pruebas este código de Ron De Bruin soluciona el problema
Requiere una copia previa del rango o pasarle la dirección para que lo haga la función.
Function rngHTML(Rng As Object) ' Range
Dim fso As Object
Dim ts As Object
Dim TempWB As Object ' Workbook
Dim TempFile As String
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'' copy the range and create a new workbook to paste the data into
'Rng.Copy
Set TempWB = xlsApp.Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
.Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
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 rngHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
rngHTML = ts.readall
ts.Close
rngHTML = Replace(rngHTML, "align=center x:publishsource=", "align=left x:publishsource=")
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