Solved: Extract Excel Files from Outlook

[bradh_nz]

Hi

I have the below code which extracts excel files from Outlook and saves them in a folder. This works fine however when there are more than 20 emails it leaves 2 behind, ie 30 emails will only return 28. Any help appreciated.

Sub SaveAttachmentsToFolder()
' This Outlook macro checks a named subfolder in the Outlook Inbox
' (here the "Sales Reports" folder) for messages with attached
' files of a specific type (here file with an "xls" extension)
' and saves them to disk. Saved files are timestamped. The user
' can choose to view the saved files in Windows Explorer.
' NOTE: make sure the specified subfolder and save folder exist
' before running the macro.
On Error GoTo SaveAttachmentsToFolder_err
' Declare variables
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 i As Integer
Dim varResponse As VbMsgBoxResult
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder = Inbox.Folders("FRSC Excel") ' Enter correct subfolder name.
'Set Inbox = ns.GetDefaultFolder(olPublicFoldersAllPublicFolders)
'Set SubFolder = AllPublicFolders.Folders("FRSC Excel") ' Enter correct subfolder name.

i = 0
' Check subfolder for messages and exit of none found
If SubFolder.Items.Count = 0 Then
MsgBox "There are no messages in the Sales Reports folder.", vbInformation, _
"Nothing Found"
Exit Sub
End If
' Check each message for attachments
For Each Item In SubFolder.Items
For Each Atmt In Item.Attachments
' Check filename of each attachment and save if it has "xls" extension
If Right(Atmt.FileName, 3) = "xls" Then
' This path must exist! Change folder name as necessary.
FileName = "\\BBF00366\Brad.Hancock$\Brad (file:////BBF00366/Brad.Hancock$/Brad) Working Folder\FRSC Files\" & _
Format(Item.CreationTime, "yyyymmdd_hhnnss_") & Atmt.FileName
Atmt.SaveAsFile FileName
i = i + 1
End If
Next Atmt
Next Item
' Show summary message
If i > 0 Then
varResponse = MsgBox("I found " & i & " attached files." _
& vbCrLf & "I have saved them into the C:\Email Attachments folder." _
& vbCrLf & vbCrLf & "Would you like to view the files now?" _
, vbQuestion + vbYesNo, "Finished!")
' Open Windows Explorer to display saved files if user chooses
If varResponse = vbYes Then
Shell "Explorer.exe /e,C:\Email Attachments", vbNormalFocus
End If
Else
MsgBox "I didn't find any attached files in your mail.", vbInformation, "Finished!"
End If
' Clear memory
SaveAttachmentsToFolder_exit:
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
Exit Sub
' Handle Errors
SaveAttachmentsToFolder_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 SaveAttachmentsToFolder_exit
End Sub

[Oorang]

Hi Brad,
Charlize (http://www.vbaexpress.com/forum/member.php?u=5928) has actually written a nice KB article on this. It is pending Charlize's final review so it is not released yet, but here is a draft copy.

Edit:
Removed draft copy as link to live article (http://vbaexpress.com/kb/getarticle.php?kb_id=953) is now posted below.

[Charlize]

Last night I (we = me and Oorang) have worked on this article. It is nearly finished (waiting for Oorang to give feedback if it's working on a different setup. I've tested this on office 2007 and it seemed to work like expected.) but you better wait to implement the already given code (because there are made some significant changes about the attachment handling --- and which files to process, by using an array of file extensions ---).

[Oorang]

Article is live. Go here:
http://vbaexpress.com/kb/getarticle.php?kb_id=953

[kmurphy]

Hello,
I am very newto this so please bear with me. I really have a need for the script in this article, but can't locate where the file naming occurs.
Can anyone help?

Kevin Murphy

[Charlize]

The name is created using this function Private Function BuildFileName(ByRef number As Long, ByRef mlItem As _
Outlook.MailItem, ByRef attchmnt As Outlook.Attachment, _
Optional dateFormat As String = "m_d_yyyy-H-MM-SS") As String
'Builds file name to preferred format. Can be changed to personal
'prefernce.
Const strInfoDlmtr_c As String = " - "
Const lngMxFlNmLen_c As Long = 255
BuildFileName = VBA.Left$(number & strInfoDlmtr_c & _
Format$(mlItem.ReceivedTime, dateFormat) & strInfoDlmtr_c & _
mlItem.SenderName & strInfoDlmtr_c & attchmnt.FileName, lngMxFlNmLen_c)
End FunctionBut the previous function uses this function to get the number of files in a directory. In case of multiple files with the same name (you never know).Private Function CountFiles(strPath As String) As Integer
'Counts the no of files in a directory
Dim FSO As Object
Dim fldr As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Set fldr = FSO.GetFolder(strPath)
CountFiles = fldr.Files.Count
Set fldr = Nothing
Set FSO = Nothing
End Function And the declaring of the saving path is done here :Public Sub SaveAttachmentRule(myItem As Outlook.MailItem, ParamArray _
PreferredFileExts() As Variant)
'Place to save the attachments
Const strRootFolder_c As String = "C:\Data\Appendices\"
Const strStockMsg_c As String = "The file was saved to: "

rest of coding ...Was this helpfull to get you going ?

[goofy78270]

I like this code but I am having one issue. How do I move my email to a folder in a second mailbox? A sample structure is below:

My Mailbox
Inbox
Contacts
...

Second Mailbox
Inbox - this is the mailbox I am searching
Target folder - sub folder of Inbox that I would like to move the email to.

[Oorang]

Hi goofy,
Welcome to the board, take a look at this thread over here (http://www.vbaexpress.com/forum/showthread.php?t=15498), I think it should address your question.

[Charlize]

I like this code but I am having one issue. How do I move my email to a folder in a second mailbox? A sample structure is below:

My Mailbox
Inbox
Contacts
...

Second Mailbox
Inbox - this is the mailbox I am searching
Target folder - sub folder of Inbox that I would like to move the email to.You can try this to pick the folder to process. Maybe add an additional check if the folder contains mailitems.Sub select_mailbox()
Dim folder As Outlook.folder
Set folder = Application.GetNamespace("MAPI").PickFolder
MsgBox "Chosen folder to process : " & folder
End Sub

[swtrader]

Copied this code and it worked wonderfully. (I know very, very little about VBA.) How can I change the Outlook folder that it searches (say a subfolder in my Inbox)?

Thanks for the code. A great solution to a big problem of bloating email!

[Charlize]

Dim ns As NameSpace
Dim Inbox as MAPIFolder
Dim SubFolder As MAPIFolder
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder = Inbox.Folders("Sales Reports")

[swtrader]

Thanks very much!!

[JAG836]

If I want to use this to download a file that gets updated and send to me every day, will this automatically overwrite the old file (the incoming file and the existing file are always the same file name)?

Edit: How would I adapt this to use it with a rule I created? The rule takes the email sent by him, with the specific subject name and places it into a subfolder of my Inbox, titled "M5 Scorecard". I also do not want it to remove the attachments from the email

[JAG836]

anyone?

[Oorang]

Hi Jag,
The Outlook.Attachment.SaveAsFile method will overwrite without prompting. Depending on your needs this may (or may not) be desirable behavior. This is why in the example provided their is a BuildFileName procedure. In general it should build unique file names, as it incorporates a timestamp that includes seconds.
However if you have more than one attachment from the same person, with the same file name, recieved in the same second, then there would be an overwrite.
If you were concerned about it, you could tweak the name builder event to use the Scripting.FileSystemObject.FileExists method to make sure you don't generate a name that already exists.