Adding Excel Cells To Email html body

[DMT Dave]

Hi Guy's what is the method to add excel cell data to html email body ?

So i have got this far, but how can i add the data (see my code where i have added NEED THIS TO BE EXCEL DATA)

Dim eDisc As String, eDisc2 As String, mySubj As String, SigFile As String, myMonth As StringDim oOutlook As Outlook.Application
Dim oEmailItem As MailItem
Dim rs As DAO.Recordset, rs2 As DAO.Recordset
Dim OutAccount As Outlook.Account
Dim pOpen As String, fOpen As String, fSave As String, pSave As String, a As String, FullName() As String, fName As String
Dim apXL As Object, xlWB As Object


FullName = Split(Forms!frmMainMenu!txtLogin, " ")
fName = FullName(0)


myMonth = Format(Now(), "mm")
    If myMonth <> "12" Then
SigFile = "DMT dave@ Email Signature.jpg"
    Else
SigFile = "DMT Xmas Signature.jpg"
    End If
    
eDisc = "Disclaimer 1
eDisc2 = "Disclaimer 2


pOpen = "T:\DMT Ltd\XL Files\"
fOpen = "Quotation Request" & ".xlsx"
pSave = "T:\DMT Ltd\XL Files\Delivery Quotes\"
fSave = Me.cboCustomer & " " & Me.cboCustomer.Column(5) & " " & Format(Now(), "dd-mm-yy") & ".xlsx"
Set apXL = CreateObject("Excel.Application")
Set xlWB = apXL.Workbooks.Open(pOpen & fOpen)
apXL.ActiveWorkbook.SaveAs pSave & fSave
apXL.Workbooks.Open pSave & fSave, True, False
apXL.Visible = False


With xlWB
.Worksheets(1).Cells(4, 9) = Me.cboCustomer.Column(0)
.Worksheets(1).Cells(5, 9) = Me.cboCustomer.Column(1)
.Worksheets(1).Cells(6, 9) = Me.cboCustomer.Column(2)
.Worksheets(1).Cells(7, 9) = Me.cboCustomer.Column(3)
.Worksheets(1).Cells(8, 9) = Me.cboCustomer.Column(4)
.Worksheets(1).Cells.EntireColumn.AutoFit
.Worksheets(1).Cells.EntireColumn.HorizontalAlignment = xlLeft
.Save
End With




Set oOutlook = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then
Set oOutlook = New Outlook.Application
End If


mySubj = "Delivery Qoutation"
Set oEmailItem = oOutlook.CreateItem(olMailItem)
With oEmailItem
Set OutAccount = oEmailItem.Session.Accounts.Item(1)
    .To = EmailTo
    .subject = mySubj
    .HTMLBody = NEED THIS TO BE EXCEL DATA & "<br>" & "<br>" & _
    KR & "<br>" & "<br>" & _
    fName & "<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
 Set myItem = Nothing
 Set OutAccount = Nothing
 Set myApp = Nothing


xlWB.Close
apXL.Quit
Set apXL = Nothing

[Welshgasman]

Use Table commands to insert the same data?

Here is how I did something similar, except my data came from Access.
THis is the whole code, so pick out the html from it.

