Export Attachments to Folders (1 Viewer)

Public Function SaveAttachmentsTest2(strPath As String, Optional strPattern As String = "*.*") As Long
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim rsA As DAO.Recordset2
Dim rsB As String
Dim fld As DAO.Field2
Dim OrdID As DAO.Field2
Dim strFullPath As String

'Get the database, recordset, and attachment field
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset("database")
Set fld = rst("Attachments")
Set OrdID = rst("Item#")

'Navigate through the table
Do While Not rst.EOF

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

'Save all attachments in the field
Do While Not rsA.EOF
If rsA("FileName") Like strPattern Then
'To Export the data, use the line below
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
SaveAttachmentsTest = SaveAttachmentsTest + 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 Sub

Click to expand...

ridders said:

Yes but you won't like what I'm about to say.
Don't do it.

Attachment fields cause significant database bloat and therefore have an adverse effect on performance. Eventually you will hit the 2GB limit. Possibly before all 5000 files are attached.
Instead save the path to the files as text fields. You will still be able to access them in the same way and your database will not become large.

Also whilst I'm on the subject, you shouldn't use special characters like # in field names.
Probably better not to use Attachments either as so similar to datatype used.

Ok I've said my piece and will stay out of this from now on.

OR have I got the wrong end of the stick and you're trying to remove existing attachments?

Click to expand...

EndIfTrue said:

The last point is correct: I'm trying to remove existing attachments from the database. the goal is to move them *out* of Access and into regular folders, still categorized, so that I may upload them from there into an enterprise application

Click to expand...

so that I may upload them from there into an enterprise application

Click to expand...

Gasman said:

I'll have a bash, but note my signature

Code:Copy to clipboard

Public Function SaveAttachmentsTest2(strPath As String, Optional strPattern As String = "*.*") As Long
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim rsA As DAO.Recordset2
Dim rsB As String
Dim fld As DAO.Field2
Dim OrdID As DAO.Field2
Dim strFullPath As String[COLOR="Red"], strFolderPath as String[/COLOR]

'Get the database, recordset, and attachment field
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset("database")
Set fld = rst("Attachments")
Set OrdID = rst("Item#")

'Navigate through the table
Do While Not rst.EOF

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

'Save all attachments in the field
Do While Not rsA.EOF
If rsA("FileName") Like strPattern Then
'To Export the data, use the line below
[B][COLOR="red"][U]strFolderPath = strPath & rsA("Item#") & "\"[/U][/COLOR][/B]
strFullPath = strFolderPath & rsA("FileName")

'Create directory if it does not exist
[COLOR="red"]If Dir(strFolderPath,vbDirectory) = "" Then
	mkdir(strFolderPath)
End If[/COLOR]
'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
SaveAttachmentsTest = SaveAttachmentsTest + 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 Sub

Click to expand...

ridders said:

My apologies. Good idea to moving them out.
But what do you mean by:

Click to expand...

arnelgp said:

Public Function SaveAttachmentsTest2(strPath As String, Optional strPattern As String = "*.*") As Long

....

Click to expand...

Public Function SaveAttachmentsTest(strPath As String, Optional strPattern As String = "*.*") As Long
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim rsA As DAO.Recordset2
Dim rsB As String
Dim fld As DAO.Field2
Dim OrdID As DAO.Field2
Dim strFullPath As String
Dim thisPath As String
'Get the database, recordset, and attachment field
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset("database")
Set fld = rst("Attachments")
Set OrdID = rst("Item#")

'Navigate through the table
Do While Not rst.EOF

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

'Save all attachments in the field
Do While Not rsA.EOF
Set OrdID = rst("Item#")
If rsA("FileName") Like strPattern Then
'To Export the data, use the line below
thisPath = Replace(strPath & "" & OrdID & "", "\", "")
subMakePath thisPath
strFullPath = thisPath & 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
SaveAttachmentsTest = SaveAttachmentsTest + 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

Private Sub subMakePath(NewPath As String)
Dim var, direc
Dim sPath As String
var = Split(NewPath, "")
For Each direc In var
sPath = sPath & direc & ""
If Dir(sPath, vbDirectory) = "" Then
MkDir sPath
End If
Next
End Sub

Click to expand...