Outlook Save multiple attachments using the subject line, and incrementing that name - vba

Question

I've spent a couple of weeks playing with VBA, I am not by any means an expert on this.
What I'm looking for is a modification of this code.
Public Sub SaveAttachments()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Integer
Dim lngCount As Integer
Dim strFile As String
Dim strFolderpath As String
Dim strFileName As String
Dim objSubject As String
Dim strDeletedFiles As String
' Get the path to your My Documents folder
'strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
On Error Resume Next
' Instantiate an Outlook Application object.
Set objOL = CreateObject("Outlook.Application")
' Get the collection of selected objects.
Set objSelection = objOL.ActiveExplorer.Selection
' The attachment folder needs to exist
' You can change this to another folder name of your choice
' Set the Attachment folder.
strFolderpath = "C:\Users\demkep\Documents\"
' Check each selected item for attachments.
For Each objMsg In objSelection
'Set FileName to Subject
objSubject = objMsg.Subject
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count
If lngCount > 0 Then
' Use a count down loop for removing items
' from a collection. Otherwise, the loop counter gets
' confused and only every other item is removed.
For i = lngCount To 1 Step -1
' Get the file name.
strFileName = objSubject & ".pdf"
' Combine with the path to the Temp folder.
strFile = strFolderpath & strFileName
Debug.Print strFile
' Save the attachment as a file.
objAttachments.Item(i).SaveAsFile strFile
Next i
End If
Next
ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub
It is the closest to what I am trying to accomplish.
However when I get an email with multiple attachments, it will simply overwrite the last file. if possible. I'd like it to save (sometimes up to 30 .pdf files) as "emailsubject, emailsubject(1), emailsubject(2), emailsubject(3)" etc...
any help would be appreciated.

Answer 1

You are not changing the filename within the loop. Something like
strFileName = objSubject & "(" & i & ").pdf"
should take care of that.
If you only want numbers if there is more than one attachment you can check lngCount before setting the name or use IIf
If lngCount > 1 Then
strFileName = objSubject & "(" & i & ").pdf"
Else
strFileName = objSubject & ".pdf"
End If
Or
strFileName = objSubject & IIf(lngCount>1, "(" & i & ")", "") & ".pdf"
You shouldn't use On Error Resume Next on your whole sub btw.

Answer 2

Here is Function that will do exactly what you need
Function UniqueName(FilePath As String) As String
Dim FSO As Object
Set FSO = CreateObject("Scripting.FilesystemObject")
Dim FileName As String
FileName = FilePath
Dim Ext As String
Ext = Chr(46) & FSO.GetExtensionName(FilePath)
Dim i As Long
i = 1
Do While FSO.FileExists(FileName)
FileName = Left(FilePath, Len(FilePath) - Len(Ext)) & " (" & i & ")" & Ext
i = i + 1
Loop
UniqueName = FileName
End Function
And change this strFile = strFolderpath & strFileName To strFile = UniqueName(strFolderpath & strFileName)