Add Data From Excel Sheet to Email HTML Body

**DMT Dave** · 02-16-2025, 09:36 AM

Hello genius's

Whilst I can and recordsets to email HTML, i have had an attempt to email and excel sheet after checking data is correct to email HTML table, in teh following code (not showing variables) but all variables are correct

i am showing the correct amont of records in immediate window, i am using rngString (to Find the range of data to go to email body)

I am unsre if this can be done, the issue i have is rngString (set as string) is coming up runtime error 13 type mistcah, this to me is usually avariable incorectly set ?

If you genius's know how i can email the contents of anexcel sheet to html table on email body would be superb....
debuging

Code:

rngString = xlWS.Range("A" + intLR & ":I" + intLR)

Code attempt

Code:

strPath = "T:\Delivery Routes\"    strFile = "Weekly Routes" & " " & Format(dtMon, "ddd-dd-mmm-yyyy") & ".xlsx"


    strHTML = "<HTML><Body><table border='3' width=auto'><font color='blue' size='3' face='Arial'><tr><th>Day</th><th>Delivery Date</th></th>" & _
        "<th>Driver</th><th>Drop No</th><th>Delivery To</th><th>Town</th><th>PostCode</th><th>Qty</th><th></th></tr>"
        
    strBody = strHTML


    Set apXL = CreateObject("Excel.Application")
    Set xlWB = apXL.Workbooks.Open(strPath & strFile)
    
    apXL.Visible = False
    
    Set xlWS = xlWB.Worksheets(1)
    
    With xlWS
    'ADD BREAK BETWEEN DRIVER NAMES
    For r = (.Cells(xlWS.Rows.Count, AddClm).End(xlUp).Row - 1) To 2 Step -1
        If .Cells(r, AddClm).Value <> .Cells(r + 1, AddClm).Value Then
                .Cells(r + 1, AddClm).ReSize(AddRow).EntireRow.Insert
        End If
    Next r
    'FIND LASTROW USED
        intLR = .Cells(.Rows.Count, 1).End(xlUp).Row
    Debug.Print intLR 'Returning 77 rows, correct
    'GATHER SHEET DATA TO ADD TO HTML MAIL
        rngString = xlWS.Range("A" + intLR & ":I" + intLR)
    'SET HTML TABLE AND ADD EXCEL SHEET DATA (rngString)
    
        strBody = strBody & "<tr><td style='background-color:#F5F5F5'>" & rngString & "</td></tr>"
    'ADD TO MAIL
    Set myItem = myApp.CreateItem(olMailItem)
    Set outAccount = myApp.Session.Accounts.item(1)
        With myItem
            .HTMLBody = rngString
            .Display
        End With
    
    End With
        
    xlWB.Close
    
    Set xlWS = Nothing
    Set apXL = Nothing
    Set xlWB = Nothing

**Welshgasman** · 02-16-2025, 10:00 AM

Range is not a string, but a Range or Object.
Whilst you can refer to a range address as a string variable, all you would be doing there is inserting literally "A77:i77".
Even if that were to insert the range values, you would only get the last row?

You might need to add one row at a time.

Here is how I did it, but my data came from Access, but the logic is the same

Code:

    ' Set up HTML tags
    strPad = "<tr><td>"
    strEndPad = "</td></tr>"
    strPadCol = "</td><td>"
    strBlankLine = "<tr></tr>"




........

            ' Now add the variable data
            With objOutlookMsg
                .HTMLBody = .HTMLBody & strPad & str3rdPartyType & strPadCol & str3rdParty & strEndPad
                .HTMLBody = .HTMLBody & strPad & strDatetype & strPadCol & strDate & strEndPad
                .HTMLBody = .HTMLBody & strPad & "Method:" & strPadCol & strMethod & strEndPad
                .HTMLBody = .HTMLBody & strPad & "Reference:" & strPadCol & strRef & strEndPad
                .HTMLBody = .HTMLBody & strPad & "Amount:" & strPadCol & strAmount & strEndPad
                .HTMLBody = .HTMLBody & strPad & "Balance:" & strPadCol & strBalance & strEndPad
                ' Add any notes if they exist
                If Len(strNotes) > 0 Then
                    .HTMLBody = .HTMLBody & strPad & "Notes:" & strPadCol & strNotes & strEndPad


                End If
'                ' Add blank line for next set
                .HTMLBody = .HTMLBody & strBlankLine & strBlankLine
            End With

Plus even if it did work, you set up strBody and then use rngString for the HTML body?

Why not just send as an attachment?

**DMT Dave** · 02-16-2025, 10:10 AM

Thanks WGM, will read htrough your reply properly, just glanced and seen may need to add 1 at a time, the reason for not attaching is because drivers can view their allocations easier, one of the drivers checking are monitoring weekly hours therefore easier for them to glance over it and work it out, i can and currently email from access without BlankLine, i currently manually clcik at the end of each driver, right click and insert a new blank row below.

just though now that i am able to add a blank row on excel sheet, grab that data and add to html.

will read thrpugh your reply more thoroughly in a couple of miniutes

**DMT Dave** · 02-16-2025, 10:17 AM

my 2nd option failing the method i was trying is to have a tempTable, clear the data, update the data, add a new blank record with day field and date field and don't add a driver name, then next update, clear and update again, local table perhaps

**DMT Dave** · 02-16-2025, 10:28 AM

Yeh, just seen a couple of things, i didn't set A(1) + intLR and I(1) + intLR

also tried setting a new varable (rngData) set as Range

still a type mismatch

Code:

