CODEWITHSUNDEEP
excelvba
middleschoolteacher
middleschoolteacher

Reputation: 45

Passing a Non-Contiguous Range from a Union into Outlook

A group of teachers (I am one) is using a spreadsheet to track missing assignments of students. The students' names are in column A, and missing assignments expand in columns to the right.

When an assignment is missing, the teacher puts their initial in the cell and right-clicks to add a comment about the assignment.
When the student submits the assignment, the teacher changes the cell's fill from nothing (xlNone) to yellow or grey.

We'd like Excel to send us a daily email that lists only the students with missing assignments in cells filled with xlNone along with the initial of the teacher or teachers.

This code does not error. The email object is constructed, but there is no data in the body of the email.

Sub Mail_Selection_Range_Outlook_Body()
'Thanks to code by Tim Williams and Ron de Bruin

    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
    On Error Resume Next
    Dim cell As Range
    Dim ci As Long
    Set rng = Nothing
    
    For Each cell In Sheet1.Range("C4:Z100").Cells
        ci = cell.Interior.ColorIndex
        If (ci = -4142 Or ci = 2 Or ci = 15 Or ci = 16) And Not IsNumeric(cell.Value) Then
            If rng Is Nothing Then
                Set rng = cell
            Else
                Set rng = Application.Union(rng, cell)
            End If
        End If
    Next cell
    
    If Not rng Is Nothing Then rng.Select
        
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next
    With OutMail
        .To = "[email protected], [email protected]"
        .CC = ""
        .BCC = ""
        .Subject = "This is the list of students with missing work"
        .HTMLBody = RangetoHTML(rng)
        .Send
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub


Function RangetoHTML(rng As Range)
' Thanks to Ron de Bruin's page
    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 paste 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

I commented On Error Resume Next out as suggested and get an error

'Type Mismatch'

Looking at the sheet, the various cells are highlighted.

Upvotes: 0

Views: 151

Answers (1)

David
David

Reputation: 48

Hello middleschoolteacher,

UPDATED ANSWER

Sub Mail_Selection_Range_Outlook_Body()
'Thanks to code by Tim Williams and Ron de Bruin

'    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
'    On Error Resume Next
    Dim cell As Range
    Dim ci As Long
'    Set rng = Nothing
    Dim str As String
    str = Empty
    
    For Each cell In Sheet1.Range("C4:Z100").Cells
        ci = cell.Interior.ColorIndex
        If (ci = -4142 Or ci = 2 Or ci = 15 Or ci = 16) And Not IsNumeric(cell.value) Then
        '****************************************************************************
'            If rng Is Nothing Then
'                Set rng = cell
'            Else
'                Set rng = Application.Union(rng, cell)
'            End If
            str = str & CStr(cell.value) & " "
        '****************************************************************************
        End If
    Next cell
    
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
'    On Error Resume Next
    With OutMail
        .To = "[email protected], [email protected]"
        .CC = ""
        .BCC = ""
        .Subject = "This is the list of students with missing work"
        
        '****************************************************************************
        Dim wdDoc As Object
        Dim olinsp As Object
        
        Set wdDoc = CreateObject("Word.Document")
        Set olinsp = .GetInspector
        Set wdDoc = olinsp.WordEditor
        
        If Not IsEmpty(str) Then
            wdDoc.Range.InsertBefore str
            .Display
            .Send
        Else
            MsgBox prompt:="No cells meet the criteria"
            Exit Sub
        End If
        '****************************************************************************
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing
    
    Set wdDoc = Nothing
    Set olinsp = Nothing
    
End Sub

So, I'm not sure this gives you the intended result, however after testing with a test worksheet I successfully displayed the email with all the relevant cell values separated by a space (you can choose whatever you want to separate the values, you just need to replace the " " on the line containing str = str & CStr(cell.value) & " " .

I changed where the .Send method is on the code so that no email is sent if there are no relevant cells.

I fail to understand how are you going to know which student hasn't yet submitted the assignment as the relevant cells contain only the initial of the teacher? Or am I getting this wrong?

If you need to include the student's name also for each cell value then the code can be easily modified to do that, however I'm not sure that I fully understand what is the desired output is here.

Anyways let me know how it goes.

ADDITION

You can output a single line like this: studentA_J studentB_F studentC_W , J F and W being the initials of the teachers. In order to achieve that you need only the the line containing str = str & CStr(cell.value) & " " and change it to str = str & Sheet1.Cells(cell.row,j) & "_" & CStr(cell.value) & " " , where j needs to be the index of the column where the student's name is.

If I remember correctly you can even write it using the letter of the column, for example if the students names are in column A then you can also replace the above line of code also by str = str & Sheet1.Cells(cell.row,"A") & "_" & CStr(cell.value) & " "

UPGRADED CODE

Sub Mail_Selection_Range_Outlook_Body()
'Thanks to code by Tim Williams and Ron de Bruin

    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range, studentCell As Range
    Dim ci As Long
    Dim str As String
    str = Empty
    
    With Application
        .calculation = xlCalculationManual
        .DisplayStatusBar = False
        .enableEvents = False
        .screenUpdating = False
        .Interactive = False
        .DisplayAlerts = False
        .AskToUpdateLinks = False
    End With
    
    For Each cell In Sheet1.Range("C4:Z100").Cells
        ci = cell.Interior.ColorIndex
        If (ci = -4142 Or ci = 2 Or ci = 15 Or ci = 16) And Not IsNumeric(cell.value) Then
        '****************************************************************************
            Set studentCell = Sheet1.Cells(cell.Row, "A")
            
            With cell
                If Not .CommentThreaded Is Nothing Then
                    str = str & studentCell.value & "_" & CStr(.value) & "_" & .CommentThreaded.Text & vbCrLf
                Else
                    str = str & studentCell.value & "_" & CStr(.value) & vbCrLf
                End If
            End With
        '****************************************************************************
        End If
    Next cell
    
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
    With OutMail
        .To = "[email protected], [email protected]"
        .CC = ""
        .BCC = ""
        .Subject = "This is the list of students with missing work"
        
        '****************************************************************************
        Dim wdDoc As Object
        Dim olinsp As Object
        
        Set wdDoc = CreateObject("Word.Document")
        Set olinsp = .GetInspector
        Set wdDoc = olinsp.WordEditor
        
        If Not IsEmpty(str) Then
            wdDoc.Range.InsertBefore str
        Else
            MsgBox prompt:="No cells meet the criteria"
            GoTo SafeExit
        End If
        '****************************************************************************
        .Display
        .Send
    End With
    
SafeExit:
    With Application
        .calculation = xlCalculationAutomatic
        .DisplayStatusBar = False
        .enableEvents = False
        .screenUpdating = False
        .Interactive = False
        .DisplayAlerts = False
        .AskToUpdateLinks = False
    End With
    Set OutMail = Nothing
    Set OutApp = Nothing
    
    Set wdDoc = Nothing
    Set olinsp = Nothing
    
End Sub

If you use this upgraded code then it will run much faster.

Upvotes: 0

Related Questions