Private Sub cmdEmail_Click()
    On Error GoTo Err_Handler
    ' Automate the routine to send notifications of Payments and deposits for clients
    Dim strFilter As String, strClientType As String
    Dim strDate As String, strSQLEmail As String
    Dim strType As String, strClient As String, str3rdID As String, str3rdParty As String, str3rdPartyType As String, strAmount As String, strRef As String, strMethod As String
    Dim strCaseWorker As String, strDatetype As String, strPad As String, strEndPad As String, strPadCol As String, strBlankLine As String, strNotes As String
    Dim strBalance As String, dblBalance As Double
    Dim iColon As Integer, intTransactions As Integer
    Dim lngCurrentRec As Long
    Dim blnDisplayMsg As Boolean, blnSameEmail As Boolean
    Dim db As Database
    Dim rs As DAO.Recordset, rsCW As DAO.Recordset
    Dim blnSameClientType As Boolean


    ' Now the Outlook variables
    Dim objOutlook As Outlook.Application
    Dim objOutlookMsg As Outlook.MailItem
    Dim objOutlookRecip As Outlook.Recipient
    Dim objOutlookAttach As Outlook.Attachment
    Dim strSigPath As String, strSignature As String, strAttachFile As String
    Dim strHeader As String, strFooter As String, strBody As String, strTemplatePath As String, strAppdata As String
    Dim intBody As Integer, intAccount As Integer


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




    On Error GoTo Err_Handler


    'Establish all the static Outlook Data


    ' Get appdata path
    strAppdata = Environ("Appdata")
    
    ' Set paths
    strTemplatePath = strAppdata & "\Microsoft\Templates"
    strSigPath = strAppdata & "\Microsoft\Signatures\Ssafa.htm"
    
    
    'Get the signature if it exists
    If Dir(strSigPath) <> "" Then
        strSignature = GetBoiler(strSigPath)
        intBody = InStr(strSignature, "<div class=WordSection1>")
        'intBody = InStr(strSignature, "<BODY>")
        strHeader = Left(strSignature, intBody + 24) ' 5
        strFooter = Mid(strSignature, intBody + 24) ' 6
    End If


    ' See if Outlook is open, otherwise open it
    'If fIsOutlookRunning = False Then
    Set objOutlook = CreateObject("Outlook.Application")
    'Call OpenOutlook
    'Pause (5)
    ' Else
    'Set objOutlook = GetObject(, "Outlook.Application")
    'End If
    
    ' Make sure we save any changed data and then get recordset
    If Me.Dirty Then Me.Dirty = False
    ' Update the status bar
    SetStatusBar ("Collecting records.....")


    strSQLEmail = "SELECT  Format([TransactionDate],""yyyymmdd"") & Format([ID],""000000"") AS UKey, Emails.*, tblClient.ClientDivision From Emails "
    strSQLEmail = strSQLEmail & "LEFT JOIN tblClient ON Emails.CMS = tblClient.ClientCMS "
    strSQLEmail = strSQLEmail & "WHERE (((Emails.EmailStatus) = 'Yes')) " ' AND (Emails.DelayEmail = False)) "
    'strSQLEmail = strSQLEmail & "ORDER BY Emails.Client, Emails.TranType, Emails.ID, Emails.TransactionDate;"
    strSQLEmail = strSQLEmail & "ORDER BY Emails.Client, Emails.TranType, Format([TransactionDate],""yyyymmdd"") & Format([ID],""000000"") ;"


    ' Create the Outlook session.
    'Set objOutlook = GetObject(, "Outlook.Application")
    'Set objOutlook = New Outlook.Application
    
    ' Open lookup table for Email CC Name (normally a Case Worker)
    Set db = CurrentDb
    Set rsCW = db.OpenRecordset("SELECT * from Lookups WHERE DataType = 'Email' AND DeActiveDate IS NULL")
    ' Save the current record position
    lngCurrentRec = Me.CurrentRecord
    ' Now get the data for the emails
    Set rs = db.OpenRecordset(strSQLEmail)
    
    ' Now set the filter to get just the rows we want
    ' strFilter = "Yes"
    
    ' Me.Filter = "EmailStatus = """ & strFilter & """"
    'Me.FilterOn = True


    ' Check we have some records to process
    If rs.RecordCount = 0 Then
        MsgBox "No records to process?", vbOKOnly, "Send Emails"
        Exit Sub
    End If
    ' OK, we are good so send the emails.


    ' Decide whether to display or just send emails
    blnDisplayMsg = Me.chkDisplay


    'Set rs = Me.RecordsetClone
    rs.MoveFirst


    SetStatusBar ("Creating Emails.....")
    ' Now walk through each record
    Do While Not rs.EOF
        ' Set flag and field to check
        blnSameClientType = True
        strClientType = rs!Client & rs!TranType
        strType = rs!TranType
        
        ' Create the message if first time we are in a different client or tran type.
        'Set objOutlookMsg = objOutlook.CreateItemFromTemplate(strTemplatePath & "\SSAFA Email.oft")
        Set objOutlookMsg = objOutlook.CreateItemFromTemplate(strTemplatePath & "\SSAFA Email.oft")
        With objOutlookMsg
            ' Set the category
            .Categories = "SSAFA"
            .Importance = olImportanceHigh
            ' Add the To recipient(s) to the message. (Also work out which account to send on 12/07/19)
            If rs!ClientDivision = "SSW" Then
                Set objOutlookRecip = .Recipients.Add("Jim Needs - Personal")
                objOutlookRecip.Type = olTo
                intAccount = 2
            Else