'FIND LASTROW USED        intLR = .Cells(.Rows.Count, 1).End(xlUp).Row
    Debug.Print intLR 'Returning 77 rows, correct
    'GATHER SHEET DATA TO ADD TO HTML MAIL
        rngData = .Range("A1" + intLR & ":I1" + intLR)
    'SET HTML TABLE AND ADD EXCEL SHEET DATA (rngData)
    
        strBody = strBody & "<tr><td style='background-color:#F5F5F5'>" & rngData & "</td></tr>"
    'ADD TO MAIL
    Set myItem = myApp.CreateItem(olMailItem)
    Set outAccount = myApp.Session.Accounts.item(1)
        With myItem
            .HTMLBody = strBody
            .Display
        End With

**Welshgasman** · 02-16-2025, 10:58 AM

You can't just copy a range like that.

And even if you could, your range is rubbish. that would come out as A177:I77 ??? even if it compiled and worked. It should complain with Type Mismatch?

I missed that at first and just saw & as that is what I use to build a range address in a string variable.

Edit: The only way I know works for the method you are attempting is to refer to a range within Excel only.

Like so

Code:

Private Sub Workbook_Open()
Dim lngLastRow As Long, lngLastRowCopy As Long
Dim strColName1 As String, strColName2 As String
Dim iCol As Integer
'Refresh sheet to get lastet data.
ActiveWorkbook.RefreshAll
'Get last row in A in sheet qryPresure
Sheets("qryPressure").Select
'Find colname for 'With Time'
iCol = Application.WorksheetFunction.Match("With Time", ActiveSheet.Rows(1), 0)
strColName1 = ActiveSheet.Cells(1, iCol).Address(False, False)
strColName2 = ActiveSheet.Cells(1, iCol + 3).Address(False, False)


'Allow for wide sheets
If Len(strColName1) > 2 Then
    strColName1 = Left(strColName1, 2)
    strColName2 = Left(strColName2, 2)
Else
    strColName1 = Left(strColName1, 1)
    strColName2 = Left(strColName2, 1)
End If
lngLastRow = GetLastRow(ActiveSheet.Name) '.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
lngLastRowCopy = GetLastRow(ActiveSheet.Name, strColName1) 'Just copy from last row available instead of row 2 as before
'Copy formula in F2 down.
Range(strColName1 & "2:" & strColName2 & "2").Copy
Range(strColName1 & lngLastRowCopy & ":" & strColName2 & lngLastRow).PasteSpecial xlPasteFormulasAndNumberFormats
Range(strColName1 & lngLastRow).Select
Sheets(4).Select ' Chnage as required
ActiveWorkbook.Save
End Sub

**DMT Dave** · 02-16-2025, 11:24 AM

ok, thanks WGM, suggest my 2nd option easier, add to temp table and add to html by adding blank records between drivers in each day of week ?

**Welshgasman** · 02-16-2025, 11:27 AM

Well if you are going to do that, you might as well just walk the rows one at a time.
I am presuming all 77 rows encompass multiple drivers? If so, just insert a blank row when the driver changes.

**Gicu** · 02-16-2025, 12:11 PM

And that why it is important to post the entire procedure including the variable declarations, can't be that much harder...
In any case please review this older thread:
https://stackoverflow.com/questions/...nge-in-outlook
Basically it uses a custom VBA function to do it, here is the entire working code, it will have to be updated to match your case, if you post the entire procedure we might be able to help.
Ron's code (fromhttps://answers.microsoft.com/en-us/msoffice/forum/all/macro-to-paste-copied-excel-selection-into-the/9cb7874f-6b57-4da0-91ba-a470294e26cc)

Code:

Here is a working macro!  Thank you all and Ron de Bruin
https://www.rondebruin.nl/win/s1/outlook/bmail2.htm


Sub Mail_Selection_Range_Outlook_Body()


Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object


Set rng = Nothing
' Only send the visible cells in the selection.


'this uses the current selection
Set rng = Selection.SpecialCells(xlCellTypeVisible)


'This is if you have a specific range you want to use
'Set rng = Sheets("Sheet1").Range("D4:D12").SpecialCells(xlCellTypeVisible)


If rng Is Nothing Then
    MsgBox "The selection is not a range or the sheet is protected. " & _
           vbNewLine & "Please correct and try again.", vbOKOnly
    Exit Sub
End If


With Application
    .EnableEvents = False
    .ScreenUpdating = False
End With


Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)




With OutMail
    .To = ThisWorkbook.Sheets("Sheet2").Range("C1").Value
    .CC = ""
    .BCC = ""
    .Subject = "This is the Subject line"
    .HTMLBody = RangetoHTML(rng)
    ' In place of the following statement, you can use ".Display" to
    ' display the e-mail message.
    .Display
End With
On Error GoTo 0


With Application
    .EnableEvents = True
    .ScreenUpdating = True
End With


Set OutMail = Nothing
Set OutApp = Nothing
End Sub




Function RangetoHTML(rng As Range)
' By Ron de Bruin.
    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 past 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

Cheers,

**jojowhite** · 02-16-2025, 09:54 PM

maybe post the excel workbook.
i am sure adding add blanks lines between drivers
through VBA and not to Alter the excel file.

**DMT Dave** · 02-17-2025, 12:55 AM

Hi Guy's thank you all for your input, to make things a little easier, i have ruled out adding data from Excel with new lines per day / driver, whist the result on the excel file does have blank line, the excel file does output correctly from access, however what i am trying to achieve is adding a new blank row in the HTML email (per driver in each day), please forgive for steering away from Excel idea, The excel file is just an external backup for that week i think working with Access / Outlook maybe easier but again, i am unsure how to implement what code and where to achieve.

The code on this post works great for the 5 working days, there are 5 SQL's, i currently right click in each day on the last row with driver A, insert a new blank line then Driver B and continue to do so on each day / driver

Lets say 7 drivers in 5 days (35 right clicks to insert blank rows), this is totally to add a separator for easier viewing / calculating time etc...

