Save All attachments of Sharepoint list via VBA not working (1 Viewer)

[luisengard]

Hi all,

I am a new user here, Spaniard in his forties, trying to learn DAO as I find situations that requires it. Thanks a lot for your help in advance, as I have spent a few hours looking for solutions and so far none has worked. I already searched this forum and found a few solutions to my issue, however when I apply them, they don't work so I must be doing something wrong.

My goal is to download all attachments of a sharepoint list. I managed to link the SP list to an Access db and I can open the linked list in Datasheet view (I cannot "import" it, though - error: <<Could not find file '' >>).

I tried codes from these posts from this same forum:
How I Exported an Attachment fields data to a folder, (cannot post links, it says it is spam)
Export Attachments to Folders (cannot post links, it says it is spam)
And similar code from other websites.

When I run any of these codes, i.e.:

Public Function SaveAttachments(strPath 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 strFullPath As String

'Get the database, recordset, and attachment field
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset("Servicios Solicitados")
Set fld = rst("Adjuntos")

'Navigate through the table
Do While Not rst.EOF

'Get the recordset for the Attachments field
Set rsA = fld.Value

'Save all attachments in the field
Do While Not rsA.EOF
If rsA("FileName") Like strPattern Then
strFullPath = strPath & "\" & rsA("FileName")

'Make sure the file does not exist and save
If Dir(strFullPath) = "" Then
rsA("FileData").SaveToFile strFullPath
End If

'Increment the number of files saved
SaveAttachments = SaveAttachments + 1
End If

'Next attachment
rsA.MoveNext
Loop
rsA.Close

'Next record
rst.MoveNext
Loop

rst.Close
dbs.Close

Set fld = Nothing
Set rsA = Nothing
Set rst = Nothing
Set dbs = Nothing
End Function

Called from:

Sub ExportAttachments()
Dim strRuta As String
strRuta = "C:\Test\"
Call SaveAttachments(strRuta)
End Sub

The error is always in the variable strFullPath, I think it is because it brings the entire Sharepoint list address, which may or may not be the right thing:

I also tried copying the table with append or make table queries, but as attachments are multi-variant, these don't know and I don't know it that would work anyway.

Any ideas on how to get those files?

Many MANY thanks,

 

[sonic8]

That looks like a bug in the implementation of the FileName property of the attachment for linked SharePoint lists.
You can work around it by extracting the file name from the full URL. E.g.:

FileNameOnly = mid(rsA("FileName"), InStrRev(rsA("FileName"),"/")+1)

 

[luisengard]

That worked like a charm!
Thanks a lot for your help, much appreciated.

I am pasting the code here just in case anyone else needs it.
Apologies for the "On Error Resume Next", but I am getting an absurd error with special accentuated characters like á, é, í, ó ú. I don't know how to fix it and the code works, but very happy to fix it if anyone has suggestions!

Thanks sonic8!!!

Sub ExportAttachments()

Dim strRuta As String

strRuta = "C:\Test"

Call SaveAttachments(strRuta)

End Sub

Public Function SaveAttachments (strPath 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 strFullPath As String
Dim FileNameOnly As Variant
Dim strFileExists As String

'Get the database, recordset, and attachment field
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset("Servicios Solicitados")
Set fld = rst("Adjuntos")

'Navigate through the table
Do While Not rst.EOF

'Get the recordset for the Attachments field
Set rsA = fld.Value

'Save all attachments in the field
Do While Not rsA.EOF

FileNameOnly = Mid(rsA("FileName"), InStrRev(rsA("FileName"), "/") + 1)

If rsA("FileName") Like strPattern Then
'strFullPath = strPath & "\" & rsA("FileName")
strFullPath = strPath & "\" & FileNameOnly
'Make sure the file does not exist and save
If Dir(strFullPath) <> "" Then
Else
'rsA("FileData").SaveToFile strFullPath

On Error Resume Next

rsA("FileData").SaveToFile strFullPath
End If

'Increment the number of files saved
SaveAttachments = SaveAttachments + 1
End If

'Next attachment
rsA.MoveNext
Loop
rsA.Close

'Next record
rst.MoveNext
Loop

rst.Close
dbs.Close

Set fld = Nothing
Set rsA = Nothing
Set rst = Nothing
Set dbs = Nothing

MsgBox ("Proceso finalizado")

End Function