Concatenate ID field to filename-CodePudding

In MS Access, I want to rename filename of the attachment with ID and filename so that there should be any problem for duplicates. For example, if the id is 1 and filename is ABC then name in the folder should be 1ABC or 1_ABC anything is fine. Currently it is saving as ABC.extension (pdf/docx/txt). I need IDfilename(1ABC.extension). ID is one of my field in Access which is a primary key.

The code what I have used is below. In my code, Attachments is the field, Notices is table name.

If someone could write the code then that would be useful.

Option Compare Database

Public Function SaveAttachments(savePath As String, Optional strPattern As String = "*.*") As Long

    Dim dbs As DAO.Database
    Dim rst As DAO.Recordset2
    Dim rsA As DAO.Recordset2
    Dim fld As DAO.Field2
    Dim ID As DAO.Field2
    Dim strFullPath As String

    Set dbs = CurrentDb
    Set rst = dbs.OpenRecordset("Notices")

    Set fld = rst("Attachments")
    Set ID = rst("ID")

    Do While Not rst.EOF

        Set rsA = fld.Value
        Set rsB = ID.Value

        Do While Not rsA.EOF

            If rsA("FileName") Like strPattern Then
                strFullPath = savePath & "\" & rsB("ID") & "_" & rsA("FileName")

                If Dir(strFullPath) = "" Then
                    rsA("FileData").SaveToFile strFullPath
                End If

                SaveAttachments = SaveAttachments   1

            End If

            rsA.MoveNext

        Loop

        rsA.Close
        rsA.MoveNext

    Loop

    rst.Close
    dbs.Close

    Set fld = Nothing
    Set ID = Nothing

    Set rsA = Nothing
    Set rsB = Nothing
    Set rst = Nothing
    Set dbs = Nothing

End Function


Private Sub Command3_Click()
    SaveAttachments ("D:\Test1")
End Sub

I am getting error in assigning ID field and below line

strFullPath = savePath & "\" & rsB("ID") & "_" & rsA("FileName")

CodePudding user response：

Try this.

Private Sub Command0_Click()

    Dim counter As Long
    counter = SaveAttachments("D:\Test1")

    MsgBox counter & " files exported."

End Sub

Public Function SaveAttachments(savePath As String, Optional strPattern As String = "*.*") As Long

    Dim r As DAO.Recordset
    Dim r2 As DAO.Recordset2
    Dim strFullPath As String
    Dim counter As Long
    
    Set r = CurrentDb().OpenRecordset("Notices")

    Do While Not r.EOF

        Set r2 = r("Attachments").Value

        Do While Not r2.EOF

            If r2("FileName") Like strPattern Then
                strFullPath = savePath & "\" & r("ID") & "_" & r2("FileName")

                If Dir(strFullPath) = "" Then
                    r2("FileData").SaveToFile strFullPath
                    counter = counter   1
                End If
            End If

            r2.MoveNext
        Loop

        If Not r2 Is Nothing Then r2.Close
        r.MoveNext
    Loop

    If Not r Is Nothing Then r.Close

    SaveAttachments = counter
End Function