VBA Code to Extract Excel files from multiple Outlook inbox responses and put into one excel sheet or just extract the excel files into one folder

[GaryG9595]

Hello,
I have an outlook inbox folder that has over 2000 responses with multiple attachments,excel file, and or pdf's, and or corporate logo jpg's. etc...
Is there any way to go into outlook and find only the excel files in the attachments and return the data from there into another excel spreadsheet?

They should all have the same Headers/Columns , but some may have 1 or more rows, and I would like to add the rows minus the header/top row into a new row on one spreadsheet
Example.
Email 1 has a PDF and excel file with 2 rows minus header data.
Email 2 has a excel file with 1 row minus header data, jpg.
Email 3 has a jpg,PDF.
Import sheet would have row 1 as headers and same columns names and VBA would fill in Rows 2 and 3 from Email 1 minus header row and fill in row 4 from Email 2 minus header row, and would skip Email 3, but keep searching inbox until all messages are searched.

Or if there's VBA code that would just extract all attachments into one folder, I have a code that can pull just the excel files from there. This one may be easier.

Either solution would work for me, Can anyone help?
Thanks in advance.
Gary

 

[Logit]

Well ... there are several examples on the internet that might help :

Extract Attachments from Saved Outlook Emails using Excel VBA

Option Explicit

Const csOutlookIn As String = "In"
Const csOutlookOut As String = "Out"

Sub Extract_Emails_Demo1()
Application.ScreenUpdating = False

Dim sCurrentFolder As String
sCurrentFolder = ActiveWorkbook.Path & "\"

Dim FSO As Scripting.FileSystemObject
Set FSO = New Scripting.FileSystemObject

Dim fldrOutlookIn As Scripting.Folder
Set fldrOutlookIn = FSO.GetFolder(sCurrentFolder & csOutlookIn)

Dim oApp As Outlook.Application
Set oApp = New Outlook.Application

Dim oMail As Outlook.MailItem
Dim oAttach As Outlook.Attachment

Dim fileItem As Scripting.File
Dim sAttachName As String
For Each fileItem In fldrOutlookIn.Files
    Set oMail = oApp.CreateItemFromTemplate(fileItem.Path)
    For Each oAttach In oMail.Attachments
        sAttachName = oAttach.Filename
        sAttachName = sCurrentFolder & csOutlookOut & "\" & sAttachName
        oAttach.SaveAsFile sAttachName
    Next oAttach
    Set oMail = Nothing
Next fileItem

MsgBox "Done!"
Application.ScreenUpdating = True
End Sub

Save E-mail attachments to folder

Sub SaveEmailAttachmentsToFolder(OutlookFolderInInbox As String, _
                                 ExtString As String, DestFolder As String)
    Dim ns As Namespace
    Dim Inbox As MAPIFolder
    Dim SubFolder As MAPIFolder
    Dim Item As Object
    Dim Atmt As Attachment
    Dim FileName As String
    Dim MyDocPath As String
    Dim I As Integer
    Dim wsh As Object
    Dim fs As Object

    On Error GoTo ThisMacro_err

    Set ns = GetNamespace("MAPI")
    Set Inbox = ns.GetDefaultFolder(olFolderInbox)
    Set SubFolder = Inbox.Folders(OutlookFolderInInbox)

    I = 0
    ' Check subfolder for messages and exit of none found
    If SubFolder.Items.Count = 0 Then
        MsgBox "There are no messages in this folder : " & OutlookFolderInInbox, _
               vbInformation, "Nothing Found"
        Set SubFolder = Nothing
        Set Inbox = Nothing
        Set ns = Nothing
        Exit Sub
    End If

    'Create DestFolder if DestFolder = ""
    If DestFolder = "" Then
        Set wsh = CreateObject("WScript.Shell")
        Set fs = CreateObject("Scripting.FileSystemObject")
        MyDocPath = wsh.SpecialFolders.Item("mydocuments")
        DestFolder = MyDocPath & "\" & Format(Now, "dd-mmm-yyyy hh-mm-ss")
        If Not fs.FolderExists(DestFolder) Then
            fs.CreateFolder DestFolder
        End If
    End If

    If Right(DestFolder, 1) <> "\" Then
        DestFolder = DestFolder & "\"
    End If

    ' Check each message for attachments and extensions
    For Each Item In SubFolder.Items
        For Each Atmt In Item.Attachments
            If LCase(Right(Atmt.FileName, Len(ExtString))) = LCase(ExtString) Then
                FileName = DestFolder & Item.SenderName & " " & Atmt.FileName
                Atmt.SaveAsFile FileName
                I = I + 1
            End If
        Next Atmt
    Next Item

    ' Show this message when Finished
    If I > 0 Then
        MsgBox "You can find the files here : " _
             & DestFolder, vbInformation, "Finished!"
    Else
        MsgBox "No attached files in your mail.", vbInformation, "Finished!"
    End If

    ' Clear memory
