Saving Outlook E-mail Attachments To a Folder

I was looking for some code samples as I wanted to save e-mail attachments to a folder. Below is the code I got from I modified it a bit as I did not want to touch the original e-mails...

In Outlook, hit Alt+F11, double click modules and paste it into module1
Sub SaveSelectedAttachment()

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", _

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 & _
' "Removed Attachments:" & vbCrLf

'for all attachments do...
For i = 1 To myAttachments.Count

'save them to destination
myAttachments(i).SaveAsFile myOrt & _

'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


'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

I have also seen a lot of useful code examples here

No comments: