Extracting excel files from emails.

[jun25]

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.