saving all attachments where the some of the attachments have thesame name

[nosliwmada]

I had this problem and saw no answers so I wrote a macro to do it.
You are welcome to it. I'm currently using Outlook 2003 (SP3) and I
haven't tested this code on any other version.

To "install" it:
1. in Outlook on the menu bar select "Tools"->"Macro"->"Visual Basic
Editor" (or alternately hit Alt + F11)
2. when the "Microsoft Visual Basic" window comes up, on its menu bar
select "Insert" ->"Module"
3. paste in the code below
4. on the "Microsoft Visual Basic" window's menu bar select "Tools"-

"References..."

5. on the small "References" window that pops up, scroll down until
you see "Microsoft Scripting Runtime", check the checkbox beside it
and click the "OK" button.
6. click the save button (or hit ctrl + s, or from the menu bar select
"File"->"Save")
7. from the "Microsoft Visual Basic" window's menu bar select "Debug"-

"Compile Project1" (note that it is the first item in the menu and

begins with the word "Compile")
8. close the "Microsoft Visual Basic" window

now that it is "installed", any time you want to save a bunch of
attachments into a directory:
1. select the emails (you can select more than 1) that you want to
save the attachments for
2. on the Outlook menu bar select "Tools"->"Macro"->"Macros" (or hit
Alt+F8)
3. select the macro named "SaveSameNameAttachments"
4. click the "Run" button.
5. enter the directory name that you want to save to (a default one
comes up) and click the "OK" button
6. when it is done saving it will let you know.

enjoy!

-------code begins below this line--------


Option Explicit

Private Const DEFAULT_ATTACHMENT_SAVE_DIRECTORY As String = "C:\My
Attachments"
Private Const MAXIMUM_FILENAME_NUMBER_SUFFIX As Integer = 999

Private objFSO As Scripting.FileSystemObject

Sub SaveSameNameAttachments()

'Declaration
Dim objMailItems, objMailItem, objAttachments, objAttachment As
Object
Dim strFolderPath As String
Dim objOutlookSelection As Outlook.Selection

Set objFSO = New Scripting.FileSystemObject

'get destination folder from user
strFolderPath = InputBox("Destination", "Save Attachments",
DEFAULT_ATTACHMENT_SAVE_DIRECTORY)

On Error Resume Next

'make sure that the destination folder exists
If Not objFSO.FolderExists(strFolderPath) Then
objFSO.CreateFolder (strFolderPath)
End If

Set objOutlookSelection = GetCurrentlySelectedItems()

If Not (objOutlookSelection Is Nothing) Then
'loop through all of the selected emails
For Each objMailItem In objOutlookSelection
Set objAttachments = objMailItem.Attachments

'loop through all of the attachments for the current email
For Each objAttachment In objAttachments
SaveAttachment strFolderPath, objAttachment
Next objAttachment

Next objMailItem
End If

'object cleanup
Set objFSO = Nothing
Set objMailItems = Nothing
Set objMailItem = Nothing
Set objAttachments = Nothing
Set objAttachment = Nothing
Set objOutlookSelection = Nothing

MsgBox "Done saving all attachments", vbOKOnly, "Attachments
Saved"

End Sub


Private Function GetCurrentlySelectedItems() As Outlook.Selection

On Error GoTo GetCurrentlySelectedItems_error

Dim objReturn As Outlook.Selection
Dim objOutlookApp As New Outlook.Application
Dim objOutlookExplorer As Outlook.Explorer

'get pointers to the selected items
Set objOutlookExplorer = objOutlookApp.ActiveExplorer
Set objReturn = objOutlookExplorer.Selection

Set objOutlookApp = Nothing
Set objOutlookExplorer = Nothing


Set GetCurrentlySelectedItems = objReturn

Exit Function


GetCurrentlySelectedItems_error:
Err.Clear

Set GetCurrentlySelectedItems = Nothing

End Function



Private Sub SaveAttachment(FolderPath As String, AttachmentObject As
Object)

Dim strFilePath As String

strFilePath = GetValidFilepathName(FolderPath, AttachmentObject)

If Len(strFilePath) > 0 Then
AttachmentObject.SaveAsFile strFilePath
End If

End Sub



Private Function GetValidFilepathName(FolderPath As String,
AttachmentObject As Object) As String

On Error GoTo GetValidFilepathName_error

Dim strFilename As String
Dim strReturn As String
Dim strPossibleFilePath As String
Dim intSuffixNumber As Integer
Dim intNumberOfPrefixZeros As Integer
Dim strZeroPrefix As String
Dim strBaseFilename As String
Dim strFilenameExtension As String

strFilename = AttachmentObject.FileName

strBaseFilename = objFSO.GetBaseName(strFilename)
strFilenameExtension = objFSO.GetExtensionName(strFilename)

'to keep things nicely lined up, these local variables are for
formatting
'the number suffixes in the form of "0001", "0002", etc.
intNumberOfPrefixZeros = Len(CStr(MAXIMUM_FILENAME_NUMBER_SUFFIX))

strZeroPrefix = String(intNumberOfPrefixZeros, "0")

strReturn = objFSO.BuildPath(FolderPath, strFilename)

'only loop through the number suffixes if the original filename
doesn't exist
If objFSO.FileExists(strReturn) Then
intSuffixNumber = 0

Do
intSuffixNumber = intSuffixNumber + 1

strPossibleFilePath = objFSO.BuildPath(FolderPath,
strBaseFilename & Right(strZeroPrefix & CStr(intSuffixNumber), 3) &
"." & strFilenameExtension)

Loop While objFSO.FileExists(strPossibleFilePath) And
intSuffixNumber <= MAXIMUM_FILENAME_NUMBER_SUFFIX

If intSuffixNumber > MAXIMUM_FILENAME_NUMBER_SUFFIX Then
MsgBox "Ran out of numbers suffixes for " &
AttachmentObject.FileName

strReturn = ""
Else
strReturn = strPossibleFilePath
End If
End If


GetValidFilepathName = strReturn

Exit Function


GetValidFilepathName_error:
Err.Clear

GetValidFilepathName = ""

End Function