Attaching a document in Email body

[Raynepau]

Hello Can anyone help with the following

I have found and used some code below (Although I do not fully understand it) that opens an email and creates a table in the body of an email. As you can see below one of the columns of the table contains the file path of a document. Instead of seeing the file path I would actually like to attach the document and not show the file path in the table so any help with this would be appreciated or of course if there is an easier way of achieving this. Please note I am not an expert so any help, explained in simple terms would be good.

An example of the information in the table is as follows

Buiding Description Attached Document
MLFC (MLFC) Work C:\Working\5CS Escalation2.vsd

And here is the code

Private Sub EMAIL_COST_AUTHORISATION_FOR_MANAGERS_APPROVAL_Click()
On Error GoTo Err_EMAIL_COST_AUTHORISATION_FOR_MANAGERS_APPROVAL_Click

Me.Dirty = False

Dim olApp As Outlook.Application
Dim objMail As Outlook.MailItem
Dim strMsg As String
Dim sqlString As String
Dim i As Integer
Dim rowColor As String

Dim rs As ADODB.Recordset
Set rs = New ADODB.Recordset
sqlString = "SELECT [Email Vendor2 Table].*From [Email Vendor2 Table] "

'sqlString = "SELECT * FROM " & Month2 & ""

rs.Open sqlString, CurrentProject.Connection, adOpenKeyset, adLockOptimistic

strMsg = "<table border='1' cellpadding='3' cellspacing='3' style='border-collapse: collapse' bordercolor='#111111' width='800'>" & _
"<tr>" & _
"<td bgcolor='#7EA7CC'>&nbsp;<b>Buiding</b></td>" & _
"<td bgcolor='#7EA7CC'>&nbsp;<b>Raised By</b></td>" & _
"<td bgcolor='#7EA7CC'>&nbsp;<b>Description</b></td>" & _
"<td bgcolor='#7EA7CC'>&nbsp;<b>Attached Document</b></td>" & _
"<td bgcolor='#7EA7CC'>&nbsp;<b>Total Cost</b></td>" & _
"</tr>"

i = 0
Do While Not rs.EOF

If (i Mod 2 = 0) Then
rowColor = "<td bgcolor='#FFFFFF'>&nbsp;"
Else
rowColor = "<td bgcolor='#E1DFDF'>&nbsp;"
End If

strMsg = strMsg & "<tr>" & _
rowColor & rs.Fields("Building") & "</td>" & _
rowColor & rs.Fields("Raised By") & "</td>" & _
rowColor & rs.Fields("Description") & "</td>" & _
rowColor & rs.Fields("Attached Document") & "</td>" & _
rowColor & rs.Fields("Total Cost") & "</td>" & _
"</tr>"

rs.MoveNext
i = i + 1
Loop

strMsg = strMsg & "Dear x and x, please see below, a Spend Authorisation Requiring Your Approval. Can you please approve by return of email" & "</table>"

Set olApp = Outlook.Application
Set objMail = olApp.CreateItem(olMailItem)
With objMail
.BodyFormat = olFormatHTML
.HTMLBody = strMsg
.Recipients.Add "user@email.com"
.Subject = "Cost Authorisation Approval Required"
'.Send if you want to send it directly without displaying on screen
.Display
End With
Set olApp = Nothing
Set objMail = Nothing

Exit_EMAIL_COST_AUTHORISATION_FOR_MANAGE:
Exit Sub
Err_EMAIL_COST_AUTHORISATION_FOR_MANAGERS_APPROVAL_Click:
MsgBox Err.Description
Resume Exit_EMAIL_COST_AUTHORISATION_FOR_MANAGE
End Sub

 

[GComyn]

I've looked at your code, and this is what I came up with to do what you wanted. The only changes was to move some lines closer to the top of the code, and add one line.