As i can now achieve it in Excel, that was my reasoning to try and adapt that to Email table, but as i already have the email setup in another procedure, again forgive me but lets rule excel external backup file out!

So in my code below, how would i add a blank new row (after each driver) in all 5 SQL's (5 days) ?

Can my code be modified to add a blank row per driver / per SQL (day) ?

Thank you all as always, you guy's are totally appreciated

Code:

Dim myApp As New Outlook.Application, outAccount As Outlook.Account, myItem As Outlook.MailItem
Dim oOutlook As Object


Dim rs As DAO.Recordset, rs2 As DAO.Recordset, rs3 As DAO.Recordset, rs4 As DAO.Recordset, rs5 As DAO.Recordset, rs6 As DAO.Recordset


Dim StaffName As String, FullName() As String, fName As String, myGreet As String, strEmail As String, TimeNow As String, strHTML As String, strBody As String, strSQL As String, strCCAll As String
Dim myMonth As String, TOD As String, SigFile As String, eDisc As String, eDisc2 As String, strUser As String, FullUser() As String, strfName As String, strSign As String, strUserSign As String
Dim strFS As String, strFE As String, strBoxStart As String, strBoxEnd As String, strMSG As String, strLink As String, OpenChrome As String, strBody2 As String, strMap As String, strDriver As String
Dim strURL As String, sSmiley As String, sDayName As String, sDriverName() As String, sDriver As String, strHTML2 As String, strHTML3 As String, strHTML4 As String, strHTML5 As String
Dim strBody3 As String, strBody4 As String, strBody5 As String, strSQL2 As String, strSQL3 As String, strSQL4 As String, strSQL5 As String, sFH As String, sFHEnd As String, strTip As String
Dim sVan1 As String, sVan2 As String, sVan3 As String, strTipFile As String, sSrc As String, sCC As String, sCC2 As String, sCC3 As String, sCC4 As String, strHTML6 As String, strBody6 As String


Dim dtStart As Date, dtEnd As Date, dtShipDate As Date


Dim i As Integer


Dim varOpt As Variant
   
strFS = "<font size='3' face='Arial' style=text-align=center; vertical-align=middle>" ‘ Mail Font
strFE = "</font>" ‘ End Font’
    sSmiley = "<span style='font-size:16px;'>😄</span>"
    dtShipDate = Format(Me.cboWeek, "mm/dd/yyyy")
    dtStart = DateAdd("d", 3, Me.cboWeek)
    dtEnd = DateAdd("d", 9, Me.cboWeek)
 
TimeNow = Format(Now(), "hh")
    Select Case TimeNow
    Case Is <= 12
        TOD = strFS & "Good Morning ," & "hope you are well " & strFE & sSmiley
    Case Is <= 17
        TOD = strFS & "Good Afternoon ," & "hope you are well " & strFE & sSmiley
    Case Else
        TOD = strFS & "Good Evening ," & "hope you are well " & strFE & sSmiley
    End Select
 
 
myMonth = Format(Now(), "mm")
If myMonth <> "12" Then
    SigFile = "DMT dave@ Email Signature.jpg"
Else
    SigFile = "DMT Xmas Signature.jpg"
End If
 
strBoxStart = "<script><table width='auto';style='text-align:left;border:1px solid black;font-family:calibri;border-collapse:collapse;padding:10px'><tr style='background:white;mso-highlight:blue' ctx.shadowblur;20; ctx.shadowcolor;blue></script>"
strBoxEnd = "</tr></table>"
 
eDisc = “This Is Our Email Disclaimer”
eDisc2 = "“This Is Our Email Disclaimer2”
 
strUser = Forms!frmMainMenu!txtLogin
 
FullUser = Split(strUser, " ")
strfName = FullUser(0)
strSign = strUser
 
strUserSign = "<i><font face='Bradley Hand TC' size='4'>" & strSign & "</font></i>"
   
strMSG = "WEEKLY PLANNER.|" & _
    "DMT delivery plans for week commencing " & Format(dtStart, "dddd-dd-mmm-yyyy") & ".|" & _
    "Please note, plans throughout the week may well change.|"
   
