Here's the code
Code:
Sub DownloadAndSaveOutlookAttachments()
Dim objFolder As Outlook.MAPIFolder
Dim objOlMainItem As Outlook.MailItem
Dim objOlMainItem2 As Outlook.MailItem
Dim strFilePath As String
Dim strTmpMsg As String
Dim sSavePathFS As String
Dim blnFlag As Boolean
Dim objAtc As Attachment
Dim objAtc2 As Attachment
Const strSaveFolder As String = "D:\Outlook Attachment\"
'path for creating attachment objOlMainItem file for stripping
strFilePath = Environ("TEMP") & "\"
strTmpMsg = "TemporaryMessageSave.objOlMainItem"
'===============================================================================
'If you want to specify a particular folder within the Inbox folder in Outlook, like "temp" folder, use the following code
'===============================================================================
'Set objFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
'Set objFolder = objFolder.Folders("Temp")
'===============================================================================
'===============================================================================
'===============================================================================
'To pick a folder yourself, use the following code
Set objFolder = Application.GetNamespace("MAPI").PickFolder
'===============================================================================
'===============================================================================
If objFolder Is Nothing Then Exit Sub
For Each objOlMainItem In objFolder.Items
For Each objAtc In objOlMainItem.Attachments
blnFlag = False
If Right$(objAtc.FileName, 3) = "objOlMainItem" Then
blnFlag = True
objAtc.SaveAsFile strFilePath & strTmpMsg
Set objOlMainItem2 = Application.CreateItemFromTemplate(strFilePath & strTmpMsg)
End If
If blnFlag Then
For Each objAtc2 In objOlMainItem2.Attachments
sSavePathFS = strSaveFolder & objAtc2.FileName
objAtc2.SaveAsFile sSavePathFS
Next objAtc2
objOlMainItem2.Delete
Else
sSavePathFS = strSaveFolder & objAtc.FileName
objAtc.SaveAsFile sSavePathFS
End If
Next objAtc
Next objOlMainItem
If Len(sSavePathFS) Then
MsgBox "Done"
Else
MsgBox "No attachments found"
End If
End Sub
Bookmarks