Excel VBA: envíe un correo electrónico e incluya una variedad de datos utilizando el desplazamiento
De: Nuevo simplón que copia varios fragmentos de código encontrados en Google
Tengo una lista de productos en una hoja de trabajo que están resaltados en diferentes colores para mostrar grupos de productos; cada color resaltado tiene un número correspondiente asignado (por lo tanto, gris = 15, amarillo = 19, etc.)
Estoy intentando incluir el rango de celdas 1, 2 y 3 a la derecha del código de color en el texto del cuerpo del correo electrónico. No me preocupa conservar los bordes o el color una vez que está en el correo electrónico, ya que estoy aún menos seguro de las cosas HTML.
Dejé algunos fantasmas (léase: código redundante) en el código que copié y eliminé de varios lugares para poder ver e identificar qué era lo que estaba intentando lograr cada vez que vuelvo a él y lo modifico según sea necesario, por ejemplo, incluyendo hoja de trabajo, etc.
Probé en varios lugares e intenté combinar varios códigos, pero pensé que probablemente era hora de aguantar y preguntar si lo que estoy tratando de lograr es factible.
Hay varias secciones de código encima de esta sección que hacen cosas como guardar como pdf, enviar correo electrónico, etc.
'===========================
'EMAIL PLACE MATERIAL ORDER'
'===========================
'shamelessly stolen from https://www.exceldemy.com/macro-to-send-email-from-excel/
Dim Cell As Range '¦
Dim ws As Worksheet '¦
Set eApp = New Outlook.Application '¦ <- no touchy
Set eItem = eApp.CreateItem(olMailItem) '¦
eItem.To = "[email protected]" '<- email address of recipient
'These items are optional
'eItem.CC = "[email protected]"
'etem.BCC = "[email protected]"
'Email subject, currently as cell info
eItem.Subject = Range("D21").Value
'Email body text
eItem.Body = "Automated Email - advise sender of errors." _
& vbNewLine & vbNewLine & _
"Please order the following:" _
& vbNewLine & vbNewLine & _
vbNewLine & vbNewLine & _
"ws.cells(1, 2).value on the ws.cells(73, 13).value" & vbNewLine & vbNewLine & _
ws.Range("h73:i100") 'i know this last line is total twaddle
'If you want to attach this workbook, then uncomment these two lines from below
'Source = This`your text`Workbook.FullName
'eItem.Attachments.Add Source
eItem.Display 'can use .Send
'Range("B2").Interior.ColorIndex
'=SUMIF(Table4[Column1],15,F24:F29)
Bodyes una propiedad de texto sin formato que no ofrece ningún formato.
eItem.Body = "Automated Email - advise sender of errors." _
En su lugar, sugeriría utilizar el modelo de objetos de Word para copiar y pegar los datos de Excel directamente en el cuerpo del mensaje. Consulte el Capítulo 17: Trabajar con cuerpos de elementos para obtener más información.
También puedes considerar usar la HTMLBodypropiedad en su lugar. Por ejemplo, puede encontrar la siguiente función que crea una cadena HTML basada en el rango de Excel pasado como parámetro:
Function RangetoHTML(rng As Range)
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
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, , 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 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