ThisMacro_exit:
    Set SubFolder = Nothing
    Set Inbox = Nothing
    Set ns = Nothing
    Set fs = Nothing
    Set wsh = Nothing
    Exit Sub

    ' Error information
ThisMacro_err:
    MsgBox "An unexpected error has occurred." _
         & vbCrLf & "Please note and report the following information." _
         & vbCrLf & "Macro Name: SaveEmailAttachmentsToFolder" _
         & vbCrLf & "Error Number: " & Err.Number _
         & vbCrLf & "Error Description: " & Err.Description _
         , vbCritical, "Error!"
    Resume ThisMacro_exit

End Sub

VBA code in Outlook for extracting Excel attachments

Sub GetAttachments()
' This Outlook macro checks a the Outlook Inbox for messages
' with attached files (of any type) and saves them to disk.
' NOTE: make sure the specified save folder exists before
' running the macro.
    On Error GoTo GetAttachments_err
' Declare variables
    Dim ns As NameSpace
    Dim Inbox As MAPIFolder
    Dim Item As Object
    Dim Atmt As Attachment
    Dim FileName As String
    Dim i As Integer
    Set ns = GetNamespace("MAPI")
    Set Inbox = ns.GetDefaultFolder(olFolderInbox)
    i = 0
' Check Inbox for messages and exit of none found
    If Inbox.Items.Count = 0 Then
        MsgBox "There are no messages in the Inbox.", vbInformation, _
               "Nothing Found"
        Exit Sub
    End If
' Check each message for attachments
    For Each Item In Inbox.Items
        If Item.UnRead = True Then 'Add this for checking unread emails
            ' Save any attachments found
                    For Each Atmt In Item.Attachments
                        If (Right(Atmt.FileName, 4) = "xlsx") Or (Right(Atmt.FileName, 4) = ".xls") Then
                        ' This path must exist! Change folder name as necessary.
                            FileName = "C:\Documents and Settings\epadillo\Desktop\test\" & _
                                Format(Item.CreationTime, "yyyymmdd_hhnnss_") & Atmt.FileName
                            Atmt.SaveAsFile FileName
                            Item.UnRead = False 'Mark email item as read
                            i = i + 1
                        End If
                Next Atmt
        End If
    Next Item

' Show summary message
    If i > 0 Then
        MsgBox "I found " & i & " attached files." _
        & vbCrLf & "I have saved them into the C:\Users\vduraiswamy\Desktop\attachments." _
        & vbCrLf & vbCrLf & "Have a nice day.", vbInformation, "Finished!"
    Else
        MsgBox "I didn't find any attached files in your mail.", vbInformation, "Finished!"
    End If
' Clear memory
GetAttachments_exit:
    Set Atmt = Nothing
    Set Item = Nothing
    Set ns = Nothing
    Exit Sub
' Handle errors
GetAttachments_err:
    MsgBox "An unexpected error has occurred." _
        & vbCrLf & "Please note and report the following information." _
        & vbCrLf & "Macro Name: GetAttachments" _
        & vbCrLf & "Error Number: " & Err.Number _
        & vbCrLf & "Error Description: " & Err.Description _
        , vbCritical, "Error!"
    Resume GetAttachments_exit
