Need VBA Outlook help- saves over duplicate file

[state08]

Trying to auto save incoming attachments based on a rule and then running VBA to save the file to a folder. The code works but I ran into a problem when there are duplicate files named with the same name, it will just overwrite the old file. Is there a way to add to the following code a number to end of the naming convention? like 1 , 2, 3 and so on so that it will not overwrite the other file? or better yet add the date to the end of the file path when saving? Thanks for your help

Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Const saveFolder As String = "C:\Users\wrighta\Documents\Test"
For Each objAtt In itm.Attachments
objAtt.SaveAsFile saveFolder & "" & objAtt.DisplayName
Set objAtt = Nothing
Next
End Sub

[gmayor]

Use the following, versions of which I have posted here previously


Option Explicit

Public Sub saveAttachtoDisk(olItem As Outlook.MailItem)
'Graham Mayor - https://www.gmayor.com - Last updated - 26 Jun 2019
Dim olAttach As Attachment
Dim strFName As String
Dim strExt As String
Dim j As Long
Dim strSaveFldr As String


strSaveFldr = Environ("USERPROFILE") & "\Documents\Test\"
CreateFolders strSaveFldr


On Error GoTo lbl_Exit
If olItem.Attachments.Count > 0 Then
For j = 1 To olItem.Attachments.Count
Set olAttach = olItem.Attachments(j)
If Not olAttach.fileName Like "image*.*" Then
strFName = olAttach.fileName
strExt = Right(strFName, Len(strFName) - InStrRev(strFName, Chr(46)))
strFName = FileNameUnique(strSaveFldr, strFName, strExt)
olAttach.SaveAsFile strSaveFldr & strFName
End If
Next j
olItem.Save
End If
lbl_Exit:
Set olAttach = Nothing
Set olItem = Nothing
Exit Sub
End Sub


Private Function FileNameUnique(strPath As String, _
strFileName As String, _
strExtension As String) As String
'An Outlook macro by Graham Mayor
Dim lngF As Long
Dim lngName As Long
lngF = 1
lngName = Len(strFileName) - (Len(strExtension) + 1)
strFileName = Left(strFileName, lngName)
Do While FileExists(strPath & strFileName & Chr(46) & strExtension) = True
strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
lngF = lngF + 1
Loop
FileNameUnique = strFileName & Chr(46) & strExtension
lbl_Exit:
Exit Function
End Function


Private Function FileExists(filespec) As Boolean
'An Outlook macro by Graham Mayor
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(filespec) Then
FileExists = True
Else
FileExists = False
End If
lbl_Exit:
Exit Function
End Function


Private Function FolderExists(fldr) As Boolean
'An Outlook macro by Graham Mayor
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If (fso.FolderExists(fldr)) Then
FolderExists = True
Else
FolderExists = False
End If
lbl_Exit:
Exit Function
End Function


Private Function CreateFolders(strPath As String)
'An Outlook macro by Graham Mayor
Dim strTempPath As String
Dim lngPath As Long
Dim VPath As Variant
VPath = Split(strPath, "\")
strPath = VPath(0) & "\"
For lngPath = 1 To UBound(VPath)
strPath = strPath & VPath(lngPath) & "\"
If Not FolderExists(strPath) Then MkDir strPath
Next lngPath
lbl_Exit:
Exit Function
End Function