'                Set objOutlookRecip = .Recipients.Add("SSAFA West Glamorgan Branch")
                Set objOutlookRecip = .Recipients.Add("South West Wales SSAFA")
                objOutlookRecip.Type = olTo
                intAccount = 3
            End If
    ' Need to send using SSAFA 365 int = 15
            'intAccount = 15
            ' Add the CC recipient(s) to the message.
            If rs!CCOffice And rs!ClientDivision = "SSW" Then
'                Set objOutlookRecip = .Recipients.Add("SSAFA West Glamorgan Branch")
                Set objOutlookRecip = .Recipients.Add("South West Wales SSAFA")
                objOutlookRecip.Type = olCC
            End If
            
            ' Need to get the Case Worker name from table, might be deactivated, so not in recordset
            If rs!CaseWorker > 0 Then
                rsCW.FindFirst "[ID] = " & rs!CaseWorker
                If rsCW.NoMatch Then
                    strCaseWorker = ""
                Else
                    strCaseWorker = rsCW!Data
                End If
            Else
                strCaseWorker = ""
            End If


            If strCaseWorker <> "" Then
                Set objOutlookRecip = .Recipients.Add(strCaseWorker)
                objOutlookRecip.Type = olCC
            End If
            
            ' Add Glyn in as BCC for CMS update - 12/02/19
            ' Only if SSW and he is not the caseworker
            If rs!ClientDivision = "SSW" And strCaseWorker <> "Glyn Davies" Then
                Set objOutlookRecip = .Recipients.Add("Glyn Davies")
                objOutlookRecip.Type = olBCC
            End If


            
            ' Set the Format, Subject, Body, and Importance of the message.
            '.BodyFormat = olFormatHTML
            strClient = rs!Client




            If strType = "Payment" Then
                .Subject = " Payment Made - " & strClient
            Else
                .Subject = "Deposit Received - " & strClient
            End If
            ' Now start the email with header
            'iColon = InStr(strClient, ":")
            ' If iColon = 0 Then iColon = Len(strClient) + 1
            .HTMLBody = strHeader & "<table border = '0' cellpadding = '5' cellspacing = '5'>"
            '    .HTMLBody = .HTMLBody & "<td>" & "Client: " & strPadCol & Left(strClient, iColon - 1) & strEndPad
            'End If
            ' Set counter to zero for count of transactions
            intTransactions = 0
        End With


        Do While blnSameClientType
            strDate = rs!TransactionDate
            strType = rs!TranType
            str3rdParty = rs!ThirdParty
            strAmount = Format(rs!Amount, "Currency")
            'strBalance = Format(rs!Balance, "Currency")
            'strBalance = Format(DSum("Amount", "Emails", "CMS = " & rs!CMS & " AND ID <= " & rs!ID), "Currency")
            ' Now using unique key Ukey to get correct running balance for entries out of sequence
            dblBalance = DSum("Amount", "Emails", "CMS = " & rs!CMS & " AND format(TransactionDate,'yyyymmdd')& format(ID,'000000') <= '" & rs!Ukey & "'")
            strBalance = Format(dblBalance, "Currency")
            ' Missed in sequence dates was producing erroneous balances 240620
            'strBalance = Format(Nz(DSum("Amount", "Emails", "CMS = " & [CMS] & " AND ID <=" & [ID]), 0), "Currency")
            'Now Calculated on the fly
            'strBalance = Format(rs!Balance, "Currency") ' was Format(DSum("[Amount]", "Emails", "[CMS]=" & rs!CMS & " AND ID <= " & rs!ID), "Currency")
            
            ' Make strBalance Red if negative
            If dblBalance < 0 Then
                strBalance = "<font color=""Red"">" & strBalance & "</font>"
            End If
            
            strRef = rs!Reference
            strMethod = rs!Method
            
            'strDatetype = "Date "
            If strType = "Payment" Then
                str3rdPartyType = "Recipient:"
                strDatetype = "Date Paid:"
            Else
                str3rdPartyType = "From Donor:"
                strDatetype = "Received:"
            End If


            strNotes = Nz(rs!Notes, "")
        
        
            ' Now build the body of the message
            
            ' Make sure we have a colon in client, else use whole field
            
            ' 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
            
            'Now update the record
            rs.Edit
            rs!EmailStatus = "Sent"
            rs!EmailDate = Date
            rs.Update


            ' Now get next record
            rs.MoveNext
            ' Has client or tran type changed?
            If Not rs.EOF Then
                If strClientType = rs!Client & rs!TranType Then
                    blnSameClientType = True
                Else
                    blnSameClientType = False
                End If
            Else
                blnSameClientType = False
            End If
            ' Increment the counter
            intTransactions = intTransactions + 1
        Loop                                     ' End blnClientType loop
        
        ' Now add the footer and amend subject to indicate how many transactions in email
        With objOutlookMsg
            .Subject = .Subject & " - " & intTransactions & " " & strType
            If intTransactions > 1 Then
                .Subject = .Subject & "s"
            End If
            
            ' Need to amend the footer depending on account being used intAccount = 2 = SSW, 3 is NPT
            If intAccount = 3 Then
                strFooter = Replace(strFooter, "Divisional Treasurer, Swansea South &amp; West", "Temporary Divisional Treasurer, Neath &amp; Port Talbot")
            End If
            
            ' Now add the footer
            .HTMLBody = .HTMLBody & "</table>" & strFooter
            '.Importance = olImportanceHigh  'High importance
            'Debug.Print strHeader
            'Debug.Print .htmlbody
            'Debug.Print strFooter
            ' Resolve each Recipient's name.
            For Each objOutlookRecip In .Recipients
                'Debug.Print objOutlookRecip.Name
                objOutlookRecip.Resolve
            Next
    
            ' Should we display the message before sending?
            .SendUsingAccount = objOutlook.Session.Accounts.Item(intAccount)
            If blnDisplayMsg Then
                .Display
            Else
                .Save
                .Send
            End If
        End With
    
            
    Loop
    ' Switch off the filter and release recordset object, and go back to record we were on
    ' Me.FilterOn = False
    SetStatusBar ("Emails created.....")
    DoCmd.GoToRecord , , acGoTo, lngCurrentRec
    cmdRequery_Click
