Export Attachments to Folders

[EndIfTrue]

Hello all,

So, I happen to be moving ~5000 documents for a project. Each one has been inserted into Microsoft Access under a column, "Attachments". Then each has been associated with a label under the column "Item#".

The objective is to write code that creates folders for each Item#, then dumps all attachments into their respective Item# folder.

I have seen code that accomplishes parts of this, but I can't yet make a complete solution.

So far I have been able to dump all files into a single folder using the following:

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

Anyone have thoughts on refining my method so it fits the end solution?

Thanks!!


Edit: Solution found! See my last post below if you're interested. And once again, a big thanks to all involved!

 

[Gasman]

You need to append the value of Item# to strPath, and create the directory if it does not exist?

 

[EndIfTrue]

Essentially, I'm trying to create folders for the attachments to go into. I'm pretty new to Access and VBA and working on a tight deadline

 

[isladogs]

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?

 

[EndIfTrue]

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?

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

 

[isladogs]

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

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

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

 

[Gasman]

I'll have a bash, but note my signature

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
[COLOR="red"]strFolderPath = strPath & rsA("Item#") & "\"[/COLOR]
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

 

[EndIfTrue]

I'll have a bash, but note my signature

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

I think we're close! However, the bolded/underlined line above returned the error "Item not found in this collection". Interesting

(Side note: the original code does "work," it just doesn't put the items into ITEM# folders as needed)

 

[EndIfTrue]

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

The files have to be migrated into the org's system of record, which requires them to be in basic files/folders before upload. It lacks the capability of receiving inputs from Access

Hence why I'm in this predicament

 

[Cronk]

You can create a subfolder using
Mkdir ("PathToParent folder" & "\ChildFolder")


The path of the folder in which the attachments are being currently being extracted is passed to your function ie strPath. You don't give any information about how to derive the names of the folders you want to create.

 

[arnelgp]

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
dim thisPath as string
'Get the database, recordset, and attachment field
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset("database")
Set fld = rst("Attachments")


'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 Sub

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

 

[EndIfTrue]

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

....

Thank you, sir!

I couldn't be more grateful for all of your help! With this batch of code, we have turned two weeks of work into 20 minutes. +rep!

For the sake of continuity, here is my final code. I just had to add the "set OrdID" reference to make it work.

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

 

[arnelgp]

You are welcome!