Requesting assistant with getting files (could be zero, 1 or more) from attachment field in MS Access to attach to an email in MS Outlook.
I have tried using code examples from the following two posts below which seem to have a combination of what I'm trying to achieve:
1. Sending Attachment fields to Email as Attachment
2. VBA code to save attachments in specific folder
My code is as follows:
I have tried using code examples from the following two posts below which seem to have a combination of what I'm trying to achieve:
1. Sending Attachment fields to Email as Attachment
2. VBA code to save attachments in specific folder
My code is as follows:
Code:
Option Compare Database
Option Explicit
Public Sub SaveAttachment()
'Funtion to Save Attachments from tblEmailTemplates to include with MS Outlook Email on btnSendEmail below
Dim db As DAO.Database
Dim rst As DAO.Recordset2
Dim rstAttachment As DAO.Recordset2
Dim fld As DAO.Field2
Dim strPath As String
Set db = CurrentDb
Set rst = db.OpenRecordset("tblEmailTemplates", dbOpenDynaset)
rst.FindFirst "EmailID = " & Me!EmailID
Set rstAttachment = rst.Fields("EmailAttachments").Value
Set fld = rstAttachment.Fields("Filedata")
strPath = CurrentProject.Path & "\Attach\" & rstAttachment.Fields("Filename")
On Error Resume Next
Kill strPath & "\Attach\"
On Error GoTo 0
fld.SaveToFile strPath 'runtime error '-2147024893 (80070003)'
'<Unknown Error-message> HRESULT: &H800700003
rstAttachment.Close
rst.Close
Set rstAttachment = Nothing
Set rst = Nothing
Set db = Nothing
End Sub
Private Sub btnSendEmail_Click()
'EVERYTHING WORKING EXCEPT ATTACHMENT
'REFERENCE HAD BEEN MADE TO OBJECT LIBRARY. VBA>Tools>Reference>MS OUTLOOK
Dim outlookApp As Outlook.Application
Dim outlookNameSpace As NameSpace 'what is this for?
Dim objMailItem As MailItem
Dim objFolder As MAPIFolder 'what is this for?
Dim strAttachmentPath As String
Dim rst As DAO.Recordset2
Dim rstAttachment As DAO.Recordset2
Dim db As DAO.Database
Dim Salutation As String
Dim Signature As String
'CALL FUNCTION SaveAttachment from above
Set outlookApp = CreateObject("Outlook.Application")
Set outlookNameSpace = outlookApp.GetNamespace("mapi")
Set objFolder = outlookNameSpace.GetDefaultFolder(olFolderInbox)
Set objMailItem = objFolder.Items.Add(olMailItem)
Set db = CurrentDb
Set rst = db.OpenRecordset("tblEmailTemplates", dbOpenDynaset)
rst.FindFirst "EmailID = " & Me!EmailID
Set rstAttachment = rst.Fields("EmailAttachments").Value
'rstAttachment Path = CurrentProject.Path & "\Attach\" & rstAttachment.Fields("Filename")
'BUILD THE EMAIL TO BE SENT...
'SALUTATION
Salutation = Me.txtContactFirstName.Value & ","
With objMailItem
.Display
End With
Signature = objMailItem.HTMLBody
objMailItem.To = Nz(Me.txtEmailTo.Value, "")
objMailItem.CC = Nz(txtEmailCC.Value, "")
objMailItem.BCC = Nz(txtEmailBCC.Value, "")
objMailItem.Subject = Nz(Me.txtEmailSubject.Value, "")
objMailItem.HTMLBody = Salutation & Me.txtEmailBody & Signature
'GRAB ATTACHMENTS FOR EMAIL IF THERE ARE ANY
If rstAttachment.RecordCount > 0 Then
Call SaveAttachment
strAttachmentPath = CurrentProject.Path & "\Attach\" & rstAttachment.Fields("Filename")
objMailItem.Attachments.Add (strAttachmentPath)
End If
With objMailItem
If Not IsNull(.To) And Not IsNull(.Subject) And Not IsNull(.Body) Then
.Display
Else
MsgBox "Please fill out required fields."
End If
End With
'CLOSE FORM
DoCmd.Close acForm, "frmTestEmail", acSaveNo
End Sub