myGreet = TOD
 
    strHTML = "<HTML><Body><table border='3' width=auto'><font color='blue' size='3' face='Arial'><tr><th>Day</th><th>Delivery Date</th></th>" & _
        "<th>Driver</th><th>Delivery To (In Order)</th><th>Town</th><th>PostCode</th><tr>"
       
        strBody = strHTML
   
    strSQL = "SELECT tblRoutes.DayName, tblRoutes.Driver, tblRoutes.DelDate, tblRoutes.DelNo, tblRoutes.DelTo, tblRoutes.Town, tblRoutes.PostCode, tblRoutes.ETA, tblRoutes.Source " _
        & "From tblRoutes " _
        & "WHERE (((tblRoutes.DayName)= ""Monday"")) " _
        & "ORDER BY tblRoutes.Driver, tblRoutes.DelDate, tblRoutes.DelNo;"
 
    Set rs = CurrentDb.OpenRecordset(strSQL)
   
    Do While Not rs.EOF
   
    If IsNull(rs.Fields("DayName")) Then
        sDayName = "No Date Planned"
    Else
        sDayName = rs.Fields("DayName")
    End If
   
    strBody = strBody & "<tr>" & _
        "<td style='background-color:#F5F5F5'>" & strFS & sDayName & strFE & "</td>" & _
        "<td style='background-color:#F8F8FF'>" & strFS & Format(rs.Fields("DelDate"), "dd-mmm-yyyy") & strFE & "</td>" & _
        "<td style='background-color:#F5F5F5'>" & strFS & rs.Fields("Driver") & strFE & "</td>" & _
        "<td style='background-color:#F8F8FF'>" & strFS & rs.Fields("DelTo") & strFE & "</td>" & _
        "<td style='background-color:#F8F8FF'>" & strFS & rs.Fields("Town") & strFE & "</td>" & _
        "<td style='background-color:#F5F5F5'>" & strFS & rs.Fields("PostCode") & strFE & "</td></tr>" & "|"
       
    rs.MoveNext
    Loop
   
    strHTML2 = "<HTML><Body><table border='3' width=auto'><font color='blue' size='3' face='Arial'><tr><th>Day</th><th>Delivery Date</th></th>" & _
        "<th>Driver</th><th>Delivery To (In Order)</th><th>Town</th><th>PostCode</th><tr>"
   
          strBody2 = strHTML2
       
    strSQL2 = "SELECT tblRoutes.DayName, tblRoutes.Driver, tblRoutes.DelDate, tblRoutes.DelNo, tblRoutes.DelTo, tblRoutes.Town, tblRoutes.PostCode, tblRoutes.ETA, tblRoutes.Source " _
        & "From tblRoutes " _
        & "WHERE (((tblRoutes.DayName)= ""Tuesday"")) " _
        & "ORDER BY tblRoutes.Driver, tblRoutes.DelDate, tblRoutes.DelNo;"
       
    Set rs2 = CurrentDb.OpenRecordset(strSQL2)
 
    Do While Not rs2.EOF
   
    If IsNull(rs2.Fields("DayName")) Then
        sDayName = "No Date Planned"
    Else
        sDayName = rs2.Fields("DayName")
    End If
   
    strBody2 = strBody2 & "<tr>" & _
        "<td style='background-color:#F5F5F5'>" & strFS & sDayName & strFE & "</td>" & _
        "<td style='background-color:#F8F8FF'>" & strFS & Format(rs2.Fields("DelDate"), "dd-mmm-yyyy") & strFE & "</td>" & _
        "<td style='background-color:#F5F5F5'>" & strFS & rs2.Fields("Driver") & strFE & "</td>" & _
        "<td style='background-color:#F8F8FF'>" & strFS & rs2.Fields("DelTo") & strFE & "</td>" & _
        "<td style='background-color:#F8F8FF'>" & strFS & rs2.Fields("Town") & strFE & "</td>" & _
        "<td style='background-color:#F5F5F5'>" & strFS & rs2.Fields("PostCode") & strFE & "</td></tr>" & "|"
   
   
    rs2.MoveNext
    Loop
   
    strHTML3 = "<HTML><Body><table border='3' width=auto'><font color='blue' size='3' face='Arial'><tr><th>Day</th><th>Delivery Date</th></th>" & _
        "<th>Driver</th><th>Delivery To (In Order)</th><th>Town</th><th>PostCode</th><tr>"
   
          strBody3 = strHTML3
       
    strSQL3 = "SELECT tblRoutes.DayName, tblRoutes.Driver, tblRoutes.DelDate, tblRoutes.DelNo, tblRoutes.DelTo, tblRoutes.Town, tblRoutes.PostCode, tblRoutes.ETA " _
        & "From tblRoutes " _
        & "WHERE (((tblRoutes.DayName)= ""Wednesday"")) " _
        & "ORDER BY tblRoutes.Driver, tblRoutes.DelDate, tblRoutes.DelNo;"
       
    Set rs3 = CurrentDb.OpenRecordset(strSQL3)
 
    Do While Not rs3.EOF
   
    If IsNull(rs3.Fields("DayName")) Then
        sDayName = "No Date Planned"
    Else
        sDayName = rs3.Fields("DayName")
    End If
   
        strBody3 = strBody3 & "<tr>" & _
        "<td style='background-color:#F5F5F5'>" & strFS & sDayName & strFE & "</td>" & _
        "<td style='background-color:#F8F8FF'>" & strFS & Format(rs3.Fields("DelDate"), "dd-mmm-yyyy") & strFE & "</td>" & _
        "<td style='background-color:#F5F5F5'>" & strFS & rs3.Fields("Driver") & strFE & "</td>" & _
        "<td style='background-color:#F8F8FF'>" & strFS & rs3.Fields("DelTo") & strFE & "</td>" & _
        "<td style='background-color:#F8F8FF'>" & strFS & rs3.Fields("Town") & strFE & "</td>" & _
        "<td style='background-color:#F5F5F5'>" & strFS & rs3.Fields("PostCode") & strFE & "</td></tr>" & "|"
   
    rs3.MoveNext
    Loop
   
    strHTML4 = "<HTML><Body><table border='3' width=auto'><font color='blue' size='3' face='Arial'><tr><th>Day</th><th>Delivery Date</th></th>" & _
        "<th>Driver</th><th>Delivery To (In Order)</th><th>Town</th><th>PostCode</th><tr>"
   
          strBody4 = strHTML4
       
    strSQL4 = "SELECT tblRoutes.DayName, tblRoutes.Driver, tblRoutes.DelDate, tblRoutes.DelNo, tblRoutes.DelTo, tblRoutes.Town, tblRoutes.PostCode, tblRoutes.ETA " _
        & "From tblRoutes " _
        & "WHERE (((tblRoutes.DayName)= ""Thursday"")) " _
        & "ORDER BY tblRoutes.Driver, tblRoutes.DelDate, tblRoutes.DelNo;"
       
    Set rs4 = CurrentDb.OpenRecordset(strSQL4)
 
    Do While Not rs4.EOF
    If IsNull(rs4.Fields("DayName")) Then
        sDayName = "No Date Planned"
    Else
        sDayName = rs4.Fields("DayName")
    End If
   
        strBody4 = strBody4 & "<tr>" & _
        "<td style='background-color:#F5F5F5'>" & strFS & sDayName & strFE & "</td>" & _
        "<td style='background-color:#F8F8FF'>" & strFS & Format(rs4.Fields("DelDate"), "dd-mmm-yyyy") & strFE & "</td>" & _
        "<td style='background-color:#F5F5F5'>" & strFS & rs4.Fields("Driver") & strFE & "</td>" & _
        "<td style='background-color:#F8F8FF'>" & strFS & rs4.Fields("DelTo") & strFE & "</td>" & _
        "<td style='background-color:#F8F8FF'>" & strFS & rs4.Fields("Town") & strFE & "</td>" & _
        "<td style='background-color:#F5F5F5'>" & strFS & rs4.Fields("PostCode") & strFE & "</td></tr>" & "|"
   
    rs4.MoveNext
    Loop
   
    strHTML5 = "<HTML><Body><table border='3' width=auto'><font color='blue' size='3' face='Arial'><tr><th>Day</th><th>Delivery Date</th></th>" & _
        "<th>Driver</th><th>Delivery To (In Order)</th><th>Town</th><th>PostCode</th><tr>"
   
    strBody5 = strHTML5
       
    strSQL5 = "SELECT tblRoutes.DayName, tblRoutes.Driver, tblRoutes.DelDate, tblRoutes.DelNo, tblRoutes.DelTo, tblRoutes.Town, tblRoutes.PostCode, tblRoutes.ETA " _
        & "From tblRoutes " _
        & "WHERE (((tblRoutes.DayName)= ""Friday"")) " _
        & "ORDER BY tblRoutes.Driver, tblRoutes.DelDate, tblRoutes.DelNo;"
       
    Set rs5 = CurrentDb.OpenRecordset(strSQL5)
 
    Do While Not rs5.EOF
    If IsNull(rs5.Fields("DayName")) Then
        sDayName = "No Date Planned"
    Else
        sDayName = rs5.Fields("DayName")
    End If
   
    strBody5 = strBody5 & "<tr>" & _
        "<td style='background-color:#F5F5F5'>" & strFS & sDayName & strFE & "</td>" & _
        "<td style='background-color:#F8F8FF'>" & strFS & Format(rs5.Fields("DelDate"), "dd-mmm-yyyy") & strFE & "</td>" & _
        "<td style='background-color:#F5F5F5'>" & strFS & rs5.Fields("Driver") & strFE & "</td>" & _
        "<td style='background-color:#F8F8FF'>" & strFS & rs5.Fields("DelTo") & strFE & "</td>" & _
        "<td style='background-color:#F8F8FF'>" & strFS & rs5.Fields("Town") & strFE & "</td>" & _
        "<td style='background-color:#F5F5F5'>" & strFS & rs5.Fields("PostCode") & strFE & "</td></tr>" & "|"
   
    rs5.MoveNext
    Loop
   
    sFH = "<font size='4' face='Verdana' style=text-align=center; vertical-align=middle>"
    sFHEnd = "</font>"
   
    strEmail = "driver1mail"
    sCC = " driver2mail "
    sCC2 = " driver3mail "
    sCC3 = " driver4mail "
    sCC4 = " driver5mail "
   
    strCCAll = sCC & "; " & sCC2 & " ;" & sCC3 & ": " & sCC4
 
  Set myItem = myApp.CreateItem(olMailItem)
    Set outAccount = myApp.Session.Accounts.item(1)
    With myItem
        .To = strEmail
        .CC = strCCAll
    .Subject = "Week Commencing " & Format(dtStart, "dd-mmm-yyyy")
    .HTMLBody = strFS & myGreet & "<br>" & "<br>" & Replace(strMSG, "|", "<br>" & "<br>") & strFE & "<br>" & "<br>" & _
    sFH & "<B>MONDAY</B>" & sFHEnd & "<br>" & strBoxStart & Replace(strBody, "|", "<br>") & strBoxEnd & "<br>" & _
    sFH & "<B>TUESDAY</B>" & sFHEnd & "<br>" & strBoxStart & Replace(strBody2, "|", "<br>") & strBoxEnd & "<br>" & _
    sFH & "<B>WEDNESDAY</B>" & sFHEnd & "<br>" & strBoxStart & Replace(strBody3, "|", "<br>") & strBoxEnd & "<br>" & _
    sFH & "<B>THURSDAY</B>" & sFHEnd & "<br>" & strBoxStart & Replace(strBody4, "|", "<br>") & strBoxEnd & "<br>" & _
    sFH & "<B>FRIDAY</B>" & sFHEnd & "<br>" & strBoxStart & Replace(strBody5, "|", "<br>") & strBoxEnd & "<br>" & _
    strUserSign & "<br>" & "<br>" & _
    "<P><IMG border=0 hspace=0 alt='' src='file://T:/DMT Ltd/Logo Media/" & SigFile & "' align=baseline></P>" & "<br>" & "<br>" & _
    "<FONT color=#00008B>" & eDisc & "<br>" & "<FONT color =#00008B>" & eDisc2
    .SendUsingAccount = outAccount
    .Display
