VBA - Save Selected Email Attachments to a folder - Keep Duplicate Items

[FireflyFL]

Here is a code I found online to save attachments from email mailbox. If I receive emails with the attachments named the same it will not save all copies. Is there away to make sure it captures all emails?

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)
On Error Resume Next


' Instantiate an Outlook Application object.
Set objOL = 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 = "FOLDERNAMEGOESHERE"


' Check each selected item for attachments.
For Each objMsg In objSelection


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.
strFile = objAttachments.Item(i).FileName

' Combine with the path to the Temp folder.
strFile = strFolderpath & 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

 

[Kenneth Hobson]

Please paste code between code tags. Click the # icon in the reply toolbar to insert the tags.

The key would be to make the filename unique. Here is a 32bit API method that creates a unique filename like Windows does:

Put this into a Module:

Const Max_Path As Integer = 260
'http://msdn.microsoft.com/en-us/library/bb776479.aspx
Public Declare Function PathYetAnotherMakeUniqueName _
  Lib "shell32.dll" _
  ( _
  ByVal pszUniqueName As String, _
  ByVal pszPath As String, _
  ByVal pszShort As String, _
  ByVal pszFileSpec As String _
  ) As Boolean

'http://msdn.microsoft.com/en-us/library/bb776476(VS.85).aspx
Public Declare Function PathMakeUniqueName _
  Lib "shell32.dll" _
  ( _
  ByVal pszUniqueName As String, _
  ByVal cchMax As Long, _
  ByVal pszTemplate As String, _
  ByVal pszLongPlate As String, _
  ByVal pszDir As String _
  ) As Boolean
  
Function fMakeAnotherUnique(vShortTemplate, vLongTemplate, vFolder) As String
  'vFolder can end in trailing backslash or not
  Dim rc As Boolean, vUniqueName As String, s As String
  vUniqueName = Space$(Max_Path)
  rc = PathYetAnotherMakeUniqueName(vUniqueName, StrConv(vFolder, vbUnicode), _
    StrConv(vShortTemplate, vbUnicode), StrConv(vLongTemplate, vbUnicode))
  If rc Then
    vUniqueName = StrConv(vUniqueName, vbFromUnicode)
    fMakeAnotherUnique = vUniqueName
  End If
End Function

Function MakeAnotherUnique(filespec As String) As String
  MakeAnotherUnique = fMakeAnotherUnique("", GetFileName(filespec), GetFolderName(filespec))
End Function

Function fMakeUnique(vShortTemplate, vLongTemplate, vFolder) As String
  'vFolder can end in trailing backslash or not
  Dim rc As Boolean, vUniqueName As String, s As String
  vUniqueName = Space$(Max_Path)
  rc = PathMakeUniqueName(vUniqueName, Max_Path, StrConv(vShortTemplate, vbUnicode), _
    StrConv(vLongTemplate, vbUnicode), StrConv(vFolder, vbUnicode))
  If rc Then
    vUniqueName = StrConv(vUniqueName, vbFromUnicode)
    fMakeUnique = vUniqueName
  End If
End Function

Function MakeUnique(filespec As String) As String
  MakeUnique = fMakeUnique("", GetFileName(filespec), GetFolderName(filespec))
End Function

Function GetFileName(filespec As String) As String
  Dim p1 As Integer, p2 As Integer
  p1 = InStrRev(filespec, "\")
  p2 = Len(filespec) - p1
  GetFileName = Mid$(filespec, p1 + 1, p2)
End Function

Function GetFolderName(filespec As String) As String
  Dim p1 As Integer
  p1 = InStrRev(filespec, "\")
  GetFolderName = Left$(filespec, p1)
End Function

At the end of the API code or another module, you can test the routines like this below. Sub Test2 method should suffice.

Sub Test1()
  Dim s As String
  s = fMakeAnotherUnique("", Environ("username") & "1.xls", ThisWorkbook.Path & "123")
  MsgBox s
  s = fMakeAnotherUnique("", ThisWorkbook.Name, ThisWorkbook.Path)
  MsgBox s
End Sub

Sub Test2()
  Dim s As String
  s = MakeAnotherUnique(ThisWorkbook.Path & "\" & Environ("username") & ".xls")
  MsgBox s
  s = MakeAnotherUnique(ThisWorkbook.FullName)
  MsgBox s
End Sub