Attach file chosen with an Access form to Outlook email

Question

I have an Access form to choose an attachment. I want to send the attachment in an email using Outlook.

My code sometimes works. Most of the time it gives an error in the child recordset.

Option Compare Database
Option Explicit

Private Sub SUBMIT_Click()

Dim db As DAO.Database
Dim appAcc As New Access.Application
Dim rst As DAO.Recordset2
Dim rsA As DAO.Recordset2
Dim strPath As String
Dim dbpath As String
Dim attPath As String
Dim outt As Object
Dim olMail As Object
Dim objOutlookAttach As Outlook.Attachment
Set outt = CreateObject("Outlook.Application")
Set olMail = outt.CreateItem(0)

'On Error GoTo emailErr

Email:

dbpath = "location of the database.accb"

strPath = "location of where attachments should be saved and then attached"

With appAcc
    .OpenCurrentDatabase dbpath
    Set rst = CurrentDb.OpenRecordset("SELECT * FROM [IVS Problem] WHERE [Problem Number] =" & Me.Problem_Number)
    Set rsA = rst.Fields("Attachment").Value     ' <==== Here shows the error
    If rsA.RecordCount <= 0 Then GoTo dooo
End With

'creating the directories for the attachments if they don't already exist

If Len(Dir(strPath, vbDirectory)) = 0 Then
    MkDir strPath
End If

strPath = strPath & "\IVS Problems"

If Len(Dir(strPath, vbDirectory)) = 0 Then
    MkDir strPath
End If

strPath = strPath & "\IVS Problem #" & Me.Problem_Number & " " & Me.Request_Title

If Len(Dir(strPath, vbDirectory)) = 0 Then
    MkDir strPath
End If

dooo:
With olMail
    .BodyFormat = olFormatHTML
    .To = ""
    .CC = ""
    .Subject = "IVS problem #" & Me.Problem_Number & " ; " & Me.Request_Title
    .Body = "Greetings, PSA"

    While Not rsA.EOF
        rsA.Fields("filedata").SaveToFile strPath
        attPath = strPath & "\" & rsA.Fields("Filename")
        .Attachments.Add (attPath)
        rsA.MoveNext
    Wend

    .Save
    .display

End With

GoTo success

emailErr:

Select Case Err.Number
Case 2501
    MsgBox "Cancelled By User", vbInformation
    Set rsA = Nothing
    Set rst = Nothing
    Set fld = Nothing
    Set olMail = Nothing
    Exit Sub
    Kill strPath
    Resume Email

Case Else
    MsgBox "Error" & Err.Number & " " & Err.Description & " was generated by " & Err.Source & Chr(13)
    Set rsA = Nothing
    Set rst = Nothing
    Set fld = Nothing
    Set olMail = Nothing
    Exit Sub
    Kill strPath
    Resume Email
End Select

success:
    Exit Sub
    MsgBox "Your issue Has been Submitted, Thank you", vbInformation
    Application.Quit (acQuitSaveAll)

End Sub

The error appears in the child recordset called rsA. The error is

"Run-time error 3021"
Unknown Error-Message HRESULT: &H800A0BCD

When I get the error message and go debug and without changing anything go back and click the button it sometimes works. It could be the recordset is empty on first run and after the debug it has data?

extra data:

problem_number is the primary key.

"attachment" is the correct field name in the table.

request title is a field in the table.

Answer 1

I dont think you want to use rsA in the first place.

Change your With block to this instead:

With appAcc
     Dim sAttch as String
     .OpenCurrentDatabase dbpath
     Set rst = CurrentDb.OpenRecordset("SELECT * FROM [IVS Problem] WHERE [Problem Number] =" & Me.Problem_Number
     If rsA.RecordCount <= 0 Then GoTo dooo
     sAttch = rst.Fields("Attachment").Value
End With

and then dont loop multiple attachments, because : Me.Problem_Number is not going to be any different using your current logic. Replace your while loop with this instead:

If Len(sAttch) > 0 Then
  attPath = strPath & "\" & sAttch 
  Msgbox attPath ' <<==== use this for debugging to make sure you have the right filename
  .Attachments.Add attPath
End If

Your logic gets a bit confusing and messy because you are using GoTo statements so I would recommend restructuring it not using those in order to make things loop the way that you want.