Proc_Exit:
    Set objOutlook = Nothing
    Set objOutlookMsg = Nothing
    Set objOutlookRecip = Nothing
    Set objOutlookAttach = Nothing
    Set rs = Nothing
    Set rsCW = Nothing
    Set db = Nothing
    SetStatusBar (" ")
    Exit Sub
    
Err_Handler:
    MsgBox Err.Number & " " & Err.Description
    Resume Proc_Exit






End Sub


Function GetBoiler(ByVal sFile As String) As String
    'Dick Kusleika
    Dim fso As Object
    Dim ts As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
    GetBoiler = ts.ReadAll
    ts.Close
    Set fso = Nothing
    Set ts = Nothing
End Function

[June7]

So you set some cells in Excel with values from Access combobox and then need to pull more data from the Excel worksheet? Options:

1. set a link to the Excel sheet and open recordset from linked table, loop recordset

2. Excel automation to loop through cells

3. Excel automation to open a recordset of sheet range, loop through recordset

4. Excel automation to programmatically copy/paste range to email, review VBA to copy/paste from Excel to Outlook - Microsoft Community

[DMT Dave]

Thank you guy's, my target is to save a quotation in excel (potentially open to adjust at later date if required)

Then grab cells data from it to html email

I guess it's easier to just attach file to email but would rather display on mail body

