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

FireflyFL

New Member
Joined
Sep 18, 2018
Messages
3
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
 

Excel Facts

Who is Mr Spreadsheet?
Author John Walkenbach was Mr Spreadsheet until his retirement in June 2019.
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:
Code:
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.
Code:
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
 
Last edited:
Upvote 0

Forum statistics

Threads
1,223,164
Messages
6,170,444
Members
452,326
Latest member
johnshaji

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top