Private Sub EMAIL_COST_AUTHORISATION_FOR_MANAGERS_APPROVAL_Click()
On Error GoTo Err_EMAIL_COST_AUTHORISATION_FOR_MANAGERS_APPROVAL_Click

    Me.Dirty = False
    
    Dim olApp As Outlook.Application
    Dim objMail As Outlook.MailItem
    Dim strMsg As String
    Dim sqlString As String
    Dim i As Integer
    Dim rowColor As String
    
    Dim rs As ADODB.Recordset
    Set rs = New ADODB.Recordset
    sqlString = "SELECT [Email Vendor2 Table].*From [Email Vendor2 Table] "
    
    'sqlString = "SELECT * FROM " & Month2 & ""
    
    rs.Open sqlString, CurrentProject.Connection, adOpenKeyset, adLockOptimistic

    'Moved These Lines
    '----
    Set olApp = Outlook.Application
    Set objMail = olApp.CreateItem(olMailItem)
    With objMail
        .BodyFormat = olFormatHTML
        .Recipients.Add "user@email.com"
        .Subject = "Cost Authorisation Approval Required"
    '----        

        strMsg = "<table border='1' cellpadding='3' cellspacing='3' style='border-collapse: collapse' bordercolor='#111111' width='800'>" & _
        "<tr>" & _
        "<td bgcolor='#7EA7CC'>&nbsp;<b>Buiding</b></td>" & _
        "<td bgcolor='#7EA7CC'>&nbsp;<b>Raised By</b></td>" & _
        "<td bgcolor='#7EA7CC'>&nbsp;<b>Description</b></td>" & _
        "<td bgcolor='#7EA7CC'>&nbsp;<b>Attached Document</b></td>" & _
        "<td bgcolor='#7EA7CC'>&nbsp;<b>Total Cost</b></td>" & _
        "</tr>"
        
        i = 0
        Do While Not rs.EOF
            If (i Mod 2 = 0) Then
            rowColor = "<td bgcolor='#FFFFFF'>&nbsp;"
            Else
            rowColor = "<td bgcolor='#E1DFDF'>&nbsp;"
            End If
            
            strMsg = strMsg & "<tr>" & _
            rowColor & rs.Fields("Building") & "</td>" & _
            rowColor & rs.Fields("Raised By") & "</td>" & _
            rowColor & rs.Fields("Description") & "</td>" & _
            rowColor & rs.Fields("Attached Document") & "</td>" & _
            rowColor & rs.Fields("Total Cost") & "</td>" & _
            "</tr>"
            .Attachments.Add rs.Fields("Attached Document") 'added line
        
            rs.MoveNext
            i = i + 1
        Loop
        
        strMsg = strMsg & "Dear x and x, please see below, a Spend Authorisation Requiring Your Approval. Can you please approve by return of email" & "</table>"
        
        .HTMLBody = strMsg
        '.Send if you want to send it directly without displaying on screen
        .Display
    End With
    Set olApp = Nothing
    Set objMail = Nothing
    
Exit_EMAIL_COST_AUTHORISATION_FOR_MANAGE:
    Exit Sub
Err_EMAIL_COST_AUTHORISATION_FOR_MANAGERS_APPROVAL_Click:
    MsgBox Err.Description
    Resume Exit_EMAIL_COST_AUTHORISATION_FOR_MANAGE
End Sub

Now, I didn't test this, so it may need some tweeking, but, as far as you know, it should work.

Hope this helps

GComyn

 

[Raynepau]

That's excellent

Many thanks

 

[Raynepau]

Hi GComyn

I've tried you suggestion and now have the following problem in that I get the following message "Object doesn't support this property or method"

I have stepped through the code and get this error message with the added line. I have copied the relevant section of the code below. For reference the line causing the problem is;
.Attachments.Add rs.Fields("Hyperlink2")

Hyperlink2 is the name of the field in the table which contains the file path. I assume it's some sor to f string problem but not sure how to correct it

Again thanks for your help and relevant code is below

Do While Not rs.EOF
If (i Mod 2 = 0) Then
rowColor = "<td bgcolor='#FFFFFF'>&nbsp;"
Else
rowColor = "<td bgcolor='#E1DFDF'>&nbsp;"
End If

strMsg = strMsg & "<tr>" & _
rowColor & rs.Fields("Building") & "</td>" & _
rowColor & rs.Fields("Budget Year") & "</td>" & _
rowColor & rs.Fields("Full Description") & "</td>" & _
rowColor & rs.Fields("Hyperlink2") & "</td>" & _
rowColor & rs.Fields("Total Cost") & "</td>" & _
"</tr>"

.Attachments.Add rs.Fields("Hyperlink2") 'added line

rs.MoveNext
i = i + 1
Loop