How To Embed An Excel Table In To An Outlook Email Body

[peter renton]

Hi
Could anybody help me with the reason why the table is not been shown when the due today text is entered.

At the moment it will send an email with the table if the dates are over due and the text ....days overdue
if There id nothing due no email is sent

But if is set to due today it sends the email but with a small square where the table should be?? on the equipment email you will see what I mean.

Regards

Peter

[bakerman]

Dear Peter,
Please read the following regarding cross-posting.
http://www.excelfox.com/forum/f25/me...1172/#post5326

Link to cross-post
how to make table show in email body on due today code

Regards
bakerman

[peter renton]

sorry Bakerman

I meant to cross reference, I have added links on both sites


Thanks

[Excel Fox]

Hi Peter,

Try this

Private Sub Workbook_Open()

Dim rngbody As Range
Dim c As Variant
Dim ddiff As Long
Dim mdiff As Long
Dim body As String
Dim w As Worksheet
Dim j As Integer
Dim cell As Range
Dim strto As String
    
    




For Each w In Worksheets
    If w.CodeName <> "Sheet2" Then

     strto = ""
    For Each cell In w.Range("A3:k200")
        If cell.Value Like "?*@?*.?*" And LCase(cell.Offset(0, 6).Value) = "yes" Then
            strto = strto & cell.Value & ";"
        End If
    Next cell
    If Len(strto) > 0 Then strto = Left(strto, Len(strto) - 1)
    
    
    
Application.EnableEvents = False
        '///New Code
        Set rngbody = w.Range("A2").Resize(1, 7)
        '///
        ' Set the initial email body.  We will use this to check if we have issues later.
        body = "The Following items are Due or Overdue Inspection" & ": " & Chr(9) & Chr(9) & Chr(9) & vbCrLf & vbCrLf & vbCrLf
        For Each c In w.Range("F4:F" & w.Cells(Rows.Count, 6).End(xlUp).Row)
            ' If each value in the range is a date, then do a check for months and days.
            If IsDate(c.Value) Then
                ddiff = DateDiff("d", Now(), c.Value)
                mdiff = DateDiff("m", Now(), c.Value)
                ' If greater than 1 month away, only populate the cell, do not add to the email
                ' body.  You many want to change this.
                If ddiff > 0 Then
                    c.Offset(0, 1).Value = ddiff & "  Days from now"
                Else
                ' Else, if we have less than one month, use days as the indicator, and
                ' increment the email body.
                    If ddiff > 1 Then
                        c.Offset(0, 1).Value = ddiff & " days from now"
                        body = body & c.Offset(0, -4) & ": " & Chr(9) & c.Offset(0, -3) & Chr(9) & Chr(9) & Chr(9) & ddiff & " Days from now" & vbCrLf
                Else
                    If ddiff = 0 Then
                        c.Offset(0, 1).Value = "due today"
                        body = body & c.Offset(0, -4) & ": " & Chr(9) & c.Offset(0, -5) & ": " & Chr(9) & Chr(9) & c.Offset(0, -3) & ": " & Chr(9) & c.Offset(0, -1) & ": " & Chr(9) & " Due today" & ": " & vbCrLf
                Else
                    c.Offset(0, 1).Value = ddiff * -1 & " days overdue"
                    body = body & c.Offset(0, -4) & ": " & Chr(9) & c.Offset(0, -5) & ": " & Chr(9) & c.Offset(0, -3) & ": " & Chr(9) & c.Offset(0, -1) & ": " & Chr(9) & ddiff * -1 & " Days overdue" & ": " & vbCrLf
                    '///New Code
                    Set rngbody = Union(rngbody, c.Offset(0, -5).Resize(1, 7))
                    '///
                End If
                End If
                End If
            End If
        Next c
        '///New Code
        If rngbody.Rows.Count > 1 Or rngbody.Areas.Count > 1 Then
        rngbody.Copy Sheet2.Range("A1")
        '///
        sn = Sheet2.Range("A1").CurrentRegion
        c01 = "<table border=1 bgcolor=#A9BCF5 >"

         

        

        
        On Error Resume Next
For j = 1 To UBound(sn)
         c01 = c01 & "<tr><td>" & Join(Application.Index(sn, j), "</td><td>") & "</td></tr>"
Next
c01 = c01 & "</table><P></P><P></P>"

On Error GoTo 0 '//Resets the error handler to break code in the event of an error

        


        
        
       
     
        With CreateObject("Outlook.Application").CreateItem(0)
            .To = strto
            .cc = ""
            .bcc = "northsidevan@gmail.com"
            .Subject = "Northside Leeds " & w.Name & " Safety Checks "
            .HTMLBody = "The Items In The Table Below Are Overdue Please Complete and Update Spread Sheet" & c01
            .display
            
            
      
        End With
        
        Sheet2.Cells(1).CurrentRegion.Offset(1).ClearContents
    End If
    End If
    
 Next w
Application.EnableEvents = True
            
End Sub