End Sub

 

[GaryG9595]

Well ... there are several examples on the internet that might help :

Extract Attachments from Saved Outlook Emails using Excel VBA

Option Explicit

Const csOutlookIn As String = "In"
Const csOutlookOut As String = "Out"

Sub Extract_Emails_Demo1()
Application.ScreenUpdating = False

Dim sCurrentFolder As String
sCurrentFolder = ActiveWorkbook.Path & "\"

Dim FSO As Scripting.FileSystemObject
Set FSO = New Scripting.FileSystemObject

Dim fldrOutlookIn As Scripting.Folder
Set fldrOutlookIn = FSO.GetFolder(sCurrentFolder & csOutlookIn)

Dim oApp As Outlook.Application
Set oApp = New Outlook.Application

Dim oMail As Outlook.MailItem
Dim oAttach As Outlook.Attachment

Dim fileItem As Scripting.File
Dim sAttachName As String
For Each fileItem In fldrOutlookIn.Files
    Set oMail = oApp.CreateItemFromTemplate(fileItem.Path)
    For Each oAttach In oMail.Attachments
        sAttachName = oAttach.Filename
        sAttachName = sCurrentFolder & csOutlookOut & "\" & sAttachName
        oAttach.SaveAsFile sAttachName
    Next oAttach
    Set oMail = Nothing
Next fileItem

MsgBox "Done!"
Application.ScreenUpdating = True
End Sub

Save E-mail attachments to folder

Sub SaveEmailAttachmentsToFolder(OutlookFolderInInbox As String, _
                                 ExtString As String, DestFolder As String)
    Dim ns As Namespace
    Dim Inbox As MAPIFolder
    Dim SubFolder As MAPIFolder
    Dim Item As Object
    Dim Atmt As Attachment
    Dim FileName As String
    Dim MyDocPath As String
    Dim I As Integer
    Dim wsh As Object
    Dim fs As Object

    On Error GoTo ThisMacro_err

    Set ns = GetNamespace("MAPI")
    Set Inbox = ns.GetDefaultFolder(olFolderInbox)
    Set SubFolder = Inbox.Folders(OutlookFolderInInbox)

    I = 0
    ' Check subfolder for messages and exit of none found
    If SubFolder.Items.Count = 0 Then
        MsgBox "There are no messages in this folder : " & OutlookFolderInInbox, _
               vbInformation, "Nothing Found"
        Set SubFolder = Nothing
        Set Inbox = Nothing
        Set ns = Nothing
        Exit Sub
    End If

    'Create DestFolder if DestFolder = ""
    If DestFolder = "" Then
        Set wsh = CreateObject("WScript.Shell")
        Set fs = CreateObject("Scripting.FileSystemObject")
        MyDocPath = wsh.SpecialFolders.Item("mydocuments")
        DestFolder = MyDocPath & "\" & Format(Now, "dd-mmm-yyyy hh-mm-ss")
        If Not fs.FolderExists(DestFolder) Then
            fs.CreateFolder DestFolder
        End If
    End If

    If Right(DestFolder, 1) <> "\" Then
        DestFolder = DestFolder & "\"
    End If

    ' Check each message for attachments and extensions
    For Each Item In SubFolder.Items
        For Each Atmt In Item.Attachments
            If LCase(Right(Atmt.FileName, Len(ExtString))) = LCase(ExtString) Then
                FileName = DestFolder & Item.SenderName & " " & Atmt.FileName
                Atmt.SaveAsFile FileName
                I = I + 1
            End If
        Next Atmt
    Next Item

    ' Show this message when Finished
    If I > 0 Then
        MsgBox "You can find the files here : " _
             & DestFolder, vbInformation, "Finished!"
    Else
        MsgBox "No attached files in your mail.", vbInformation, "Finished!"
    End If

    ' Clear memory
ThisMacro_exit:
    Set SubFolder = Nothing
    Set Inbox = Nothing
    Set ns = Nothing
    Set fs = Nothing
    Set wsh = Nothing
    Exit Sub

    ' Error information
