Add Attachment to Email in VBA (1 Viewer)

[Paul Ager]

Hi Guys,

Background - I want to send an email/s to various recipents email addresses based on a query result. I've created separate queries for each month but ideally would like to set the parameters to choose a month within the code, however although i cant find anything to do this yet the code below lets me send an email based on the query result for a single month. This is working great at the mo, but I now need to send an attachment with the email. I'd really appreciate it if someone would cast their eye over the code listed below and see if they can find a solution.

Private Sub email_attached_Click()

Dim MyDb As DAO.Database
Dim rsEmail As DAO.Recordset
Dim qdf As DAO.QueryDef
Dim prm As DAO.Parameter
Dim sToName As String
Dim sSubject As String
Dim sMessageBody As String

Set MyDb = CurrentDb

Set qdf = MyDb.QueryDefs("qryrecipients_emails_mar11")
For Each prm In qdf.Parameters
prm.Value = Eval(prm.Name)
Next

Set rsEmail = qdf.OpenRecordset()

With rsEmail
.MoveFirst
Do Until rsEmail.EOF
If IsNull(.Fields(0)) = False Then
sToName = .Fields(0)
sSubject = "See Attachment"
sMessageBody = "Hi," & vbCrLf & vbCrLf & "Please see attached." & vbCrLf & vbCrLf & "Regards," & vbCrLf & vbCrLf & "Paul"

DoCmd.SendObject acSendNoObject, , , sToName, , , sSubject, sMessageBody, False, False
End If
.MoveNext
Loop
End With

Set MyDb = Nothing
Set rsEmail = Nothing
End Sub

Many thanks for looking.

Regards,

Paul

 

[NigelShaw]

Hi Paul,

without checking for accuracy, i would guess -

Dim sAttachment As String
'Make attachment a string because it is the path being attached
 
aAttachment = "C:\MyAttachmentPath\"
 
.Attachment = sAttachment

Cheers

Nigel

p.s. if you highlight your code in future and then click # hash button above, it will highlight the code as mine is displayed

 

[darbid]

Hi Paul,

MSaccess' SendObject method does not have an attachment part built in. You are going to have to use the outlook object model yourself instead of access doing it for you. There are lots of examples on this.

Once you get the general email code set up, I have specifically on your attachments part added some help.

You can add a number of attachments to an email, thus it is a little different to what you might be thinking. You have an array of attachments eg Attachment(X).

http://msdn.microsoft.com/en-gb/library/aa210902(office.11).aspx

The Add method is explained like this

Creates a new attachment in the Attachments collection and returns the new attachment as an Attachment object.
expression.Add(Source, Type, Position, DisplayName)
expression Required. An expression that returns an Attachments collection object.
Source Required String. The source of the attachment.
Type Optional String. The type of the attachment.
Position Optional String. In e-mail messages using Microsoft Outlook Rich Text format, position where the attachment should be placed. A value of 1 for the Position parameter specifies that the attachment should be positioned at the beginning of the message body. A value 'n' greater than the number of characters in the body of the e-mail item specifies that the attachment should be placed at the end. A value of 0 makes the attachment hidden.
DisplayName Optional String. This name is displayed in an Inspector object for the attachment if the mail item is in Rich Text format. If the mail item is in Plain Text or HTML format, then the attachment is displayed using the name in the Source parameter.

Set myOlApp = CreateObject("Outlook.Application")
Set myItem = myOlApp.CreateItem(olMailItem)
Set myAttachments = myItem.Attachments
myAttachments.Add "C:\My Documents\Q496.xls", _
    olByValue, 1, "4th Quarter 1996 Results Chart"

Feel free to post your code on this if you have any questions.

 

[Paul Ager]

Thanks for the replies guys, but I'm still having problems. I've managed to get some code to send an attachment with an email, but now want to try and merge the 2 pieces of code together if thats possible? Please below.

Private Sub email_exp1_Click()
Dim MyDb As DAO.Database
Dim rsEmail As DAO.Recordset
Dim qdf As DAO.QueryDef
Dim prm As DAO.Parameter
Dim strEmail As String
Dim strMsg As String
Dim oLook As Object
Dim oMail As Object
Set MyDb = CurrentDb
Set qdf = MyDb.QueryDefs("qryexp_may11")
For Each prm In qdf.Parameters
prm.Value = Eval(prm.Name)
Next
Set rsEmail = qdf.OpenRecordset()
With rsEmail
        .MoveFirst
        Do Until rsEmail.EOF
            If IsNull(.Fields(0)) = False Then
 
Set oLook = CreateObject("Outlook.Application")
Set oMail = oLook.createitem(0)
With oMail
.to = .Fields(0)
.body = "See attached"
.Subject = "This has an attachment"
.Attachments.Add ("C://myattachment.doc")
.Send
End If
.MoveNext
Loop
End With
Set oMail = Nothing
Set oLook = Nothing
End Sub

I'm still getting grips with all this so the above code may just be a complete mess! Any help would be appreciated!

 

[darbid]

looks good. But have you tried this code. You would see a major problem. the CreateObject is in your loop which means you would have many many outlooks opening.

Also does this work as a path in Windows? ("C://myattachment.doc")

 

[Paul Ager]

Thanks. The link was just an example and I pressed the wrong slash. I realised afterwards what I'd done. I was hoping no one would notice lol.

Yes I have run the code and get a Compile Error: 'End If without block If'. New one to me.

 

[darbid]

I used to hate cleaning my room. But generally when it is clean I can find things. In coding it is even more important to get a good system from the beginning. That is up to you.

So if you set out your code like this does it help you to find the problem

Private Sub email_exp1_Click()
'Need to add some error catching

