Adding Attachment to Code to send an Email Message

  • Thread starter Thread starter MS Access Question
  • Start date Start date
M

MS Access Question

I am trying to send an automated email message with an MS Word attachment
using MS Access and MS Outlook. Everything works fine until I use the
Attachment.Add command, I get an error message "Cannot write to file..."
I am not trying to write a file, I am merely trying to attach an existing
file... any thoughts?

Option Compare Database
Option Explicit

Private Sub cmdMerge_Click()
On Error GoTo Err_cmdMerge_Click

Dim db As DAO.Database, rst As DAO.Recordset
Dim First As String
Dim Email As String
Set db = CurrentDb
Set rst = db.OpenRecordset("qry_JobContactMerge")
DoEvents

rst.MoveFirst

Do Until rst.EOF
First = rst![FIRSTNAME]

DoEvents

Call SendEmail(Email, First)

Me.TxtProcess = rst![EMAILName]

rst.MoveNext
Loop



Exit_cmdMerge_Click:
Exit Sub

Err_cmdMerge_Click:
MsgBox Err.Description
Resume Exit_cmdMerge_Click

End Sub



Private Sub cmdQuit_Click()
On Error GoTo Err_cmdQuit_Click

If Me.Dirty Then Me.Dirty = False
DoCmd.Quit

Exit_cmdQuit_Click:
Exit Sub

Err_cmdQuit_Click:
MsgBox Err.Description
Resume Exit_cmdQuit_Click

End Sub


'******begin code*****
Function SendEmail(Email As String, First As String)
Dim strEmail, strBody As String
Dim objOutlook As Outlook.Application
Dim objEmail As Outlook.MailItem

'**creates an instance of Outlook
Set objOutlook = CreateObject("Outlook.application")
Set objEmail = objOutlook.CreateItem(olMailItem)

'**************************************************************
'*create string with email address

strEmail = EMAIL

'strBody = txtTDate & Chr(13) & Chr(13)
strBody = strBody & "Hello " & First & "," & Chr(13) & Chr(13)
strBody = strBody & "Thank you for your recent correspondence." & Chr(13)
strBody = strBody & "Sincerely," & Chr(13) & Chr(13)

'***creates and sends email
With objEmail
.To = strEmail
.SUBJECT = "My Document is attached"
.body = strBody
.Attachments.Add ("C:\Users\John\Documents\MSWordDoc2003Format.doc")
'add attachment
.Send
End With


Set objEmail = Nothing
objOutlook.Quit

Exit Function

End Function
'****end code*****
 
Here is some code I have used:
I choose to use "display" rather than "send" so the email can be inspected
before sending.
This requires the a reference to a Microsoft Outlook Object Library. While
in code click Tools...references and find the latest one in the list.

Private Sub cmdSendEmail_Click()
On Error GoTo MyError
Dim myOL, myNewMessage, strMyPath As String
Set myOL = New Outlook.Application
Set myNewMessage = myOL.CreateItem(olMailItem)
With myNewMessage
.Subject = "Subject Text"
.Body = "Subject Text"
.To = "Target Email Address"

strMyPath = "The path to my file" ' as in "C:\My Documents\MyFile.doc"

.Attachments.Add strMyPath, olByValue
.Display

End With

Exit Sub
MyError:
Application.Echo True
Re = vbNo
Re = MsgBox(Err.Number & " " & Err.Description _
& Chr(13) & "Would you like to continue?", vbYesNo, " Send Email ")
If Re = vbYes Then Resume Next
DoCmd.SetWarnings True

End Sub

--
Never stop learning, never stop helping.


MS Access Question said:
I am trying to send an automated email message with an MS Word attachment
using MS Access and MS Outlook. Everything works fine until I use the
Attachment.Add command, I get an error message "Cannot write to file..."
I am not trying to write a file, I am merely trying to attach an existing
file... any thoughts?

Option Compare Database
Option Explicit

Private Sub cmdMerge_Click()
On Error GoTo Err_cmdMerge_Click

Dim db As DAO.Database, rst As DAO.Recordset
Dim First As String
Dim Email As String
Set db = CurrentDb
Set rst = db.OpenRecordset("qry_JobContactMerge")
DoEvents

rst.MoveFirst

Do Until rst.EOF
First = rst![FIRSTNAME]

DoEvents

Call SendEmail(Email, First)

Me.TxtProcess = rst![EMAILName]

rst.MoveNext
Loop



Exit_cmdMerge_Click:
Exit Sub

Err_cmdMerge_Click:
MsgBox Err.Description
Resume Exit_cmdMerge_Click

End Sub



Private Sub cmdQuit_Click()
On Error GoTo Err_cmdQuit_Click

If Me.Dirty Then Me.Dirty = False
DoCmd.Quit

Exit_cmdQuit_Click:
Exit Sub

Err_cmdQuit_Click:
MsgBox Err.Description
Resume Exit_cmdQuit_Click

End Sub


'******begin code*****
Function SendEmail(Email As String, First As String)
Dim strEmail, strBody As String
Dim objOutlook As Outlook.Application
Dim objEmail As Outlook.MailItem

'**creates an instance of Outlook
Set objOutlook = CreateObject("Outlook.application")
Set objEmail = objOutlook.CreateItem(olMailItem)

'**************************************************************
'*create string with email address

strEmail = EMAIL

'strBody = txtTDate & Chr(13) & Chr(13)
strBody = strBody & "Hello " & First & "," & Chr(13) & Chr(13)
strBody = strBody & "Thank you for your recent correspondence." & Chr(13)
strBody = strBody & "Sincerely," & Chr(13) & Chr(13)

'***creates and sends email
With objEmail
.To = strEmail
.SUBJECT = "My Document is attached"
.body = strBody
.Attachments.Add ("C:\Users\John\Documents\MSWordDoc2003Format.doc")
'add attachment
.Send
End With


Set objEmail = Nothing
objOutlook.Quit

Exit Function

End Function
'****end code*****
Click to expand...
 
Back
Top