Increment file name by 1 VBA

[KDC900]

Hello,

I have found a code that saves all attachments in a table called "attachments" to a folder. I have modified it and got it to work, but the problem I have now is incrementing the file name by one every time a file name already exist. Below is the code I have.

Private Sub Command38_Click()

Dim dbs As DAO.Database
Dim rst As DAO.Recordset2
Dim rsA As DAO.Recordset2
Dim fld As DAO.Field2
Dim strPath As String
Dim strFullPath As String
Dim strPattern As String
strPattern = "*.*"
On Error GoTo ErrorHandel


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

'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 = "I:\HumRes\FP\Communication\Attachment" & "\" & rsA("FileName")

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

Else
'Increment the number of files saved
fld.Value = fld.Value + 1

rsA("FileData").SaveToFile strFullPath



End If



End If

'Next attachment
rsA.MoveNext
Loop
rsA.Close

'Next record
rst.MoveNext
Loop
ErrorHandel:
MsgBox "Error: (" & Err.Number & ") " & Err.Description, vbCritical

rst.Close
dbs.Close




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

I have looked around and tried different things but VBA is not a strong suit for me. The goal of this code is to save all attachments in the table to folder.

Thank You for any info/help on this,
KDC900

[OBP]

Can you tell me what the actual values or data is in the field1 in the rst recordset you are working through?
Also where does the "filename" in RSA("filename") come from?

[KDC900]

Hello OBP,

Field1 is an attachment field.
As far as "FileName" and "FileData", they are 2 out of the 3 values that make up the multivalue attachment field or at least that's what it looked like when I researched it.

Thank you,
KDC900

[OBP]

Unfortunately I am not familiar with attachment fields.
After the
Set fld = rst("field1")
can you enter the code
msgbox fld
and post the result on here so that I can see what the variable fld holds.
The next question is will the "other" same attachments be in the same record or subsequent records?
If so then you should create a table that stores the file names in use to make it easy to test if they are already used and what the last incremented name was.

[KDC900]

Hello OBP,

when I run the code with "msgbox fld" I get Error (13) type mismatch. as far a table for attachments, currently all attachments are saved in a separate table just for them.

Thank You,
KDC900

[OBP]

Try
msgbox fld.value

[KDC900]

Here is what came up.

[OBP]

Well that doesn't mean anything to me, does it to you?
You said in your opening comment that the code works, what filename does it create?

[KDC900]

The attachments name and .msg is what appears in the designated folder. Its manly if not all email attachments also I have never seen that symbol before. I have tried adding in to the code to where is adds a random number to the rsA(FileName) if a file exists.
Private Sub Command38_Click()

Dim dbs As DAO.Database
Dim rst As DAO.Recordset2
Dim rsA As DAO.Recordset2
Dim fld As DAO.Field2
Dim strPath As String
Dim strFullPath As String
Dim strPattern As String
strPattern = "*.*"
On Error GoTo ErrorHandel


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


'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 = "I:\HRes\FPAY\Communication\Attachment" & "\" & rsA("FileName")

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

Else
rsA("FileName") = rsA("FileName") & Rnd
strFullPath = "I:\HRes\FPAY\Communication\Attachment" & "\" & rsA("FileName")
rsA("FileData").SaveToFile strFullPath

End If


End If

'Next attachment
rsA.MoveNext
Loop
rsA.Close

'Next record
rst.MoveNext
Loop
ErrorHandel:
MsgBox "Error: (" & Err.Number & ") " & Err.Description, vbCritical

rst.Close
dbs.Close




Set fld = Nothing
Set rsA = Nothing
Set rst = Nothing
Set dbs = Nothing
End Sub
But I now get this error:

[OBP]

Do you know which line of code gives the error?
I use simple msgboxes in the code to test where it occurs ie
msgbox 0
msgbox 1
msgbox 2
in strategic places in the code

[KDC900]

The error occurs where is says

Else
rsA("FileName") = rsA("FileName") & Rnd

as soon as it hit the else it popped the Error message mentioned before.

[OBP]

Rnd is the reserved word for the Random Function and it has it's own syntax see
https://support.office.com/en-us/article/Rnd-Function-503CD2E4-3949-413F-980A-ED8FB35C1D80

Are actually trying to use a Random number rather than an actual value?

[KDC900]

Hello OBP,

it was a thought that went though my head in the hopes of it working. I did modify my code and so far I think it is doing what I want. see below:
Dim dbs As DAO.Database
Dim rst As DAO.Recordset2
Dim rsA As DAO.Recordset2
Dim fld As DAO.Field2
Dim strPath As String
Dim strFullPath As String
Dim strPattern As String
strPattern = "*.*"
On Error GoTo ErrorHandel


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


'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 = "I:\HRes\FPAY\Communication\Attachment" & "\" & Rnd & rsA("FileName")

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


End If


End If

'Next attachment
rsA.MoveNext
Loop
rsA.Close

'Next record
rst.MoveNext
Loop
ErrorHandel:
MsgBox "Error: (" & Err.Number & ") " & Err.Description, vbCritical

rst.Close
dbs.Close



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

in stead of having vba look to see if a file name exists and the adding a number I just had the name already start off with a random number. Example ".001 filename.msg". I am checking to see if all were copied out.