Send Access Attachments as Outlook Attachments

[MajP]

Saw a post asking how to send Access attachments as attachments in an email. I did not know much about attachment datatypes so I read up on this to come up with a solution. I did not think this was a commonly known solution so I am posting here. If there is a cleaner way please reply.

Although attachment fields appear to be not normalized (you can put multiple attachment in a single field) in fact they are. System tables hold the normalized data. My solution was to read all of the attachments in an attachment field, save them to disk, attach them to the email, then delete off the disk.

To save to disk you can use DAO. The trick is that an attachment field can return its own recordset of all the attachments in that field for that record. This special recordset then has a savetofile method.

This function is passed in a DAO recordset from the form. It gets the attachments and saves them to the disk for the current record, and returns a string of the attachments deliminated with a question mark

Public Function getAttachments(rs As DAO.Recordset) As String
  'Pass in a recordset with an attachment field
  'Saves the attachement to a directory and passes back a (?) delimited string
  On Error GoTo errlbl
  Const strPath = "C:\"
  Const fldName = "attchPic"
  
  Dim rsAtt As DAO.Recordset
  Dim attachName As String
  Dim PathAndName As String
  Set rsAtt = rs.Fields(fldName).Value
  '  Save current attachment to disk 
  Do While Not rsAtt.EOF
    attachName = rsAtt.Fields("fileName")
    PathAndName = strPath & attachName
    If getAttachments = "" Then
      getAttachments = PathAndName
    Else
      getAttachments = getAttachments & "?" & PathAndName
    End If
    rsAtt.Fields("filedata").saveToFile strPath
    rsAtt.MoveNext
  Loop
  Debug.Print getAttachments
  Exit Function
errlbl:
  If Err.Number = 3839 Then
    MsgBox "File " & attachName & " already exists in " & strPath
    Resume Next
  Else
    MsgBox Err.Number & " " & Err.Description & " in getAttachments."
  End If
End Function

There are two very interesting lines of code
Set rsAtt = rs.Fields(fldName).Value
which returns a recordset holding all the attachments for a field from the attachment datatype.

and
rsAtt.Fields("filedata").saveToFile strPath
Which is a new dao method to save a file held in the "filedata" field of the attachment recordset

The rest is standard outlook code. The only thing I added was passing in my deliminated string of attachments

Sub SendMessage(Optional attachmentPaths = "")
   'Pass in the attachments seperated by ?
   On Error GoTo errlbl
   Dim objOutlook As Outlook.Application
   Dim objOutlookMsg As Outlook.MailItem
   Dim objOutlookRecip As Outlook.Recipient
   Dim objOutlookAttach As Outlook.Attachment
   Dim atts() As String
   Dim i As Integer
   ' Create the Outlook session.
   Set objOutlook = CreateObject("Outlook.Application")

   ' Create the message.
   Set objOutlookMsg = objOutlook.CreateItem(olMailItem)

   With objOutlookMsg
      ' Add the To recipient(s) to the message.
     Set objOutlookRecip = .Recipients.Add("Nancy Davolio")
      objOutlookRecip.Type = olTo

      ' Add the CC recipient(s) to the message.
      Set objOutlookRecip = .Recipients.Add("Andrew Fuller")
      objOutlookRecip.Type = olCC

      ' Set the Subject, Body, and Importance of the message.
      .Subject = "This is an Automation test with Microsoft Outlook"
      .Body = "Last test - I promise." & vbCrLf & vbCrLf
      .Importance = olImportanceHigh  'High importance

      ' Add attachments to the message.
      If Not attachmentPaths = "" Then
         atts = Split(attachmentPaths, "?")
         For i = LBound(atts) To UBound(atts)
           Set objOutlookAttach = .Attachments.Add(atts(i))
         Next i
      End If

      ' Resolve each Recipient's name.
      For Each objOutlookRecip In .Recipients
         objOutlookRecip.Resolve
         If Not objOutlookRecip.Resolve Then
         objOutlookMsg.Display
      End If
      Next
      
      .Send

   End With
   Set objOutlookMsg = Nothing
   Set objOutlook = Nothing
   Exit Sub
errlbl:
   MsgBox Err.Number & " " & Err.Description
End Sub

since I saved the attachments to disk, I delete them once the email is sent

Public Sub killAttachments(attachmentPaths As String)
  On Error GoTo errlbl
  Dim atts() As String
  Dim i As Integer
  
  If Not attachmentPaths = "" Then
    atts = Split(attachmentPaths, "?")
    For i = LBound(atts) To UBound(atts)
      Kill (atts(i))
    Next i
  End If
  Exit Sub
errlbl:
  If Err.Number = 53 Then
    MsgBox "File " & atts(i) & " not found"
    Resume Next
  Else
    MsgBox Err.Number & " " & Err.Description & " in KillAttachments"
  End If
End Sub

This is all called from a form like

Private Sub cmdSave_Click()
  Dim rs As DAO.Recordset
  Dim attachmentPaths As String
  
  Set rs = Me.Recordset
  attachmentPaths = getAttachments(rs)
  Call SendMessage(attachmentPaths)
  Call killAttachments(attachmentPaths)
  
End Sub

obviously this code can be simply modified to save all attachments to disk. There is also a loadfromfile method.