防止文件尝试附加两次

Question

在我的数据库中，我有一个零件表，其中包含零件图的附件字段。该字段应允许多个图纸与每个零件相关联。这是我的代码：

Function AttachDrawings() ' attaches part drawing pdfs from "Drawings" folder to "Main Item List" table

Dim rsPart As DAO.Recordset ' part recordset from table "Main Item List"
Dim rsAttach As DAO.Recordset2 ' child recordset of rsPart that represents drawing attachments
Dim nameFile As String ' name of file in folder "Drawings"
Dim strTarget As String ' Customer name and item ID that should be found in .pdf file name

Set rsPart = CurrentDb.OpenRecordset("Main Item List") ' initialize parent recordset
nameFile = Dir("C:\Drawings\*.pdf") ' finds first pdf in folder
Do While (nameFile <> "")
    rsPart.MoveFirst
    While Not rsPart.EOF
        strTarget = rsPart.Fields("Customer").Value & " " & rsPart.Fields("Customer Item ID").Value ' this string should be within the file name of a pdf
        If InStr(1, nameFile, strTarget) Then ' if the phrase is in the file name, attach file
            Set rsAttach = rsPart.Fields("Drawings").Value ' initialize child recordset
            rsPart.Edit
            rsAttach.AddNew
            rsAttach.Fields("FileData").LoadFromFile ("C:\Drawings\" & nameFile)
            rsAttach.Update
            rsPart.Update
        End If
        rsPart.MoveNext ' move to next record
    Wend
    nameFile = Dir() ' move to next drawing
Loop
rsPart.Close
End Function

当最初没有任何记录的附件时，代码运行良好，并且所有附件都与其对应的记录匹配。但是，如果将一些新图形添加到文件夹并再次运行代码，则会出现运行时错误 3820（“您无法输入该值，因为它与多值查找或附件字段中的现有值重复。多值查找或附件字段不能包含重复值。”）。发生错误是因为程序试图添加字段中已存在的附件。为了避免这种情况，我尝试使用 On Error 跳过附加代码，这给了我同样的错误（调整后的代码只是函数的一部分，它只包含 rsPart while 循环）：

 While Not rsPart.EOF
        strTarget = rsPart.Fields("Customer").Value & " " & rsPart.Fields("Customer Item ID").Value ' this string should be within the file name of a pdf
        If InStr(1, nameFile, strTarget) Then ' if the phrase is in the file name, attach file
            Set rsAttach = rsPart.Fields("Drawings").Value ' initialize child recordset
            rsPart.Edit
            rsAttach.AddNew
            On Error GoTo SkipAttaching
            rsAttach.Fields("FileData").LoadFromFile ("C:\Drawings\" & nameFile)
            rsAttach.Update
            rsPart.Update
SkipAttaching:
        End If
        rsPart.MoveNext ' move to next record
    Wend

请注意，我可能错误地使用了 On Error，因为我对 vba 还很陌生。我还尝试循环遍历子记录集 rsAttach 并在添加之前将每个附件名称与文件进行比较，但仍然出现错误：

While Not rsPart.EOF
        strTarget = rsPart.Fields("Customer").Value & " " & rsPart.Fields("Customer Item ID").Value ' this string should be within the file name of a pdf
        If InStr(1, nameFile, strTarget) Then ' if the phrase is in the file name, attach file
            Set rsAttach = rsPart.Fields("Drawings").Value ' initialize child recordset
            rsAttach.MoveFirst
            While Not rsAttach.EOF
                If (rsAttach.Fields("FileName") <> nameFile) Then
                    rsPart.Edit
                    rsAttach.AddNew
                    rsAttach.Fields("FileData").LoadFromFile ("C:\Drawings\" & nameFile)
                    rsAttach.Update
                    rsPart.Update
                End If
                rsAttach.MoveNext
            Wend
        End If
        rsPart.MoveNext ' move to next record
    Wend

对于我尝试的修复和原始场景，运行时错误为 3820，并且 rsAttach.Update 行被突出显示。关于如何解决这个问题的任何想法？似乎不再附加文件应该太难了，所以我想我错过了一些小东西。

Answer 1

试试下面的代码（未经测试）。您的第三个版本很接近，但如果您已经有多个附件，您将始终尝试添加一个新附件。我偷懒，用开关表示……

Function AttachDrawings()               ' attaches part drawing pdfs from "Drawings" folder to "Main Item List" table

Dim rsPart As DAO.Recordset         ' part recordset from table "Main Item List"
Dim rsAttach As DAO.Recordset2      ' child recordset of rsPart that represents drawing attachments
Dim nameFile As String              ' name of file in folder "Drawings"
Dim strTarget As String             ' Customer name and item ID that should be found in .pdf file name

Set rsPart = CurrentDb.OpenRecordset("Main Item List")      ' initialize parent recordset
nameFile = Dir("C:\Drawings\*.pdf")                         ' finds first pdf in folder
Do While (nameFile <> "")
    rsPart.MoveFirst
    While Not rsPart.EOF
        strTarget = rsPart.Fields("Customer").Value & " " & rsPart.Fields("Customer Item ID").Value     ' this string should be within the file name of a pdf
        If InStr(1, nameFile, strTarget) Then                   ' if the phrase is in the file name, attach file
            Set rsAttach = rsPart.Fields("Drawings").Value      ' initialize child recordset
            rsAttach.MoveFirst
            Dim blnMatch    As Boolean
            blnMatch = False
            Do While Not rsAttach.EOF
                'If (rsAttach.Fields("FileName") <> nameFile) Then
                If (rsAttach.Fields("FileName") = nameFile) Then
                    blnMatch = True
                    Exit Do
                End If
                rsAttach.MoveNext
            Loop
            If blnMatch = False Then
                rsPart.Edit
                rsAttach.AddNew
                rsAttach.Fields("FileData").LoadFromFile ("C:\Drawings\" & nameFile)
                rsAttach.Update
                rsPart.Update
            End If
        End If
        rsPart.MoveNext ' move to next record
    Wend
    nameFile = Dir() ' move to next drawing
Loop
rsPart.Close
End Function