使用vba将访问表单附件附加到Outlook电子邮件中

Question

我有一个访问表单，您可以选择一个附件，我想使用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

[就像我说的那样，代码不起作用，但是当我收到错误消息并进行调试并且不做任何更改时，我返回并单击按钮，有时它可以工作。我不知道可能是第一次运行时记录集为空，并且在调试后它具有数据？

额外数据：

问题编号是主键。

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

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

任何帮助将不胜感激。

Answer 1

我不认为您首先要使用rsA。

改为将您的With块改为：

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

然后不要循环多个附件，因为：使用您当前的逻辑，Me.Problem_Number不会有任何不同。替换为while循环：

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

您的逻辑有点混乱和混乱，因为您使用的是GoTo语句，所以我建议不要使用那些结构来对其进行重组，以使事情按您想要的方式循环。