Download Attachment From Outlook Saved Mail Item Using VBA

[SP69]

hi,

I have 150 outlook mails saved in a folder, each having an attachment. I want to download attachment from all to a folder, via VBA.
Please Help me with that.

[Excel Fox]

Here's the 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

[SP69]

Sorry if my question was not self explanatory.
I have a windows folder in which 150 mails are saved as outlook messages("*.msg").
I need to browse all and open them one by one and then download the attachment.