ThisMacro_err:
    MsgBox "An unexpected error has occurred." _
         & vbCrLf & "Please note and report the following information." _
         & vbCrLf & "Macro Name: SaveEmailAttachmentsToFolder" _
         & vbCrLf & "Error Number: " & Err.Number _
         & vbCrLf & "Error Description: " & Err.Description _
         , vbCritical, "Error!"
    Resume ThisMacro_exit

End Sub

VBA code in Outlook for extracting Excel attachments

Sub GetAttachments()
' This Outlook macro checks a the Outlook Inbox for messages
' with attached files (of any type) and saves them to disk.
' NOTE: make sure the specified save folder exists before
' running the macro.
    On Error GoTo GetAttachments_err
' Declare variables
    Dim ns As NameSpace
    Dim Inbox As MAPIFolder
    Dim Item As Object
    Dim Atmt As Attachment
    Dim FileName As String
    Dim i As Integer
    Set ns = GetNamespace("MAPI")
    Set Inbox = ns.GetDefaultFolder(olFolderInbox)
    i = 0
' Check Inbox for messages and exit of none found
    If Inbox.Items.Count = 0 Then
        MsgBox "There are no messages in the Inbox.", vbInformation, _
               "Nothing Found"
        Exit Sub
    End If
' Check each message for attachments
    For Each Item In Inbox.Items
        If Item.UnRead = True Then 'Add this for checking unread emails
            ' Save any attachments found
                    For Each Atmt In Item.Attachments
                        If (Right(Atmt.FileName, 4) = "xlsx") Or (Right(Atmt.FileName, 4) = ".xls") Then
                        ' This path must exist! Change folder name as necessary.
                            FileName = "C:\Documents and Settings\epadillo\Desktop\test\" & _
                                Format(Item.CreationTime, "yyyymmdd_hhnnss_") & Atmt.FileName
                            Atmt.SaveAsFile FileName
                            Item.UnRead = False 'Mark email item as read
                            i = i + 1
                        End If
                Next Atmt
        End If
    Next Item

' Show summary message
    If i > 0 Then
        MsgBox "I found " & i & " attached files." _
        & vbCrLf & "I have saved them into the C:\Users\vduraiswamy\Desktop\attachments." _
        & vbCrLf & vbCrLf & "Have a nice day.", vbInformation, "Finished!"
    Else
        MsgBox "I didn't find any attached files in your mail.", vbInformation, "Finished!"
    End If
' Clear memory
GetAttachments_exit:
    Set Atmt = Nothing
    Set Item = Nothing
    Set ns = Nothing
    Exit Sub
' Handle errors
GetAttachments_err:
    MsgBox "An unexpected error has occurred." _
        & vbCrLf & "Please note and report the following information." _
        & vbCrLf & "Macro Name: GetAttachments" _
        & vbCrLf & "Error Number: " & Err.Number _
        & vbCrLf & "Error Description: " & Err.Description _
        , vbCritical, "Error!"
    Resume GetAttachments_exit
End Sub

Thank you. I always come here first. I have found the most help here from the people on this forum than any other site. I did search here and could not find what I was looking for then I searched using google. didn't find anything at first, but I did find a solution at another site and Version 3.0 worked, but it pulled all the attachments, which is fine, because I can then target a folder and pull just the excel files with a macro I have already.
Thanks again for your help. I am going to try the code you posted about extracting just the excel files next.
Posting this, in case it may help someone else down the road, maybe even me as I have short term memory.

 

[Logit]

Best wishes.

 

[smozgur]

The marked solution post has been switched with the one that contains at least one method that could be adapted in order to solve the original question.

@GaryG9595 - if @Logit's solution doesn't solve your question for some reason, and if you'd like to post the solution that you found at another site and adapt it to your problem that solves the problem as you explained and needed, then it is perfectly fine to mark your own post as the solution as it will help future readers. Otherwise, please do not mark a post that doesn't contain a solution.