Solved VBA access to outlook email with table: aligning table cells (1 Viewer)

miacino

Registered User.
Local time
Yesterday, 23:47
Joined
Jun 5, 2007
Messages
106
Hi! I am pulling some data from Access to send as table (table without borders).
Code:
Private Sub Command71_Click()
    Dim strQry As String
    Dim aHead(1 To 2) As String
    Dim aRow(1 To 2) As String
    Dim aBody() As String
    Dim lCnt As Long
    Dim rst
    Dim strEmailto As String

    FileName = "G:\CLASP\CLASP Tools\" & [Guideline] & "\" & "RG_" & [Guideline] & ".pdf"
    myLink = "https://www.connecticutchildrens.org/co-management/access-referral-guidelines/"

    'create emails to
    Set rst = CurrentDb.OpenRecordset("select [email] from [verified users]")
    If rst.NoMatch Then
    strEmailto = ""
    rst.MoveFirst
    End If
    Do While Not rst.EOF
    strEmailto = strEmailto & "; " & rst!Email
    rst.MoveNext
    Loop

    'Create the header row
    aHead(1) = ""
    aHead(2) = ""

 
    lCnt = 1
    ReDim aBody(1 To lCnt)
    aBody(lCnt) = "<HTML><body><table border='0'><tr><th>" & Join(aHead, "</th><th>") & "</th></tr>"
    

   'Create each body row
    strQry = "SELECT [summaryofchange], [guidelineID#] From [Latest summary of changes] where [guidelineid#] = " & Me![GuidelineID#]
    Set db = CurrentDb
    Set rec = CurrentDb.OpenRecordset(strQry)
    
    If Not (rec.BOF And rec.EOF) Then
        Do While Not rec.EOF
            lCnt = lCnt + 1
            ReDim Preserve aBody(1 To lCnt)
            
            aRow(1) = "<li>   </li>"
            aRow(2) = rec("summaryofchange")

            aBody(lCnt) = "<tr><td>" & Join(aRow, "</td><td>") & "</td></tr>"
            rec.MoveNext
        Loop
    
    End If

    aBody(lCnt) = aBody(lCnt) & "</table></body></html>"

 'create the email
    Set appOutLook = CreateObject("Outlook.Application")
    Set MailOutLook = appOutLook.CreateItem(olMailItem)
    Signature = MailOutLook.htmlbody
 
 With MailOutLook
    .To = "name@gmail.com"
    .bcc = strEmailto
    .subject = "CT Children's updated CLASP tool notification"
    .display
    strHTMLbody = "<HTML><BODY><font face=Calibri>Dear CLASP user community, " & "<BR><BR>The CLASP tool for <b>" & [Guideline] & _
    " </b>has been updated and posted the the CLASP internet site (<a href='" & myLink & "'>https://www./co-management/access-referral-guidelines/</a>)" & "." & _
    "  If you routinely print out the CLASP tools to use at the point of care, please be sure to print out the updated version to replace any previous ones." & _
    "<BR><BR> A summary of the updates to the CLASP tool is as follows: "

    strHTMLbody2 = "</p><BR>Please let us know if you have any questions." & _
    "<BR><BR>Thank you,"

     .htmlbody = strHTMLbody & Join(aBody, vbNewLine) & strHTMLbody2 & .htmlbody
  
    .Attachments.Add FileName
    
  End With

I have it working fabulously except for one minor thing. The bullet in the table should be TOP-CENTERED if the 2nd column goes beyond one line. (see example attached). I cannot figure out where - or how - to incorporate the appropriate code that will align those table cells to TOP.

I appreciate any guidance!!
:)
 

Attachments

i think its because of the wrap text, right? Text is growing but bullet is not..... i think.
Can you align bullet to top, maybe?
 
aBody(lCnt) = "<tr><td>" & Join(aRow, "</td><td>") & "</td></tr>"
Try to replace string above to:
Code:
aBody(lCnt) ="<tr><td Style = ""vertical-align: Top"">" & Join(aRow, "</td><td>") & "</td></tr>"
 
