jun25
08-17-2015, 04:58 AM
I am writing to request some help in regards extracting excel attachments from outlook emails.
I have found the following code which is able to extract all attachments from specific outlook email folder. However, I would like the code below to be able to do the following:
· Extract only excel attachments formats = xls, xlsx & csv.
· Extract all the attachments attachment into sheets of one workbook – excel file, instead of multiple excel files in the ‘outlook file’ folder.
Sub GetAttachments()
Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim i As Integer
Dim myExt As String
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox).Folders("Offer")
i = 0
If Inbox.Items.Count = 0 Then
MsgBox "There are no messages in the Inbox.", vbInformation, _
"Nothing Found"
Exit Sub
End If
For Each Item In Inbox.Items
For Each Atmt In Item.Attachments
Select Case myExt
Case "xls", "xlsm", "xlsx"
FileName = "C:\Users\Jun\Desktop\Outlook_files\" & Atmt.FileName
Atmt.SaveAsFile FileName
i = i + 1
Case Else
'do nothing
End Select
Next Atmt
Next Item
GetAttachments_exit:
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
Exit Sub
End Sub
Any further assistance or help would be very much appreciated. Many Thanks.
I have found the following code which is able to extract all attachments from specific outlook email folder. However, I would like the code below to be able to do the following:
· Extract only excel attachments formats = xls, xlsx & csv.
· Extract all the attachments attachment into sheets of one workbook – excel file, instead of multiple excel files in the ‘outlook file’ folder.
Sub GetAttachments()
Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim i As Integer
Dim myExt As String
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox).Folders("Offer")
i = 0
If Inbox.Items.Count = 0 Then
MsgBox "There are no messages in the Inbox.", vbInformation, _
"Nothing Found"
Exit Sub
End If
For Each Item In Inbox.Items
For Each Atmt In Item.Attachments
Select Case myExt
Case "xls", "xlsm", "xlsx"
FileName = "C:\Users\Jun\Desktop\Outlook_files\" & Atmt.FileName
Atmt.SaveAsFile FileName
i = i + 1
Case Else
'do nothing
End Select
Next Atmt
Next Item
GetAttachments_exit:
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
Exit Sub
End Sub
Any further assistance or help would be very much appreciated. Many Thanks.