End With

**Welshgasman** · 02-17-2025, 04:03 AM

You test for when the driver changes and add a blank line.

Unless you want all drivers to see each others jobs/trips, I would be emailing each their own in an email.

**DMT Dave** · 02-17-2025, 04:17 AM

HI WGM, yes i used to send each their own but yes all drivers to see each others jobs/trips.

What would be the method

set a recordset or an insert statement

Try and find Driver change and add record ?

After help on here, this I can do in Excel but unsure how to find each driver change in each SQL 1 to 5 in Access

I did find something on Google but more excel based

I now have duplicate table called tblRoutes2, all data is now added to the new table so i can use tblRoutes2 for emailing purposes only

Once any updates are added / or new week, both tables are cleared with a Delete statement and new week added, then it's the adjustments required

**Welshgasman** · 02-17-2025, 05:41 AM

With what you have now.

I would open a recordset for valid drivers.
Within that recordset loop, I would run all those queries, but just for the driver in the current recordset record.
Then before I MoveNext, add your blank line.

Rinse and repeat.

**Gicu** · 02-17-2025, 10:40 AM

Here is how I would check for driver change (look at the Mondays recordset). Your code could be streamlined by using a loop and the Weekday() function on the delivery data (no need to hardcode the DayName like you do now in the temporary table) you would loop from 2 to 6 (for Monday to Friday):
https://learn.microsoft.com/en-us/of...ekday-function