Not looked at your suggestions yet but did think afterwards can i not string the xl lines such as:

Dim strA = xlwb.worksheets.cells etc & "|" & _
xlwb.worksheets.cells NEXT CELL etc & "|"

html.body = Replace(strA,"|","<br>")

Going to look through your suggestions,

lastly, is it possible to border this (Outline in htmlbody) ?

[Welshgasman]

Perhaps try a Copy and Paste?
https://www.google.com/search?q=past...hrome&ie=UTF-8

[June7]

To show a border could build HTML table. Example

        body = "<table style='text-align:right;border:1px solid black;font-family:calibri;border-collapse:collapse;padding:15px'><tr style='background:yellow;mso-highlight:yellow'>" & _            "<th>No</th><th>Client</th><th>Date</th><th>PR</th><th>Currency</th><th>Amt</th></tr>" & _
            "<tr><td>12345</td><td>Jones</td><td>12Dec2017</td><td>ABC</td><td>US</td><td>2000</td></tr>" & _
            "<tr><td>67890</td><td>Smith</td><td>12Dec2017</td><td>ABC</td><td>US</td><td>1000</td></tr></table>"

I tested manual copy/paste and cell border formatting did carry over so I expect programmatic copy/paste would as well.

[DMT Dave]

brilliant guys thank you very much, i will play around

Managed to get the data into html by simply using the following

Dim strBody as String

strBody = xlWB.WorkSheets(1).Cells(4, 9) & "|" & _
xlWB.WorkSheets(1).Cells(45 9) & "|" & _
etc.....

Then

.HTMLBody = Replace(strBody,"|","<br>")

That has added data from teh selected cells

will play around with those borders

Thanks again guys

[DMT Dave]

Hi June7, totally fantastic, I have adapted some of your suggestion this borders the full email, where in the html body can I just have the strBody and strBody2 within the table (outlined) ?

So that the wkr (With Kind Regards), User, Signature is outside of the table ?

The below code borders the full email so if you could kind advise/adjust where in the html would be fantastic

adjusted code

.HTMLBody = "<table style='text-align:left;border:1px solid black;font-family:calibri;border-collapse:collapse;padding:15px'><tr style='background:white;mso-highlight:black'>" & _    Replace(strBody, "|", "<br>") & Replace(strBody2, "|", "<br>") & "<br>" & "<br>" & _
    wkr & "<br>" & "<br>" & _
    fName & "<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

[DMT Dave]

Thanks you all

[June7]

Not seeing closing </tr> and </table> tags.

[DMT Dave]

Hi June7, Where in my code would i add that ?

I am going to runt through your code and see what you have done but if i can add data within the table and leave closing lines (wkr) and user and signature outside after the table would be great

I think i need to learn more about tags but if you can advise/adjust where i can achieve this would be greatly appreciated

[DMT Dave]

OK June7, where I have changed to black at the end of the code, i need to add the closing as you mentioned...

I have to keep logging into work as the db isn't on my machine so i am going to log in and read through what you have done but my main target is to have the strBody data only inside of the borders (table)

[Welshgasman]

You add them where you want the border to stop?

[DMT Dave]

Great stuff guy's thank you all so much, yes just realised, added to after my replace strbody but before my next line for wkr and user and signature

Thats has done it, i am going read through yours and June7 code and try to understand it as much as i can ie: can i now change colour of table border

[Welshgasman]

Here is a clue Dave.
What colour is the border?
When you find that out, look for that colour in the code.