Code:
Private Sub Command71_Click()
    Dim strQry As String
    Dim aHead(1 To 2) As String
    Dim aRow(1 To 3) As String
    Dim aBody() As String
    Dim lCnt As Long
    Dim rst
    Dim strEmailto As String

    FileName = "G:\CLASP\CLASP Tools\" & [Guideline] & "\" & "RG_" & [Guideline] & ".pdf"
    myLink = "https://www.connecticutchildrens.org/co-management/access-referral-guidelines/"

    'create emails to
    Set rst = CurrentDb.OpenRecordset("select [email] from [verified users]")
    If rst.NoMatch Then
    strEmailto = ""
    rst.MoveFirst
    End If
    Do While Not rst.EOF
    strEmailto = strEmailto & "; " & rst!Email
    rst.MoveNext
    Loop

    'Create the header row
    aHead(1) = ""
    aHead(2) = ""

 
    lCnt = 1
    ReDim aBody(1 To lCnt)
    aBody(lCnt) = "<body><table border='0'><tr><th>" & Join(aHead, "</th><th>") & "</th></tr>"
    

   'Create each body row
    strQry = "SELECT [summaryofchange], [guidelineID#] From [Latest summary of changes] where [guidelineid#] = " & Me![GuidelineID#]
    'strQry = "SELECT [summaryofchange] From [Latest summary of changes];"
    Set db = CurrentDb
    Set rec = CurrentDb.OpenRecordset(strQry)
    
    If Not (rec.BOF And rec.EOF) Then
        Do While Not rec.EOF
            lCnt = lCnt + 1
            ReDim Preserve aBody(1 To lCnt)
            
            aRow(1) = "<ul><li>"
            aRow(2) = rec("summaryofchange")
            aRow(3) = "</li></ul>"

            'aBody(lCnt) = "<tr><td>" & Join(aRow, "</td><td>") & "</td></tr>"
            aBody(lCnt) = Join(aRow, "")
            rec.MoveNext
        Loop
    
    End If

    aBody(lCnt) = aBody(lCnt) & "</table></body></html>"

 'create the email
    Set appOutLook = CreateObject("Outlook.Application")
    Set MailOutLook = appOutLook.CreateItem(olMailItem)
    Signature = MailOutLook.htmlbody
 
 With MailOutLook
    .To = "name@gmail.com"
    .bcc = strEmailto
    .subject = "CT Children's updated CLASP tool notification"
    strHTMLbody = "Dear CLASP user community, " & "<BR><BR>The CLASP tool for <b>" & [Guideline] & _
    " </b>has been updated and posted the the CLASP internet site (<a href='" & myLink & "'>https://www./co-management/access-referral-guidelines/</a>)" & "." & _
    "  If you routinely print out the CLASP tools to use at the point of care, please be sure to print out the updated version to replace any previous ones." & _
    "<BR><BR> A summary of the updates to the CLASP tool is as follows: "

    strHTMLbody2 = "</p><BR>Please let us know if you have any questions." & _
    "<BR><BR>Thank you,"

     .htmlbody = "<HTML><head><style>Body {font-family:Calibri}li {text-indent:-20px;margin-left:20px}</style></head>" & _
     strHTMLbody & Join(aBody, vbNewLine) & strHTMLbody2 & "</HTML>"
  
    .Attachments.Add FileName
    
    .display
    
  End With
End Sub
ol1.png
 
Last edited:
Code:
Private Sub Command71_Click()
    Dim strQry As String
    Dim aHead(1 To 2) As String
    Dim aRow(1 To 3) As String
    Dim aBody() As String
    Dim lCnt As Long
    Dim rst
    Dim strEmailto As String

    FileName = "G:\CLASP\CLASP Tools\" & [Guideline] & "\" & "RG_" & [Guideline] & ".pdf"
    myLink = "https://www.connecticutchildrens.org/co-management/access-referral-guidelines/"

    'create emails to
    Set rst = CurrentDb.OpenRecordset("select [email] from [verified users]")
    If rst.NoMatch Then
    strEmailto = ""
    rst.MoveFirst
    End If
    Do While Not rst.EOF
    strEmailto = strEmailto & "; " & rst!Email
    rst.MoveNext
    Loop

    'Create the header row
    aHead(1) = ""
    aHead(2) = ""


    lCnt = 1
    ReDim aBody(1 To lCnt)
    aBody(lCnt) = "<body><table border='0'><tr><th>" & Join(aHead, "</th><th>") & "</th></tr>"
   

   'Create each body row
    strQry = "SELECT [summaryofchange], [guidelineID#] From [Latest summary of changes] where [guidelineid#] = " & Me![GuidelineID#]
    'strQry = "SELECT [summaryofchange] From [Latest summary of changes];"
    Set db = CurrentDb
    Set rec = CurrentDb.OpenRecordset(strQry)
   
    If Not (rec.BOF And rec.EOF) Then
        Do While Not rec.EOF
            lCnt = lCnt + 1
            ReDim Preserve aBody(1 To lCnt)
           
            aRow(1) = "<ul><li>"
            aRow(2) = rec("summaryofchange")
            aRow(3) = "</li></ul>"

            'aBody(lCnt) = "<tr><td>" & Join(aRow, "</td><td>") & "</td></tr>"
            aBody(lCnt) = Join(aRow, "")
            rec.MoveNext
        Loop
   
    End If

    aBody(lCnt) = aBody(lCnt) & "</table></body></html>"

'create the email
    Set appOutLook = CreateObject("Outlook.Application")
    Set MailOutLook = appOutLook.CreateItem(olMailItem)
    Signature = MailOutLook.htmlbody

With MailOutLook
    .To = "name@gmail.com"
    .bcc = strEmailto
    .subject = "CT Children's updated CLASP tool notification"
    strHTMLbody = "Dear CLASP user community, " & "<BR><BR>The CLASP tool for <b>" & [Guideline] & _
    " </b>has been updated and posted the the CLASP internet site (<a href='" & myLink & "'>https://www./co-management/access-referral-guidelines/</a>)" & "." & _
    "  If you routinely print out the CLASP tools to use at the point of care, please be sure to print out the updated version to replace any previous ones." & _
    "<BR><BR> A summary of the updates to the CLASP tool is as follows: "

    strHTMLbody2 = "</p><BR>Please let us know if you have any questions." & _
    "<BR><BR>Thank you,"

     .htmlbody = "<HTML><head><style>Body {font-family:Calibri}li {text-indent:-20px;margin-left:20px}</style></head>" & _
     strHTMLbody & Join(aBody, vbNewLine) & strHTMLbody2 & "</HTML>"
 
    .Attachments.Add FileName
   
    .display
   
  End With
End Sub
View attachment 98669

Thank you so much! That did it! :)
 
Try to replace string above to:
Code:
aBody(lCnt) ="<tr><td Style = ""vertical-align: Top"">" & Join(aRow, "</td><td>") & "</td></tr>"

Thanks for your help! It solved the vertical bullet problem, but when wrapping the text it didn't indent :(.
I think I found the solution below.
:)
 

Users who are viewing this thread

Back
Top Bottom