Dim MyDb As DAO.Database
Dim rsEmail As DAO.Recordset
Dim qdf As DAO.QueryDef
Dim prm As DAO.Parameter
Dim strEmail As String
Dim strMsg As String
Dim oLook As Object
Dim oMail As Object

Set MyDb = CurrentDb
Set qdf = MyDb.QueryDefs("qryexp_may11")

For Each prm In qdf.Parameters
    prm.Value = Eval(prm.Name)
Next

Set rsEmail = qdf.OpenRecordset()

With rsEmail
    .MoveFirst
    Do Until rsEmail.EOF
        If IsNull(.Fields(0)) = False Then
        
            Set oLook = CreateObject("Outlook.Application") 'this cannot be here cause it is in the loop
            Set oMail = oLook.createitem(0)
            With oMail
                .to = .Fields(0)
                .body = "See attached"
                .Subject = "This has an attachment"
                .Attachments.Add ("C://myattachment.doc")  'This path need correcting
                .Send
        End If
                .MoveNext
    Loop
End With

Set oMail = Nothing
Set oLook = Nothing

End Sub

 

[Paul Ager]

Thanks darbid that makes sense however I still get the compile error End If without block If even after a few changes see below. Please forgive me if a make some silly errors I'm still getting used to VBA.

[FONT=Tahoma][FONT=Tahoma]Private Sub email_exp1_Click()[/FONT]
[FONT=Tahoma]On Error GoTo Err_email_exp1_Click[/FONT]
 
[FONT=Tahoma]Dim MyDb As DAO.Database[/FONT]
[FONT=Tahoma]Dim rsEmail As DAO.Recordset[/FONT]
[FONT=Tahoma]Dim qdf As DAO.QueryDef[/FONT]
[FONT=Tahoma]Dim prm As DAO.Parameter[/FONT]
[FONT=Tahoma]Dim strEmail As String[/FONT]
[FONT=Tahoma]Dim strMsg As String[/FONT]
[FONT=Tahoma]Dim oLook As Object[/FONT]
[FONT=Tahoma]Dim oMail As Object[/FONT]
 
[FONT=Tahoma]Set MyDb = CurrentDb[/FONT]
[FONT=Tahoma]Set qdf = MyDb.QueryDefs("qryexp_may11")[/FONT]
 
[FONT=Tahoma]For Each prm In qdf.Parameters[/FONT]
[FONT=Tahoma]   prm.Value = Eval(prm.Name)[/FONT]
[FONT=Tahoma]Next[/FONT]
 
[FONT=Tahoma]Set rsEmail = qdf.OpenRecordset()[/FONT]
[FONT=Tahoma]Set oLook = CreateObject("Outlook.Application")[/FONT]
 
[FONT=Tahoma]With rsEmail[/FONT]
[FONT=Tahoma]       .MoveFirst[/FONT]
[FONT=Tahoma]       Do Until rsEmail.EOF[/FONT]
[FONT=Tahoma]           If IsNull(.Fields(0)) = False Then[/FONT]
 
[FONT=Tahoma]               'Set oMail = oLook.createitem(0)[/FONT]
[FONT=Tahoma]               With oMail[/FONT]
[FONT=Tahoma]                   .to = .Fields(0)[/FONT]
[FONT=Tahoma]                   .body = "See attached"[/FONT]
[FONT=Tahoma]                   .Subject = "Has this got an attachment"[/FONT]
[FONT=Tahoma]                   .Attachments.Add ("\\my_network\network_folder\my attachment.doc")[/FONT]
[FONT=Tahoma]                   .Send[/FONT]
[FONT=Tahoma]           End If[/FONT]
[FONT=Tahoma]                   .MoveNext[/FONT]
[FONT=Tahoma]Loop[/FONT]
[FONT=Tahoma]End With[/FONT]
 
[FONT=Tahoma]Set oMail = Nothing[/FONT]
[FONT=Tahoma]Set oLook = Nothing[/FONT]
 
[FONT=Tahoma]Err_email_exp1_Click:[/FONT]
[FONT=Tahoma]   MsgBox Err.Description[/FONT]
[FONT=Tahoma]   Resume Exit_email_exp1_Click[/FONT]
 
[FONT=Tahoma]End Sub[/FONT]
[/FONT]

 

[darbid]

with oMail

 

[Paul Ager]

Re: Add Attachment to Email in VBA - SOLVED!

Eureka! Thanks for your help darbid, please see working code below

Private Sub email_exp1_Click()
 
Dim MyDb As DAO.Database
Dim rsEmail As DAO.Recordset
Dim qdf As DAO.QueryDef
Dim prm As DAO.Parameter
Dim strEmail As String
Dim strMsg As String
Dim oLook As Object
Dim oMail As Object
Set MyDb = CurrentDb
Set qdf = MyDb.QueryDefs("qryexp_may11")
For Each prm In qdf.Parameters
    prm.Value = Eval(prm.Name)
Next
Set rsEmail = qdf.OpenRecordset()
Set oLook = CreateObject("Outlook.Application")
With rsEmail
        .MoveFirst
        Do Until rsEmail.EOF
        myRecipient = .Fields(0)
            If IsNull(myRecipient) = False Then
                Set oLook = CreateObject("Outlook.Application")
                Set oMail = oLook.createitem(0)
                With oMail
                    .to = myRecipient
                    .body = "See attached"
                    .Subject = "Test Email"
                    .Attachments.Add ("\\mynetwork\mynetworkfolder\test.doc")
                    .Send
                End With
            End If
                    .MoveNext
        Loop
End With
Set oMail = Nothing
Set oLook = Nothing
End Sub

Thanks again!

 

[darbid]

your welcome - and there is a little thanks button you can click.