Getting Attached xls files from the Inbox of Outolook

This program would check Outlook Inbox for messages with attached Excel files and saves the attached files to disk, at the same time copying their worksheets to a single new workbook in Excel.


Place the following in a standard module. Please note: THIS CODE REQUIRES A REFERENCE TO THE CURRENT VERSION OF OUTLOOK TO BE SET: In the VB Editor go to Tools > References and tick Microsoft Outlook [Version] Object Library. This code is currently referenced to Outlook 11.0 (Office 2003).

Option Explicit
'Code by Gareth Lombard
Sub GetAttachments()
    On Error GoTo GetAttachments_err

    ' Declare variables for communicating with Outlook
    Dim appOl As New Outlook.Application
    Dim nsOl As Outlook.Namespace
    Dim Inbox As Outlook.MAPIFolder
    Dim Item As Object
    Dim Atmt As Outlook.Attachment
    Set nsOl = appOl.GetNamespace("MAPI")
    Set Inbox = nsOl.GetDefaultFolder(olFolderInbox)

    ' Declare variables for doing Excel work
    Dim FileName As String
    Dim TodaysFile As String
    Dim objSheet As Worksheet
    Dim EmptySheets As Integer

    'Declare constant for saving attached files
    'Change here to your own preferred path
    Const sFolder As String = "C:\data\"

    ' These variables are counters to log work done
    Dim i As Integer
    Dim x As Integer
    Dim z As Integer
    i = 0
    x = 0

    '//Amended by Colo
    Dim TodaysFileWb As Workbook
    Dim flg As Boolean
    Dim intSheetInNewWb As Integer

    With Application
        intSheetInNewWb = .SheetsInNewWorkbook
        .SheetsInNewWorkbook = 1
    End With

    ' Turn of screen updating for speed
    Application.StatusBar = "Checking your mail..."
    Application.ScreenUpdating = False

    ' Create new workbook Amended by Colo
    Set TodaysFileWb = Workbooks.Add
    TodaysFileWb.Sheets(1).Name = "Result"

    ' Check Inbox for messages and check each message for attachments
    If Inbox.Items.Count > 0 Then
        For Each Item In Inbox.Items
    ' Loop through attachments (there may be more than one)
            For Each Atmt In Item.Attachments
    ' If attachment is an Excel file (name ends with "xls") save the file to disk
                If Right(Atmt.FileName, 3) = "xls" Then
                    FileName = sFolder & Atmt.FileName
                    Atmt.SaveAsFile FileName
                    i = i + 1
    ' Open the file in Excel and note its name (short name without path)
                    Workbooks.Open FileName
                    FileName = ActiveWorkbook.Name
    ' Copy each worksheet (if it is not empty) to new workbook
                    For Each objSheet In ActiveWorkbook.Sheets
                        If objSheet.UsedRange.Cells.Count > 1 Then
    '//Amended by Colo
                            If flg Then
                                objSheet.UsedRange.Copy _
                                TodaysFileWb.Sheets(1).Cells _
                                                        (TodaysFileWb.Sheets(1).Cells. _
                                                         SpecialCells(11).Row + 1, 1)
                                objSheet.UsedRange.Copy _
                                TodaysFileWb.Sheets(1).Cells(1, 1)
                                flg = True
                            End If
                            x = x + 1
                        End If
                    Next objSheet
    ' Close the file without saving any changes
                    Workbooks(FileName).Close Savechanges:=False
                End If
            Next Atmt
        Next Item
    End If
    ' Restore screen updating and show summary message. Throw away
    ' new workbook if nothing was found
    Application.ScreenUpdating = True
    Application.StatusBar = False
    If i > 0 Then
        MsgBox "I found " & i & " Excel files containing a total of " _
             & x & " sheets of data." _
             & vbCrLf & "I have copied them into " & TodaysFileWb.Name & "." _
             & vbCrLf & vbCrLf & "Have a nice day.", vbInformation, "Finished!"
        MsgBox "I didn't find any Excel files in your mail.", _
               vbInformation, "Finished!"
        TodaysFileWb.Close False
    End If
    ' Clear memory
    Set Atmt = Nothing
    Set Item = Nothing
    Set nsOl = Nothing
    Set appOl = Nothing
    '//Amended by Colo
    Set TodaysFileWb = Nothing
    '//Amended by Colo
    Application.SheetsInNewWorkbook = intSheetInNewWb

    Exit Sub
    ' Error handler
    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!"
    Application.StatusBar = False
    Resume GetAttachments_exit
End Sub

| HOME |
Copyright © cellmasters.net - colo's junk room All Right Reserved
Tips and Information about Microsoft Excel|Masaru Kaji aka Colo