将使用 Access 表单选择的文件附加到 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

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

额外数据：

problem_number 是主键。

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

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

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 语句，因此我建议您对其进行重组，而不是使用这些语句，以使事情以您想要的方式循环。