Code:

Dim myApp As New Outlook.Application, outAccount As Outlook.Account, myItem As Outlook.MailItem
Dim oOutlook As Object




Dim rs As DAO.Recordset, rs2 As DAO.Recordset, rs3 As DAO.Recordset, rs4 As DAO.Recordset, rs5 As DAO.Recordset, rs6 As DAO.Recordset




Dim StaffName As String, FullName() As String, fName As String, myGreet As String, strEmail As String, TimeNow As String, strHTML As String, strBody As String, strSQL As String, strCCAll As String
Dim myMonth As String, TOD As String, SigFile As String, eDisc As String, eDisc2 As String, strUser As String, FullUser() As String, strfName As String, strSign As String, strUserSign As String
Dim strFS As String, strFE As String, strBoxStart As String, strBoxEnd As String, strMSG As String, strLink As String, OpenChrome As String, strBody2 As String, strMap As String, strDriver As String
Dim strURL As String, sSmiley As String, sDayName As String, sDriverName() As String, sDriver As String, strHTML2 As String, strHTML3 As String, strHTML4 As String, strHTML5 As String
Dim strBody3 As String, strBody4 As String, strBody5 As String, strSQL2 As String, strSQL3 As String, strSQL4 As String, strSQL5 As String, sFH As String, sFHEnd As String, strTip As String
Dim sVan1 As String, sVan2 As String, sVan3 As String, strTipFile As String, sSrc As String, sCC As String, sCC2 As String, sCC3 As String, sCC4 As String, strHTML6 As String, strBody6 As String


Dim dtStart As Date, dtEnd As Date, dtShipDate As Date
Dim i As Integer
Dim varOpt As Variant
Dim sCurrentDriver as String


   
strFS = "<font size='3' face='Arial' style=text-align=center; vertical-align=middle>" ‘ Mail Font
strFE = "</font>" ‘ End Font’
    sSmiley = "<span style='font-size:16px;'>��</span>"
    dtShipDate = Format(Me.cboWeek, "mm/dd/yyyy")
    dtStart = DateAdd("d", 3, Me.cboWeek)
    dtEnd = DateAdd("d", 9, Me.cboWeek)
 
TimeNow = Format(Now(), "hh")
    Select Case TimeNow
    Case Is <= 12
        TOD = strFS & "Good Morning ," & "hope you are well " & strFE & sSmiley
    Case Is <= 17
        TOD = strFS & "Good Afternoon ," & "hope you are well " & strFE & sSmiley
    Case Else
        TOD = strFS & "Good Evening ," & "hope you are well " & strFE & sSmiley
    End Select
 
 
myMonth = Format(Now(), "mm")
If myMonth <> "12" Then
    SigFile = "DMT dave@ Email Signature.jpg"
Else
    SigFile = "DMT Xmas Signature.jpg"
End If
 
strBoxStart = "<script><table width='auto';style='text-align:left;border:1px solid black;font-family:calibri;border-collapse:collapse;padding:10px'><tr style='background:white;mso-highlight:blue' ctx.shadowblur;20; ctx.shadowcolor;blue></script>"
strBoxEnd = "</tr></table>"
 
eDisc = “This Is Our Email Disclaimer”
eDisc2 = "“This Is Our Email Disclaimer2”
 
strUser = Forms!frmMainMenu!txtLogin
 
FullUser = Split(strUser, " ")
strfName = FullUser(0)
strSign = strUser
 
strUserSign = "<i><font face='Bradley Hand TC' size='4'>" & strSign & "</font></i>"
   
strMSG = "WEEKLY PLANNER.|" & _
    "DMT delivery plans for week commencing " & Format(dtStart, "dddd-dd-mmm-yyyy") & ".|" & _
    "Please note, plans throughout the week may well change.|"
   
