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

防止文件尝试连接两次

1 个答案: