Pulling Data from an excel sheet into a Word document or Email

[DentonHTHS]

HI everyone,

I teach online courses and we are required to provide progress reports every few weeks. I have managed to pull the data from the online course into excel and develop basically a two column area in excel that would have the names of assignments in Column A and the Students names and then their corresponding marks in Columns B onward. I would like to be able to pull that first column and the specific student column into an email or word document that could be mailed to the student and parents. I would like to automate this process as much as possible. Right now, I have a form email I use but I need to cut an image of the two columns for each student and paste it into a copy of the email and repeat for each student.

 

[Candyman8019]

The function you're looking for is called 'RangeToHTML'. Here's the one I use. In your script that generates the email, have it call the RangetoHTML script (and pass a range into the function) from the .htmlbody property.

Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Changed by Joe Rieger 2022
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
    Dim HdrRng As Range
    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    Set HdrRng = Sheet11.Range("A11:M11")
    'Copy the range and create a new workbook to past the data in
Application.ScreenUpdating = False
    
    'copies header row (HdrRng) from sheet to email
    HdrRng.Copy
    Set TempWB = Workbooks.Add(1)
    
        With TempWB.Sheets(1)
            .Cells(1, 1).PasteSpecial Paste:=8
        .Cells(1, 1).PasteSpecial xlPasteValues, , False, False
        .Cells(1, 1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1, 1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
    
    'Copies (rng), passed into this function, into the email
    rng.Copy
            With TempWB.Sheets(1)
            .Cells(2, 1).PasteSpecial Paste:=8
        .Cells(2, 1).PasteSpecial xlPasteValues, , False, False
        .Cells(2, 1).PasteSpecial xlPasteFormats, , False, False
        .Cells(2, 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=")
    RangetoHTML = Replace(RangetoHTML, "table border=0 cellpadding=0 cellspacing=0", _
                     "table border=0 cellpadding=1 cellspacing=1")

    '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
Application.ScreenUpdating = True
End Function

 

[DentonHTHS]

The function you're looking for is called 'RangeToHTML'. Here's the one I use. In your script that generates the email, have it call the RangetoHTML script (and pass a range into the function) from the .htmlbody property.

Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Changed by Joe Rieger 2022
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
    Dim HdrRng As Range
    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    Set HdrRng = Sheet11.Range("A11:M11")
    'Copy the range and create a new workbook to past the data in
Application.ScreenUpdating = False
   
    'copies header row (HdrRng) from sheet to email
    HdrRng.Copy
    Set TempWB = Workbooks.Add(1)
   
        With TempWB.Sheets(1)
            .Cells(1, 1).PasteSpecial Paste:=8
        .Cells(1, 1).PasteSpecial xlPasteValues, , False, False
        .Cells(1, 1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1, 1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
   
    'Copies (rng), passed into this function, into the email
    rng.Copy
            With TempWB.Sheets(1)
            .Cells(2, 1).PasteSpecial Paste:=8
        .Cells(2, 1).PasteSpecial xlPasteValues, , False, False
        .Cells(2, 1).PasteSpecial xlPasteFormats, , False, False
        .Cells(2, 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=")
    RangetoHTML = Replace(RangetoHTML, "table border=0 cellpadding=0 cellspacing=0", _
                     "table border=0 cellpadding=1 cellspacing=1")

    '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
Application.ScreenUpdating = True
End Function

This is wonderful but I am not sure about how to do the script for the email. Could you explain how to do that or point me to a tutorial that would show how to do that? Thank you so much.

 

[Candyman8019]

It goes without saying that you'll need to modify this to fit your need...but this should get you started:

Private Sub SendDefectEmail()
Dim i As Integer, Mail_Object, Email_Subject, o As Variant, signature As String
Dim omail As Object

'Send Email Confirmation
Dim rng As Range
Dim subject As String
Dim FirstRow As Long
Dim lastrow As Long
Dim HeaderRow As Range
Dim FilePath As String
Dim Sig As String
Dim sendto As String


FirstRow = Selection.Cells(1, 1).Row
lastrow = Selection.Cells(Selection.Rows.Count, 1).Row

  subject = Sheet13.Range("NewDefSubject").Value & " " & Sheet11.Range("A" & FirstRow).Value
  sendto = Sheet13.Range("SendToAddr").Value

'Set Header Row and selected range
Set HeaderRow = Sheet11.Range("A11:M11")
Set rng = Sheet11.Range("A" & FirstRow & ":M" & lastrow).SpecialCells(xlCellTypeVisible)


Set Mail_Object = CreateObject("Outlook.Application")
Set omail = Mail_Object.CreateItem(o)

With omail
  .display
End With

signature = omail.htmlbody

With omail
    .subject = "...Please Wait, Building Email..."
    .To = sendto
    .CC = Sheet13.Range("carboncopy").Value
    .htmlbody = Sheet13.Range("BODY1").Value & "<br/><br/>" & _
                Sheet13.Range("BODY2").Value & "<br/>" & _
                RangetoHTML(rng) & _
                signature
    .subject = subject
    '.Send
End With

End Sub

Brief explanation...In order for the email to include my default signature block, I display the email message first, then build the email, then I manually send it by clicking the send button. You can have it automatically send by uncommenting the .send line.

Additionally, I found the function to not be very fast, so I added a subject line that says "...Please Wait, Building Email...", then it updates to the actual subject just before I send the message.

 

[DentonHTHS]

Thank you. I will work with this and see if I can get it to work on my stuff. Much appreciated.