Printable View
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
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
sorry Bakerman
I meant to cross reference, I have added links on both sites
Thanks
Hi Peter,
Try this
Code: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