我有一个“访问”表单来选择附件。我想使用Outlook通过电子邮件发送附件。

我的代码有时可行。在大多数情况下，它会在子记录集中产生错误。

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

该错误出现在名为rsA的子记录集中。错误是

“运行时错误3021”
未知错误消息HRESULT：＆H800A0BCD

当我收到错误消息并进行调试，并且不做任何更改时，返回并单击按钮，有时它可以工作。可能是第一次运行时记录集为空，并且在调试后它具有数据？

其他数据：

problem_number是主键。

“附件”是表中正确的字段名称。

请求标题是表格中的一个字段。