john316swan
Board Regular
- Joined
- Oct 13, 2016
- Messages
- 66
- Office Version
- 2019
- Platform
- Windows
Hi Excel Guru's,
I am having trouble with html borders when the email is read via gMail (Outlook/Apple Mail Client both read it). I googled and there wasn't much info, other than someone suggesting I change the .BodyFormat = 2 (or 'olFormatHTML)...which didn't work Please help me figure this out, it's driving me crazy
Sub emailCoaches()
'This will send a weekly email to coaches letting them know which students are on hold for their scholarship offer
Dim ws As Worksheet
Dim sportLr As Double, recruitsLr As Double
Dim x As Double, y As Double
Dim sport As String, studentHold As String, holdList As String
Dim strHeader As String, strbody As String, strFooter As String
Dim SigString As String, signature As String
Dim OL As Outlook.Application
Dim holdEmail As Outlook.MailItem
sportLr = Sheets("Tables").Cells(Rows.Count, 25).End(xlUp).Row
recruitsLr = Sheets("Recruits").Cells(Rows.Count, 1).End(xlUp).Row
SigString = Environ("appdata") & "\Microsoft\Signatures\No Logo.htm"
signature = GetSignature(SigString)
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
'This is the header that won't change for all emails
strHeader = "******>Dear Coach,<br><br>" _
& "Below is a list of all students for whom we can send a financial aid package to, " _
& "but do not have an athletic offer:<br><br>"
'This is the footer that won't change for all emails
strFooter = "<br>The data and amounts in the above table are <b>ESTIMATES</b> based on the most recent information we have. " _
& "If an art scholarship is <b>POSSIBLE</b> you can confirm with the student whether they plan on actually " _
& "auditioning. Please let me or Cathy know if anything looks funky or you have any questions.</BODY></html>" & signature
'This code creates a loop that goes through each of the hold reasons
For x = 2 To sportLr
nextSport:
'Sheets("Tables").Activate
sport = Sheets("Tables").Cells(x, 25)
Sheets("Recruits").Activate
'Now we're going to loop through all students and create a table of holds that meet the "X" criteria
For y = 2 To recruitsLr
If Cells(y, 16) = sport Then
studentHold = "<tr><td nowrap>" & Cells(y, 1) & "</td><td nowrap>" & Cells(y, 2) & "</td><td nowrap>" & Cells(y, 3) & "</td><td nowrap>" & Cells(y, 9) _
& "</td><td>" & Cells(y, 18) & "</td><td>" & Format(Cells(y, 21), "#,###") & "</td><td nowrap>" & Format(Cells(y, 22), "#,###") & "</td><td nowrap>" & Format(Cells(y, 23), "#,###") _
& "</td><td nowrap>" & Format(Cells(y, 24), "#,###") & "</td><td nowrap>" & Format(Cells(y, 25), "#,###") & "</td><td nowrap>" & Cells(y, 30) _
& "</td><td nowrap>" & Format(Cells(y, 26), "#,###") & "</td><td nowrap>" & Format(Cells(y, 27), "#,###") & "</td><td nowrap>" & Format(Cells(y, 28), "#,###") & "</td>"
holdList = holdList & studentHold & "</tr>"
End If
Next y
'Once you loop through list, if there are no holds, we will then skip to next sport
If holdList = "" Then
If x > sportLr Then
Exit Sub
End If
x = x + 1
holdlst = ""
GoTo nextSport
End If
'Now we will send the email to the coach
Set OL = CreateObject("Outlook.Application")
Set holdEmail = OL.CreateItem(0)
strbody = "<style>table, th, td {border: 1px solid black; border-collapse: collapse; word-wrap: break-word; text-align: center; padding: 5px;}</style>" _
& "<table><tr><th no wrap>Student ID</th><th nowrap>Last</th><th nowrap>First</th><th nowrap>FAFSA</th><th nowrap>Room & Board" _
& "</th><th nowrap>Academic</th><th nowrap>Scholar Event</th><th nowrap>Pell</th><th nowrap>Cal Grant" _
& "</th><th nowrap>Tot. Free Money</th><th nowrap>Arts Possible</th><th nowrap>Est. Loans</th><th nowrap>Est Costs" _
& "</th><th nowrap>Est Bal B4 Ath $</th></tr>" & holdList & "</table>"
With holdEmail
.To = Sheets("Tables").Cells(x, 27)
.Subject = "19-20 Financial Aid Package Holds for " & Sheets("Tables").Cells(x, 26)
.HTMLBody = strHeader & strbody & strFooter
.BodyFormat = 2
.Send
End With
'Now we reset hold list and move to next sport
Set OL = Nothing
Set holdEmail = Nothing
holdList = ""
Next x
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Function GetSignature(ByVal sFile As String) As String
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetSignature = ts.ReadAll
ts.Close
End Function
<style>table, th, td {border: 1px solid black; border-collapse: collapse; word-wrap: break-word; text-align: center; padding: 5px;}</style>
I am having trouble with html borders when the email is read via gMail (Outlook/Apple Mail Client both read it). I googled and there wasn't much info, other than someone suggesting I change the .BodyFormat = 2 (or 'olFormatHTML)...which didn't work Please help me figure this out, it's driving me crazy
Sub emailCoaches()
'This will send a weekly email to coaches letting them know which students are on hold for their scholarship offer
Dim ws As Worksheet
Dim sportLr As Double, recruitsLr As Double
Dim x As Double, y As Double
Dim sport As String, studentHold As String, holdList As String
Dim strHeader As String, strbody As String, strFooter As String
Dim SigString As String, signature As String
Dim OL As Outlook.Application
Dim holdEmail As Outlook.MailItem
sportLr = Sheets("Tables").Cells(Rows.Count, 25).End(xlUp).Row
recruitsLr = Sheets("Recruits").Cells(Rows.Count, 1).End(xlUp).Row
SigString = Environ("appdata") & "\Microsoft\Signatures\No Logo.htm"
signature = GetSignature(SigString)
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
'This is the header that won't change for all emails
strHeader = "******>Dear Coach,<br><br>" _
& "Below is a list of all students for whom we can send a financial aid package to, " _
& "but do not have an athletic offer:<br><br>"
'This is the footer that won't change for all emails
strFooter = "<br>The data and amounts in the above table are <b>ESTIMATES</b> based on the most recent information we have. " _
& "If an art scholarship is <b>POSSIBLE</b> you can confirm with the student whether they plan on actually " _
& "auditioning. Please let me or Cathy know if anything looks funky or you have any questions.</BODY></html>" & signature
'This code creates a loop that goes through each of the hold reasons
For x = 2 To sportLr
nextSport:
'Sheets("Tables").Activate
sport = Sheets("Tables").Cells(x, 25)
Sheets("Recruits").Activate
'Now we're going to loop through all students and create a table of holds that meet the "X" criteria
For y = 2 To recruitsLr
If Cells(y, 16) = sport Then
studentHold = "<tr><td nowrap>" & Cells(y, 1) & "</td><td nowrap>" & Cells(y, 2) & "</td><td nowrap>" & Cells(y, 3) & "</td><td nowrap>" & Cells(y, 9) _
& "</td><td>" & Cells(y, 18) & "</td><td>" & Format(Cells(y, 21), "#,###") & "</td><td nowrap>" & Format(Cells(y, 22), "#,###") & "</td><td nowrap>" & Format(Cells(y, 23), "#,###") _
& "</td><td nowrap>" & Format(Cells(y, 24), "#,###") & "</td><td nowrap>" & Format(Cells(y, 25), "#,###") & "</td><td nowrap>" & Cells(y, 30) _
& "</td><td nowrap>" & Format(Cells(y, 26), "#,###") & "</td><td nowrap>" & Format(Cells(y, 27), "#,###") & "</td><td nowrap>" & Format(Cells(y, 28), "#,###") & "</td>"
holdList = holdList & studentHold & "</tr>"
End If
Next y
'Once you loop through list, if there are no holds, we will then skip to next sport
If holdList = "" Then
If x > sportLr Then
Exit Sub
End If
x = x + 1
holdlst = ""
GoTo nextSport
End If
'Now we will send the email to the coach
Set OL = CreateObject("Outlook.Application")
Set holdEmail = OL.CreateItem(0)
strbody = "<style>table, th, td {border: 1px solid black; border-collapse: collapse; word-wrap: break-word; text-align: center; padding: 5px;}</style>" _
& "<table><tr><th no wrap>Student ID</th><th nowrap>Last</th><th nowrap>First</th><th nowrap>FAFSA</th><th nowrap>Room & Board" _
& "</th><th nowrap>Academic</th><th nowrap>Scholar Event</th><th nowrap>Pell</th><th nowrap>Cal Grant" _
& "</th><th nowrap>Tot. Free Money</th><th nowrap>Arts Possible</th><th nowrap>Est. Loans</th><th nowrap>Est Costs" _
& "</th><th nowrap>Est Bal B4 Ath $</th></tr>" & holdList & "</table>"
With holdEmail
.To = Sheets("Tables").Cells(x, 27)
.Subject = "19-20 Financial Aid Package Holds for " & Sheets("Tables").Cells(x, 26)
.HTMLBody = strHeader & strbody & strFooter
.BodyFormat = 2
.Send
End With
'Now we reset hold list and move to next sport
Set OL = Nothing
Set holdEmail = Nothing
holdList = ""
Next x
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Function GetSignature(ByVal sFile As String) As String
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetSignature = ts.ReadAll
ts.Close
End Function
<style>table, th, td {border: 1px solid black; border-collapse: collapse; word-wrap: break-word; text-align: center; padding: 5px;}</style>
Last edited: