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.
Example
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)
Else
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!"
Else
MsgBox "I didn't find any Excel files in your mail.", _
vbInformation, "Finished!"
TodaysFileWb.Close False
End If
' Clear memory
GetAttachments_exit:
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
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!"
Application.StatusBar = False
Resume GetAttachments_exit
End Sub
Getting Attached xls files from the Inbox of Outolook
