title: Renaming same name Multiple email attachments when Copying from outlook
body: <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>