Sending Attachment fields to Email as Attachments (1 Viewer)

[wrweaver]

I needed a button to send information from the text fields in a form as the body of an email, and then attach the attachments that are in the attachment field "IssuePics." I have read hours of forums and found the code that turns the text fields into the body of the email, and I thought I found the code to attach the attachments. I'm having trouble merging the two.
This is the send attachments portion:

Dim appOutLook As Outlook.Application
Dim MailOutLook As Outlook.MailItem
Dim OutlookAttach As Outlook.Attachment
Set appOutLook = CreateObject("Outlook.Application")
Set MailOutLook = appOutLook.CreateItem(olMailItem)
 
Dim db As DAO.Database
Dim rsParent As DAO.Recordset2
Dim rsChild As DAO.Recordset2
Set db = CurrentDb
Set rsParent = Me.Recordset
rsParent.OpenRecordset
Set rsChild = rsParent.Fields("Attachments").Value
While Not rsChild.EOF
If Dir("C:\dbtemp", vbDirectory) = "" Then
MkDir ("C:\dbtemp")
Else
'do nothing for the "C:\dbtemp" directory already exists
'MsgBox "C:\dbtemp\ directory already exists"
End If
rsChild.OpenRecordset
rsChild.Fields("FileData").SaveToFile ("c:\dbtemp\")
rsChild.MoveNext
Wend
With MailOutLook
.BodyFormat = olFormatRichText
'.To = "email address"
'.CC = " "
.Subject = "test"
Dim fso As Object, SourceFolder As Object, SourceFile As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = fso.GetFolder("C:\dbtemp\")
For Each SourceFile In SourceFolder.Files
.Attachments.Add SourceFolder.Path & "\" & SourceFile.Name
Next
'Send email
'.DeleteAfterSubmit = True 'This would let Outlook send the note without storing it in your sent bin
'.Send
Kill "C:\dbtemp\*.*" ' delete all files in the folder
RmDir "C:\dbtemp\" ' delete folder
End With

And this is the one I found to send the fields in the body:

Dim oFilesys, oTxtStream As Object
Dim txtHTML As String
Dim olApp As Object
Dim objMail As Object
DoCmd.OpenReport "ReviewWorkOrdeMROR", acViewPreview, , "WorkOrderID=" & WorkOrderID, acHidden
DoCmd.OutputTo acOutputReport, strReviewWorkOrdeMROR, acFormatHTML, "C:\temp\" & strReviewWorkOrdeMROR & ".HTML", False
Set oFilesys = CreateObject("Scripting.FileSystemObject")
Set oTxtStream = oFilesys.OpenTextFile("C:\temp\" & strReviewWorkOrdeMROR & ".HTML", 1)
txtHTML = oTxtStream.ReadAll
oTxtStream.Close
Set oTxtStream = Nothing
Set oFilesys = Nothing

'Set olApp = GetObject(, "Outlook.Application") 'See if Outlook is open
'If Err Then 'Outlook is not open
Set olApp = CreateObject("Outlook.Application") 'Create a new instance of Outlook
'End If
Set objMail = olApp.CreateItem(olMailItem)
With objMail
''.BodyFormat = olFormatHTML
.HTMLBody = txtHTML
'.Recipients.Add ""
.Subject = ""

'.Send if you want to send it directly without displaying on screen
.Display
End With
'you can delete the outputted file if you want
Kill "c:\temp\" & strReviewWorkOrdeMROR & ".HTML"
Set olApp = Nothing
Set objMail = Nothing

I really don't know how to merge them and when I ran the code to attach the attachment field, I got a compile error: "User-defined type not defined."

I'm using Access 2010 and Office 2010.

I appreciate any and all help most graciously! Thank you.

 

[michaeljryan78]

User Defined error is usually a missing reference. Create a reference to the Outlook libraray in the VBA editor by going to tools>references. Look for "Microsoft Outlook xx.o Object library.

 

[michaeljryan78]

I use this combonation of functions. works well for me. In outlook you must also set trust center to allow programmatic access.

Option Compare Database
Option Explicit
Dim appOutlook As Outlook.Application
Dim ns As Outlook.NameSpace
 
'this function opens a recordset to see if there is an attachment for the record.  modify to taste

Function AttachmentResult() As Boolean
Dim rs As Recordset
Dim strAttach As String
    strAttach = "Select filepath from tblAttachments where ticketID = " & TempVars!TicketID
    Set rs = CurrentDb.OpenRecordset(strAttach)
    
    If rs.RecordCount > 0 Then
        AttachmentResult = True
    Else
        AttachmentResult = False
    End If
    
    rs.Close
    Set rs = Nothing
    
End Function

Function Outlook_SendMail(strSubject As String, strBody As String, strTo As String, strCC As String, Optional strBcc As String, Optional strAttach As Boolean, Optional AutoSend As Boolean = True)
    Outlook_OpenOutlook 'this is a sub further down the page
    Dim mailOutlook As Outlook.MailItem
    Dim strDoc As String
    Dim strDisclaimer As String
    
    
    strDisclaimer = "**THIS IS AN AUTOMATED EMAIL PLEASE DO NOT REPLY** YOUR EMAIL WILL NOT BE READ**" & vbCrLf & vbCrLf
    Set mailOutlook = appOutlook.CreateItem(olMailItem)
    

        If strAttach = True Then
            Dim rs As Recordset
            Dim strSQL As String
            strSQL = "Select filepath from tblAttachments where ticketID = " & TempVars!TicketID
            Set rs = CurrentDb.OpenRecordset(strSQL)
            Do Until rs.EOF = True
                mailOutlook.Attachments.Add quote(rs!FilePath)
            rs.MoveNext
            Loop
            rs.Close
            Set rs = Nothing
        End If
        mailOutlook.Subject = strSubject
        
        If Len(strTo) < 1 Then
            Set mailOutlook = Nothing
            Exit Function
        End If
            If AutoSend = False Then
                mailOutlook.To = ""
                mailOutlook.CC = ""
               mailOutlook.BCC = ""
                mailOutlook.body = strDisclaimer & strBody
                mailOutlook.Display
            Else
                mailOutlook.To = strTo
                mailOutlook.CC = strCC
                mailOutlook.BCC = strBcc
                mailOutlook.body = strDisclaimer & strBody
'                mailOutlook.Display
                mailOutlook.send
            End If
    
End Function
Sub Outlook_OpenOutlook()
On Error Resume Next
Set appOutlook = GetObject(, "Outlook.Application")
    If Err <> 0 Then
        Set appOutlook = New Outlook.Application
        Set ns = appOutlook.GetNamespace("MAPI")
        Dim folderOutlook As Folder
        Set folderOutlook = ns.GetDefaultFolder(olFolderInbox)
        folderOutlook.Display
    Else
        Set ns = appOutlook.GetNamespace("MAPI")
    End If
  
End Sub
 
 
Sub Test()
Dim strSubject As String
Dim strBody As String
Dim strTo As String
Dim strCC As String
Dim strBcc As String
strBody = "TEST"
strSubject = "This is a Test Email!"
strTo = "[EMAIL="someone@somewhere.com"]someone@somewhere.com[/EMAIL]"
strCC = ""

Call Outlook_SendMail(strSubject, strBody, strTo, strCC, , AttachmentResult)

End Sub

 

[wrweaver]

Thanks Michael! Adding the reference in the library did the trick! Here is the final working code that sends the information on a form in html email format and attaches any attachments!

Dim oFilesys, oTxtStream As Object
Dim txtHTML As String
Dim appOutLook As Outlook.Application
Dim MailOutLook As Outlook.MailItem
Dim OutlookAttach As Outlook.Attachment
Set appOutLook = CreateObject("Outlook.Application")
Set MailOutLook = appOutLook.CreateItem(olMailItem)

DoCmd.OpenReport "YOURREPORTNAME", acViewPreview, , "WorkOrderID=" & WorkOrderID, acHidden
DoCmd.OutputTo acOutputReport, strYOURREPORTNAME, acFormatHTML, "C:\temp\" & strYOURREPORTNAME & ".HTML", False
Set oFilesys = CreateObject("Scripting.FileSystemObject")
Set oTxtStream = oFilesys.OpenTextFile("C:\temp\" & strReviewWorkOrdeMROR & ".HTML", 1)
txtHTML = oTxtStream.ReadAll
oTxtStream.Close
Set oTxtStream = Nothing
Set oFilesys = Nothing
Dim db As DAO.Database
Dim rsParent As DAO.Recordset2
Dim rsChild As DAO.Recordset2
Set db = CurrentDb
Set rsParent = Me.Recordset
rsParent.OpenRecordset
Set rsChild = rsParent.Fields("YOURATTACHMENTSFIELDNAME").Value
While Not rsChild.EOF
If Dir("C:\dbtemp", vbDirectory) = "" Then
MkDir ("C:\dbtemp")
Else
'do nothing for the "C:\dbtemp" directory already exists
'MsgBox "C:\dbtemp\ directory already exists"
End If
rsChild.OpenRecordset
rsChild.Fields("FileData").SaveToFile ("c:\dbtemp\")
rsChild.MoveNext
Wend
With MailOutLook
.BodyFormat = olFormatRichText
.To = ""
'.CC = " "
.Subject = ""
.HTMLBody = txtHTML
Dim fso As Object, SourceFolder As Object, SourceFile As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = fso.GetFolder("C:\dbtemp\")
For Each SourceFile In SourceFolder.Files
.Attachments.Add SourceFolder.Path & "\" & SourceFile.Name
.Display
Next
'Send email
'.DeleteAfterSubmit = True 'This would let Outlook send the note without storing it in your sent bin
'.Send
Kill "C:\dbtemp\*.*" ' delete all files in the folder
RmDir "C:\dbtemp\" ' delete folder
End With
'MsgBox MailOutLook.Body
Kill "c:\temp\" & strReviewWorkOrdeMROR & ".HTML"
'email_error:
'MsgBox "An error was encountered." & vbCrLf & "The error message is: " & Err.Description
'Resume Error_out
''Error_out:

 

[drouz]

Hello, I'm fairly new to Access and VBA but have spend days learning how to setup a database with an attachments field, which I have done successfully, this database is on a shared network drive and is used by my workmates, so data is entered via a form, I wanted to add a command button to email the entered data (or current record). I have managed to do this and also managed to save the attachment from the attachment field to disk then add it to the email as an attachment, I then run into problems if the record has no attachments, I guessing I need to add a check to determine if there are any attachments and then add them if there are any, however I have no idea how to do this, below is my code so far apologies if its a bit messy as I have put it together by grabbing others code from forums and changing it to suit my database.

Any help would be greatly appreciated

Cheers
Josh

Function SaveAttachment()
Dim db As DAO.Database
 Dim rst As DAO.Recordset2
 Dim rstAttachment As DAO.Recordset2
 Dim fld As DAO.Field2
 Dim strPath As String
 Dim intz As Integer
 
Set db = CurrentDb
     Set rst = db.OpenRecordset("site inspections table", dbOpenDynaset)
     rst.FindFirst "ID = " & Me!ID
      Set rstAttachment = rst.Fields("Photos").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
 
 rstAttachment.Close
 rst.Close
 Set rstAttachment = Nothing
 Set rst = Nothing
 Set db = Nothing
 
End Function
 
Private Sub cmdEmail_Click()
 Dim outlookApp As Outlook.Application
 Dim outlookNamespace As NameSpace
 Dim objMailItem  As MailItem
 Dim objFolder As MAPIFolder
 Dim strAttachementPath As String
 Dim rst As DAO.Recordset2
 Dim rstAttachment As DAO.Recordset2
 Dim db As DAO.Database
 
Call SaveAttachment
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("site inspections table", dbOpenDynaset)
     rst.FindFirst "ID = " & Me!ID
    Set rstAttachment = rst.Fields("Photos").Value
strAttachementPath = CurrentProject.Path & "\Attach\" _
  & rstAttachment.Fields("Filename")
 
With objMailItem
     .To = "EMAIL ADDRESS HERE"
     .Subject = "Site Inspection for " & [Area] & "At " & [Date]
     .Body = "Some text here"
     .Attachments.Add (strAttachementPath)
     .Display
 End With
 outlookApp.ActiveWindow
 'SendKeys ("%s")
MsgBox "Mail Sent!", vbOKOnly, "Mail Sent"

 

[michaeljryan78]

You can do this:

With objMailItem
     .To = "EMAIL ADDRESS HERE"
     .Subject = "Site Inspection for " & [Area] & "At " & [Date]
     .Body = "Some text here"
if isnull(rstAttachment.Fields("Filename")) = false then
     .Attachments.Add (strAttachementPath)
End if
     .Display
 End With

 

[drouz]

You can do this:

With objMailItem
     .To = "EMAIL ADDRESS HERE"
     .Subject = "Site Inspection for " & [Area] & "At " & [Date]
     .Body = "Some text here"
if isnull(rstAttachment.Fields("Filename")) = false then
     .Attachments.Add (strAttachementPath)
End if
     .Display
 End With

thanking you, I have tried inserting this code, but I get a runtime error before I reach this point

Run Time Error '3021'
No Current Record

I've commented in my code below where it happens, I'm guessing it happens because there are no attachments I think I need a check in here or something but nothing I do seems to fix this, thanks for you help so far

I have tried moving the Call SaveAttachment function down to the if statement in objmailitem, but the functions seems to get called regardless

Function SaveAttachment()
Dim db As DAO.Database
Dim rst As DAO.Recordset2
Dim rstAttachment As DAO.Recordset2
Dim fld As DAO.Field2
Dim strPath As String
Dim intz As Integer
 
Set db = CurrentDb
Set rst = db.OpenRecordset("site inspections table", dbOpenDynaset)
rst.FindFirst "ID = " & Me!ID
Set rstAttachment = rst.Fields("Photos").Value
Set fld = rstAttachment.Fields("Filedata")
strPath = CurrentProject.Path & "\Attach\" _     'HERE IS WHERE I
& rstAttachment.Fields("Filename")                  'GET RUN TIME ERRROR
On Error Resume Next
Kill strPath & "\Attach\"
On Error GoTo 0
 
fld.SaveToFile strPath
 
rstAttachment.Close
rst.Close
Set rstAttachment = Nothing
Set rst = Nothing
Set db = Nothing
 
End Function
 
Private Sub cmdEmail_Click()
Dim outlookApp As Outlook.Application
Dim outlookNamespace As NameSpace
Dim objMailItem As MailItem
Dim objFolder As MAPIFolder
Dim strAttachementPath As String
Dim rst As DAO.Recordset2
Dim rstAttachment As DAO.Recordset2
Dim db As DAO.Database
 
Call SaveAttachment
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("site inspections table", dbOpenDynaset)
rst.FindFirst "ID = " & Me!ID
Set rstAttachment = rst.Fields("Photos").Value
strAttachementPath = CurrentProject.Path & "\Attach\" _
& rstAttachment.Fields("Filename")
 
With objMailItem
.To = "EMAIL ADDRESS HERE"
.Subject = "Site Inspection for " & [Area] & "At " & [Date]
.Body = "Some text here"
if isnull(rstAttachment.Fields("Filename")) = false then
     .Attachments.Add (strAttachementPath)
end if
.Display
End With
outlookApp.ActiveWindow
'SendKeys ("%s")

 

[drouz]

Ha been playing around with it and finally cracked it, heres the code that worked for me, thank for the help michaeljryan78

Function SaveAttachment()
Dim db As DAO.Database
 Dim rst As DAO.Recordset2
 Dim rstAttachment As DAO.Recordset2
 Dim fld As DAO.Field2
 Dim strPath As String
 Dim intz As Integer
 
Set db = CurrentDb
     Set rst = db.OpenRecordset("site inspections table", dbOpenDynaset)
     rst.FindFirst "ID = " & Me!ID
      Set rstAttachment = rst.Fields("Photos").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
 
 rstAttachment.Close
 rst.Close
 Set rstAttachment = Nothing
 Set rst = Nothing
 Set db = Nothing
 
End Function
 
Private Sub cmdEmail_Click()
 Dim outlookApp As Outlook.Application
 Dim outlookNamespace As NameSpace
 Dim objMailItem  As MailItem
 Dim objFolder As MAPIFolder
 Dim strAttachementPath As String
 Dim rst As DAO.Recordset2
 Dim rstAttachment As DAO.Recordset2
 Dim db As DAO.Database
 Dim strHTML
 
'Call SaveAttachment
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("site inspections table", dbOpenDynaset)
     rst.FindFirst "ID = " & Me!ID
    Set rstAttachment = rst.Fields("Photos").Value
'strAttachementPath = CurrentProject.Path & "\Attach\" _
' & rstAttachment.Fields("Filename")

' Build HTML for message body.
 strHTML = "<HTML><HEAD>"
 strHTML = "<br>"
 strHTML = strHTML & "<FONT Face=Calibri><b>ID: </b></br>" & [ID] & "<br>"
 strHTML = strHTML & "<FONT Face=Calibri><b>Date: </b></br>" & [Date] & "<br>"
 strHTML = strHTML & "<FONT Face=Calibri><b>Time: </b></br>" & [Time] & "<br>"
 strHTML = strHTML & "<FONT Face=Calibri><b>Technician: </b></br>" & [Technician] & "<br>"
 strHTML = strHTML & "<FONT Face=Calibri><b>Area: </b></br>" & [Area] & "<br>"
 strHTML = strHTML & "<FONT Face=Calibri><b>Blast No.: </b></br>" & [shot number] & "<br><br>"
 strHTML = strHTML & "<FONT Face=Calibri><b>Comments: </b></br>" & [Comments] & "<br>"
 strHTML = strHTML & "</FONT></br><BODY>"
'strHTML = strHTML & "<FONT Face=Arial Color=#ff0000 Size=5>Job #: 123456</FONT></br>"
'strHTML = strHTML & "<FONT Size=3>For: <FONT Size=2></B>a name here</br>"
'strHTML = strHTML & "<FONT Size=3><B>Description: </B><FONT Size=2>description of work to be done</FONT></br>"
 strHTML = strHTML & "</BODY></HTML>"

' Build the Email to be sent
With objMailItem
    .BodyFormat = olFormatHTML
    .To = "EMAIL ADDRESS HERE"
    .Subject = "Site Inspection for " & [Area] & " At " & [Date]
'    .Body = "Some text here"
    .HTMLBody = strHTML
' Grab Attachments for Email if there are any
    If rstAttachment.RecordCount > 0 Then
        Call SaveAttachment
        strAttachementPath = CurrentProject.Path & "\Attach\" _
        & rstAttachment.Fields("Filename")
        .Attachments.Add (strAttachementPath)
    End If
     .Display
 End With
 
 outlookApp.ActiveWindow
 'SendKeys ("%s")
MsgBox "Mail Sent!", vbOKOnly, "Mail Sent"