CODEWITHSUNDEEP
ms-accessduplicatesvbaattachment
turndownforhwhat
turndownforhwhat

Reputation: 13

Preventing a file from attempting to be attached twice

In my database, I have a parts table that contains an attachment field for part drawings. This field should allow for multiple drawings to be associated with each part. Here is my code:

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

When there are initially no attachments for any records, the code runs fine, and all attachments match up with their corresponding records. However, if some new drawings are added to the folder and the code is run again, run time error 3820 occurs ("You cannot enter that value because it duplicates an existing value in the multi-valued lookup or attachment field. Multi-valued lookup or attachment fields cannot contain duplicate values."). The error is occurring because the program is attempting to add attachments that already exist in the field. In order to avoid this, I tried using On Error to skip over the attaching code, which gives me the same error (the adjusted code is just a part of the function, which contains only the rsPart while loop):

 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

Note that I could be using On Error incorrectly, because I'm fairly new to vba. I also tried looping through the child recordset rsAttach and comparing each attachment name to the file before adding, but I still get an error:

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

For both of my attempted fixes and the original scenario, the run time error is 3820 and the line rsAttach.Update is highlighted. Any idea on how to fix this issue? It doesn't seem like it should be too difficult to not attach a file again, so I think I'm missing something small.

Upvotes: 1

Views: 908

Answers (1)

Wayne G. Dunn
Wayne G. Dunn

Reputation: 4312

Try the following code (untested). Your third version was close, but if you already have more than one attachment, you will always try to add a new attachment. I was lazy and used a switch to indicate...

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

Upvotes: 0

Related Questions