Renaming same name Multiple email attachments when Copying from outlook
<p>Historically I was using Excel and lotus notes to do this, company is transitioning thru to Outlook 2016 as it's standard email client.</p>

<p>We get daily reports to a mailbox from our Fridge units at multiple branches. each branch is a separate email but some of the attachments are named the same.</p>

<p>I used a script that copied the attachments from LN and it had a private function that in the processing of copying the attachments it would rename them if they had the same name.</p>

<p>I found a script here at stack overflow that I modified to save the attachments from Outlook into a Network folder. That works fine.</p>

<p>Here is the script</p>

<pre><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 Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String

' Get the path to your My Documents folder
'strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
strFolderpath = "J:\Clayton\Logistics\Plantwatch\REPORTS\ZDumpSites\"
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

' Set the Attachment folder.
strFolderpath = strFolderpath '&amp; "\Attachments\"

' Check each selected item for attachments. If attachments exist,
' save them to the strFolderPath folder and strip them from the item.
For Each objMsg In objSelection

    ' This code only strips attachments from mail items.
    ' If objMsg.class=olMail Then
    ' Get the Attachments collection of the item.
    Set objAttachments = objMsg.Attachments
    lngCount = objAttachments.Count
    strDeletedFiles = ""

    If lngCount &gt; 0 Then

        ' We need to 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

            ' Save attachment before deleting from item.
            ' Get the file name.
            strFile = objAttachments.Item(i).FileName

            ' Combine with the path to the Temp folder.
            strFile = strFolderpath &amp; strFile

            ' Save the attachment as a file.
            objAttachments.Item(i).SaveAsFile strFile

            ' Delete the attachment.
            'objAttachments.Item(i).Delete

            'write the save as path to a string to add to the message
            'check for html and use html tags in link
            If objMsg.BodyFormat &lt;&gt; olFormatHTML Then
                strDeletedFiles = strDeletedFiles &amp; vbCrLf &amp; "&lt;file://" &amp; strFile &amp; "&gt;"
            Else
                strDeletedFiles = strDeletedFiles &amp; "&lt;br&gt;" &amp; "&lt;a href='file://" &amp; _
                strFile &amp; "'&gt;" &amp; strFile &amp; "&lt;/a&gt;"
            End If

            'Use the MsgBox command to troubleshoot. Remove it from the final code.
            'MsgBox strDeletedFiles

        Next i

        ' Adds the filename string to the message body and save it
        ' Check for HTML body
        If objMsg.BodyFormat &lt;&gt; olFormatHTML Then
            objMsg.Body = vbCrLf &amp; "The file(s) were saved to " &amp; strDeletedFiles &amp; vbCrLf &amp; objMsg.Body
        Else
            objMsg.HTMLBody = "&lt;p&gt;" &amp; "The file(s) were saved to " &amp; strDeletedFiles &amp; "&lt;/p&gt;" &amp; objMsg.HTMLBody
        End If
        objMsg.Save
    End If
Next

ExitSub:

Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub
</code></pre>

<p>I am trying to add this Function to this Script:</p>

<pre><code>Private Function UniqueFileName(ByVal Fn As String) As String  ' Rename same Name files.

    Dim Fun As String                     ' Function return value
    Dim Sp() As String                    ' Split file name
    Dim Ext As Long                       ' file extension character count
    Dim i As Integer                      ' file name index

    Sp = Split(Fn, ".")
    If UBound(Sp) Then Ext = Len(Sp(UBound(Sp))) + 1
    Fun = stPath &amp; Fn
    Do While Len(Dir(Fun))
        i = i + 1
        Fun = stPath &amp; Left(Fn, Len(Fn) - Ext) &amp; _
              "(" &amp; CStr(i) &amp; ")" &amp; Right(Fn, Ext)
        If i &gt; 100 Then Exit Do
    Loop
    UniqueFileName = Fun
End Function
</code></pre>

<p>But search as I can I cannot see where this would fit or be added to the script.</p>

<p>How can I add this function to the excellent Script above to rename same named attachments?  </p>

<p>I suspect I am missing something simple!</p>