Save Attachment Macro

Hello,

A while ago, someone had written me a code for Outlook.  I recieve many e-mails that contain attachments.  I always save these specific attachments locally, so after a while it became a pain in manually saving each attachment - one by one.

In using this code, I select all e-mails that I want - that have attachments & click on my "Save Attachments" button.  Then it saves it to a preset location.

I do NOT know anything about coding this,...  and I am not the one who wrote the code origionally.

There is a  revision I would like to the code though to avoid some problems I've been having.

1.)  Do not overwrite files with the same file name.

A possible work around would be if the code found that there was a file with the same file name, instead of overwriting it, it would add "(2)" onto the end of the file name.

Example...

BettyJane.jpg
BettyJane(2).jpg

xp310Asked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

xp310Author Commented:
Oh wow, I'm not with it today...

Here's the existing macro I do have.

Sub SaveAttachment()

    'Declaration
    Dim myItems, myItem, myAttachments, myAttachment As Object
    Dim myOrt As String
    Dim myOLApp As New Outlook.Application
    Dim myOlExp As Outlook.Explorer
    Dim myOlSel As Outlook.Selection
   
    'Ask for destination folder
    myOrt = InputBox("Destination", "Save Attachments", "C:\Attachments\Attachment - ")

    On Error Resume Next
   
    'work on selected items
    Set myOlExp = myOLApp.ActiveExplorer
    Set myOlSel = myOlExp.Selection
   
    'for all items do...
    For Each myItem In myOlSel
   
        'point on attachments
        Set myAttachments = myItem.Attachments
       
        'if there are some...
        If myAttachments.Count > 0 Then
       
            'add remark to message text
            myItem.Body = myItem.Body & vbCrLf & _
                "E-mail Attachment(s): Automatically Saved to Location Below" & vbCrLf
               
            'for all attachments do...
            For i = 1 To myAttachments.Count
           
                'save them to destination
                myAttachments(i).SaveAsFile myOrt & _
                    myAttachments(i).DisplayName

                'add name and destination to message text
                myItem.Body = myItem.Body & _
                    "File: " & myOrt & _
                    myAttachments(i).DisplayName & vbCrLf
                   
            Next i
           
            'for all attachments do...
            While myAttachments.Count > 0
           
                'remove it (use this method in Outlook XP)
                'myAttachments.Remove 1
               
                'remove it (use this method in Outlook 2000)
                myAttachments(1).Delete
               
            Wend
           
            'save item without attachments
            myItem.Save
        End If
       
    Next
   
    'free variables
    Set myItems = Nothing
    Set myItem = Nothing
    Set myAttachments = Nothing
    Set myAttachment = Nothing
    Set myOLApp = Nothing
    Set myOlExp = Nothing
    Set myOlSel = Nothing
   
End Sub
David LeeCommented:
Hi xp310,

Try this, it works for me on Outlook 2003.

Sub SaveAttachment()

    'Declaration
    Dim myItems, myItem, myAttachments, myAttachment
    Dim myOrt As String
    Dim myOLApp As New Outlook.Application
    Dim myOlExp As Outlook.Explorer
    Dim myOlSel As Outlook.Selection
    Dim objFSO As Object
    Dim intCount As Integer
   
    'Ask for destination folder
    'myOrt = InputBox("Destination", "Save Attachments", "C:\Attachments\Attachment - ")
    myOrt = InputBox("Destination", "Save Attachments", "C:\eetesting\Attachments\")

    'On Error Resume Next
   
    Set objFSO = CreateObject("Scripting.FileSystemObject")
   
    'work on selected items
    Set myOlExp = myOLApp.ActiveExplorer
    Set myOlSel = myOlExp.Selection
   
    'for all items do...
    For Each myItem In myOlSel
   
        'point on attachments
        Set myAttachments = myItem.Attachments
       
        'if there are some...
        If myAttachments.Count > 0 Then
       
            'add remark to message text
            myItem.Body = myItem.Body & vbCrLf & _
                "E-mail Attachment(s): Automatically Saved to Location Below" & vbCrLf
               
            'for all attachments do...
            For i = 1 To myAttachments.Count
                strFileName = myAttachments(i).DisplayName
                intCount = 1
                Do While True
                    If objFSO.FileExists(myOrt & strFileName) Then
                        strFileName = objFSO.GetBaseName(myOrt & strFileName) & "(" & intCount & ")." & objFSO.GetExtensionName(myOrt & strFileName)
                        intCount = intCount + 1
                    Else
                        myAttachments(i).SaveAsFile myOrt & strFileName
                        Exit Do
                    End If
                Loop
           
                'add name and destination to message text
                myItem.Body = myItem.Body & _
                    "File: " & myOrt & strFileName & vbCrLf
                   
            Next i
           
            'for all attachments do...
            While myAttachments.Count > 0
           
                'remove it (use this method in Outlook XP)
                'myAttachments.Remove 1
               
                'remove it (use this method in Outlook 2000)
                myAttachments(1).Delete
               
            Wend
           
            'save item without attachments
            myItem.Save
        End If
       
    Next
   
    'free variables
    Set myItems = Nothing
    Set myItem = Nothing
    Set myAttachments = Nothing
    Set myAttachment = Nothing
    Set myOLApp = Nothing
    Set myOlExp = Nothing
    Set myOlSel = Nothing
   
End Sub

Cheers!

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Outlook

From novice to tech pro — start learning today.