myGreet = TOD
 
    strHTML = "<HTML><Body><table border='3' width=auto'><font color='blue' size='3' face='Arial'><tr><th>Day</th><th>Delivery Date</th></th>" & _
        "<th>Driver</th><th>Delivery To (In Order)</th><th>Town</th><th>PostCode</th><tr>"
       
        strBody = strHTML
   
    strSQL = "SELECT tblRoutes.DayName, tblRoutes.Driver, tblRoutes.DelDate, tblRoutes.DelNo, tblRoutes.DelTo, tblRoutes.Town, tblRoutes.PostCode, tblRoutes.ETA, tblRoutes.Source " _
        & "From tblRoutes " _
        & "WHERE (((tblRoutes.DayName)= ""Monday"")) " _
        & "ORDER BY tblRoutes.Driver, tblRoutes.DelDate, tblRoutes.DelNo;"
 
    Set rs = CurrentDb.OpenRecordset(strSQL)
	
   'VLAD -set initial value for sCurrentDriver
	If rs.RecordCOunt>0 Then sCurrentDriver=rs("Driver") 'first record of recordset ordered by driver
	
    Do While Not rs.EOF
		
		If IsNull(rs.Fields("DayName")) Then
			sDayName = "No Date Planned"
		Else
			sDayName = rs.Fields("DayName")
		End If
		
		If sCurrentDriver<>rs("Driver") Then 
			'VLAD driver changed -insert blank line here
		End if
		
		strBody = strBody & "<tr>" & _
			"<td style='background-color:#F5F5F5'>" & strFS & sDayName & strFE & "</td>" & _
			"<td style='background-color:#F8F8FF'>" & strFS & Format(rs.Fields("DelDate"), "dd-mmm-yyyy") & strFE & "</td>" & _
			"<td style='background-color:#F5F5F5'>" & strFS & rs.Fields("Driver") & strFE & "</td>" & _
			"<td style='background-color:#F8F8FF'>" & strFS & rs.Fields("DelTo") & strFE & "</td>" & _
			"<td style='background-color:#F8F8FF'>" & strFS & rs.Fields("Town") & strFE & "</td>" & _
			"<td style='background-color:#F5F5F5'>" & strFS & rs.Fields("PostCode") & strFE & "</td></tr>" & "|"
		sCurrentDriver=rs("Driver") 'Vlad -reset variable
		rs.MoveNext
    Loop
   
    strHTML2 = "<HTML><Body><table border='3' width=auto'><font color='blue' size='3' face='Arial'><tr><th>Day</th><th>Delivery Date</th></th>" & _
        "<th>Driver</th><th>Delivery To (In Order)</th><th>Town</th><th>PostCode</th><tr>"
   
          strBody2 = strHTML2
       
    strSQL2 = "SELECT tblRoutes.DayName, tblRoutes.Driver, tblRoutes.DelDate, tblRoutes.DelNo, tblRoutes.DelTo, tblRoutes.Town, tblRoutes.PostCode, tblRoutes.ETA, tblRoutes.Source " _
        & "From tblRoutes " _
        & "WHERE (((tblRoutes.DayName)= ""Tuesday"")) " _
        & "ORDER BY tblRoutes.Driver, tblRoutes.DelDate, tblRoutes.DelNo;"
       
    Set rs2 = CurrentDb.OpenRecordset(strSQL2)
 
     
	Do While Not rs2.EOF
   
    If IsNull(rs2.Fields("DayName")) Then
        sDayName = "No Date Planned"
    Else
        sDayName = rs2.Fields("DayName")
    End If
   
    strBody2 = strBody2 & "<tr>" & _
        "<td style='background-color:#F5F5F5'>" & strFS & sDayName & strFE & "</td>" & _
        "<td style='background-color:#F8F8FF'>" & strFS & Format(rs2.Fields("DelDate"), "dd-mmm-yyyy") & strFE & "</td>" & _
        "<td style='background-color:#F5F5F5'>" & strFS & rs2.Fields("Driver") & strFE & "</td>" & _
        "<td style='background-color:#F8F8FF'>" & strFS & rs2.Fields("DelTo") & strFE & "</td>" & _
        "<td style='background-color:#F8F8FF'>" & strFS & rs2.Fields("Town") & strFE & "</td>" & _
        "<td style='background-color:#F5F5F5'>" & strFS & rs2.Fields("PostCode") & strFE & "</td></tr>" & "|"
   
   
    rs2.MoveNext
    Loop
   
    strHTML3 = "<HTML><Body><table border='3' width=auto'><font color='blue' size='3' face='Arial'><tr><th>Day</th><th>Delivery Date</th></th>" & _
        "<th>Driver</th><th>Delivery To (In Order)</th><th>Town</th><th>PostCode</th><tr>"
   
          strBody3 = strHTML3
       
    strSQL3 = "SELECT tblRoutes.DayName, tblRoutes.Driver, tblRoutes.DelDate, tblRoutes.DelNo, tblRoutes.DelTo, tblRoutes.Town, tblRoutes.PostCode, tblRoutes.ETA " _
        & "From tblRoutes " _
        & "WHERE (((tblRoutes.DayName)= ""Wednesday"")) " _
        & "ORDER BY tblRoutes.Driver, tblRoutes.DelDate, tblRoutes.DelNo;"
       
    Set rs3 = CurrentDb.OpenRecordset(strSQL3)
 
    Do While Not rs3.EOF
   
    If IsNull(rs3.Fields("DayName")) Then
        sDayName = "No Date Planned"
    Else
        sDayName = rs3.Fields("DayName")
    End If
   
        strBody3 = strBody3 & "<tr>" & _
        "<td style='background-color:#F5F5F5'>" & strFS & sDayName & strFE & "</td>" & _
        "<td style='background-color:#F8F8FF'>" & strFS & Format(rs3.Fields("DelDate"), "dd-mmm-yyyy") & strFE & "</td>" & _
        "<td style='background-color:#F5F5F5'>" & strFS & rs3.Fields("Driver") & strFE & "</td>" & _
        "<td style='background-color:#F8F8FF'>" & strFS & rs3.Fields("DelTo") & strFE & "</td>" & _
        "<td style='background-color:#F8F8FF'>" & strFS & rs3.Fields("Town") & strFE & "</td>" & _
        "<td style='background-color:#F5F5F5'>" & strFS & rs3.Fields("PostCode") & strFE & "</td></tr>" & "|"
   
    rs3.MoveNext
    Loop
   
    strHTML4 = "<HTML><Body><table border='3' width=auto'><font color='blue' size='3' face='Arial'><tr><th>Day</th><th>Delivery Date</th></th>" & _
        "<th>Driver</th><th>Delivery To (In Order)</th><th>Town</th><th>PostCode</th><tr>"
   
          strBody4 = strHTML4
       
    strSQL4 = "SELECT tblRoutes.DayName, tblRoutes.Driver, tblRoutes.DelDate, tblRoutes.DelNo, tblRoutes.DelTo, tblRoutes.Town, tblRoutes.PostCode, tblRoutes.ETA " _
        & "From tblRoutes " _
        & "WHERE (((tblRoutes.DayName)= ""Thursday"")) " _
        & "ORDER BY tblRoutes.Driver, tblRoutes.DelDate, tblRoutes.DelNo;"
       
    Set rs4 = CurrentDb.OpenRecordset(strSQL4)
 
    Do While Not rs4.EOF
    If IsNull(rs4.Fields("DayName")) Then
        sDayName = "No Date Planned"
    Else
        sDayName = rs4.Fields("DayName")
    End If
   
        strBody4 = strBody4 & "<tr>" & _
        "<td style='background-color:#F5F5F5'>" & strFS & sDayName & strFE & "</td>" & _
        "<td style='background-color:#F8F8FF'>" & strFS & Format(rs4.Fields("DelDate"), "dd-mmm-yyyy") & strFE & "</td>" & _
        "<td style='background-color:#F5F5F5'>" & strFS & rs4.Fields("Driver") & strFE & "</td>" & _
        "<td style='background-color:#F8F8FF'>" & strFS & rs4.Fields("DelTo") & strFE & "</td>" & _
        "<td style='background-color:#F8F8FF'>" & strFS & rs4.Fields("Town") & strFE & "</td>" & _
        "<td style='background-color:#F5F5F5'>" & strFS & rs4.Fields("PostCode") & strFE & "</td></tr>" & "|"
   
    rs4.MoveNext
    Loop
   
    strHTML5 = "<HTML><Body><table border='3' width=auto'><font color='blue' size='3' face='Arial'><tr><th>Day</th><th>Delivery Date</th></th>" & _
        "<th>Driver</th><th>Delivery To (In Order)</th><th>Town</th><th>PostCode</th><tr>"
   
    strBody5 = strHTML5
       
    strSQL5 = "SELECT tblRoutes.DayName, tblRoutes.Driver, tblRoutes.DelDate, tblRoutes.DelNo, tblRoutes.DelTo, tblRoutes.Town, tblRoutes.PostCode, tblRoutes.ETA " _
        & "From tblRoutes " _
        & "WHERE (((tblRoutes.DayName)= ""Friday"")) " _
        & "ORDER BY tblRoutes.Driver, tblRoutes.DelDate, tblRoutes.DelNo;"
       
    Set rs5 = CurrentDb.OpenRecordset(strSQL5)
 
    Do While Not rs5.EOF
    If IsNull(rs5.Fields("DayName")) Then
        sDayName = "No Date Planned"
    Else
        sDayName = rs5.Fields("DayName")
    End If
   
    strBody5 = strBody5 & "<tr>" & _
        "<td style='background-color:#F5F5F5'>" & strFS & sDayName & strFE & "</td>" & _
        "<td style='background-color:#F8F8FF'>" & strFS & Format(rs5.Fields("DelDate"), "dd-mmm-yyyy") & strFE & "</td>" & _
        "<td style='background-color:#F5F5F5'>" & strFS & rs5.Fields("Driver") & strFE & "</td>" & _
        "<td style='background-color:#F8F8FF'>" & strFS & rs5.Fields("DelTo") & strFE & "</td>" & _
        "<td style='background-color:#F8F8FF'>" & strFS & rs5.Fields("Town") & strFE & "</td>" & _
        "<td style='background-color:#F5F5F5'>" & strFS & rs5.Fields("PostCode") & strFE & "</td></tr>" & "|"
   
    rs5.MoveNext
    Loop
   
    sFH = "<font size='4' face='Verdana' style=text-align=center; vertical-align=middle>"
    sFHEnd = "</font>"
   
    strEmail = "driver1mail"
    sCC = " driver2mail "
    sCC2 = " driver3mail "
    sCC3 = " driver4mail "
    sCC4 = " driver5mail "
   
    strCCAll = sCC & "; " & sCC2 & " ;" & sCC3 & ": " & sCC4
 
  Set myItem = myApp.CreateItem(olMailItem)
    Set outAccount = myApp.Session.Accounts.item(1)
    With myItem
        .To = strEmail
        .CC = strCCAll
    .Subject = "Week Commencing " & Format(dtStart, "dd-mmm-yyyy")
    .HTMLBody = strFS & myGreet & "<br>" & "<br>" & Replace(strMSG, "|", "<br>" & "<br>") & strFE & "<br>" & "<br>" & _
    sFH & "<B>MONDAY</B>" & sFHEnd & "<br>" & strBoxStart & Replace(strBody, "|", "<br>") & strBoxEnd & "<br>" & _
    sFH & "<B>TUESDAY</B>" & sFHEnd & "<br>" & strBoxStart & Replace(strBody2, "|", "<br>") & strBoxEnd & "<br>" & _
    sFH & "<B>WEDNESDAY</B>" & sFHEnd & "<br>" & strBoxStart & Replace(strBody3, "|", "<br>") & strBoxEnd & "<br>" & _
    sFH & "<B>THURSDAY</B>" & sFHEnd & "<br>" & strBoxStart & Replace(strBody4, "|", "<br>") & strBoxEnd & "<br>" & _
    sFH & "<B>FRIDAY</B>" & sFHEnd & "<br>" & strBoxStart & Replace(strBody5, "|", "<br>") & strBoxEnd & "<br>" & _
    strUserSign & "<br>" & "<br>" & _
    "<P><IMG border=0 hspace=0 alt='' src='file://T:/DMT Ltd/Logo Media/" & SigFile & "' align=baseline></P>" & "<br>" & "<br>" & _
    "<FONT color=#00008B>" & eDisc & "<br>" & "<FONT color =#00008B>" & eDisc2
    .SendUsingAccount = outAccount
    .Display
End With

Cheers,

Add Data From Excel Sheet to Email HTML Body

Thread Tools

Add Data From Excel Sheet to Email HTML Body

Similar Threads

Adding Excel Cells To Email html body

Sending email with Access through Outlook using HTML body

email body using html format

Sending Reports with email body having HTML

Export html to body of email issue

Posting Permissions