Solved: Automatically Save Excel file from Outlook Exchange to PC File

[Gil]

Hello

I am attempting to save an Excel file from Outlook Exchange to a file on my pc automatically when an email arrives. In my Inbox I have a rule that moves an email with the word Testing in the Subject to a sub folder called Project, it then is set to run a script, which I assume is the code that I placed in Project 1/This Outlook session.
All this as a result of trawling the Outlook forum and finding this possible solution from JP2112 in a thread dated 09-09-2009. I have seen several others which all seem to be variations of this code.
Trouble is I cannot get it to work for me. I have changed the bits that I think are particular to my set up but am now stuck. This code may go a bit further than I need but if someone could review it and point me in the right direction I am quite happy to try and edit out the bits I need.
One question to start is in my novice attempts at Excel I was often told to put Option Explicit first, this doen't seem to work with this code.
A second question is in Set Items = objns.GetDefaultFolder(olFolderInbox).Items I tried to change olFolderInbox to olFolderProject.
Any help would be greatly appreciated.




Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim objns As Outlook.NameSpace
Set objns = GetNamespace("MAPI")
Set Items = objns.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub Items_ItemAdd(ByVal item As Object)
On Error Goto ErrorHandler
Const folder As String = "d:\Desktop\Project Log\"
Const fileExtensions As String = "xls"
Dim fileExts As Variant
Dim Msg As Outlook.MailItem
Dim atts As Outlook.Attachments
Dim att As Outlook.Attachment
Dim i As Long, j As Long
Dim strFilePath As String
' parse file extensions
fileExts = Split(fileExtensions, ",")
' only act on mail items
If TypeName(item) <> "MailItem" Then Goto ProgramExit
Set Msg = item
' exit if message is too small or no attachments
If (Msg.Size < 1500000) And (Msg.Attachments.Count = 0) Then Goto ProgramExit
Set atts = Msg.Attachments
' loop through attachments, if the file extension matches one of the
' specified file types, save it to the given folder
With atts
For i = .Count To 1 Step -1
If UBound(Filter(fileExts, GetFileType(.item(i).fileName))) > -1 Then
strFilePath = folder & BuildFileName(.Count, Msg, .item(i))
With .item(i)
.SaveAsFile strFilePath
.Delete
End With
If Msg.BodyFormat = olFormatHTML Then
Msg.HTMLBody = Msg.HTMLBody & "<p>" & _
"The file was saved to: " & strFilePath & "</p>"
Else
Msg.Body = Msg.Body & vbCrLf & "The file was saved to: " & strFilePath & vbCrLf
End If
End If
Next i
End With
Msg.Save
MsgBox "Xls files are extracted from" & vbCrLf & _
"the emails in Project folder.", vbInformation
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.number & " - " & Err.Description
Resume ProgramExit
End Sub
Function GetFileType(ByVal fileName As String) As String
' get file extension
GetFileType = Mid$(fileName, InStrRev(fileName, ".") + 1, Len(fileName))
End Function
Private Function BuildFileName(ByRef number As Long, ByRef mlItem As Outlook.MailItem, ByRef att 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
'preference.
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 & att.fileName, lngMxFlNmLen_c)
End Function

[JP2112]

Where is the folder called "Project" located? You'll need to adjust this line to walk the folder hierarchy:
Set Items = objns.GetDefaultFolder(olFolderInbox).Items
For example, if the folder is one level below the default Inbox, this code would work:
Set Items = objns.GetDefaultFolder(olFolderInbox).Folders("Project").Items
The code you are using is doing a few extra things which you probably don't want. For example, if the message is below a certain size the code exits. I don't think you want that.
I assume the rule is doing the heavy lifting (i.e. checking for the correct email), and all you need is a script which takes any new message in the Project folder. If so, this would work fine:
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objns As Outlook.NameSpace
Set olApp = Outlook.Application
Set objns = olApp.GetNamespace("MAPI")
Set Items = objns.GetDefaultFolder(olFolderInbox).Folders("Project").Items
End Sub
Private Sub Items_ItemAdd(ByVal item As Object)
On Error Goto ErrorHandler
Const folder As String = "d:\Desktop\Project Log\"
Dim msg As Outlook.MailItem
Dim msgAttachs As Outlook.Attachments
' assume that we have the correct item
Set msg = Item
Set msgAttachs = msg.Attachments
msgAttachs.Item(1).SaveAsFile folder & msgAttachs.Item(1).FileName
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.number & " - " & Err.Description
Resume ProgramExit
End Sub

[Gil]

Hello JP2112
Thank you for the reply. Yes you assumed right that the Project folder is a sub folder of the Inbox. And yes all I want is the Excel attachment to either copy to or move to my chosen PC file.
Forgive me but I am a novice in this VBA field but my question is does all the code go in the ThisOutlookSession General Field.
I obviously cannot get it to work so if you have any additional suggestions I would be grateful.

Gil

[JP2112]

It gets pasted into the ThisOutlookSession module. I assume you have no other code there?

If you need placement assistance, see Where do I put my Outlook VBA code? (http://www.codeforexcelandoutlook.com/outlook-vba/where-do-i-put-my-outlook-vba-code/)

Once you paste the code there, you must restart Outlook.

If you have to make changes to the code in the future, you have to restart Outlook each time.

I think the code I gave you should work, but after restarting Outlook you should probably set a breakpoint in the ItemAdd Event and then drop a matching email into the Project folder. Then you can step through the code to make sure it's doing what you want.

[Gil]

Hello JP2112
Thank you for your reply. I had placed the code in the correct place. I read through the link you gave and am happy that part is ok. I have restarted Outlook and still no success.
If I step in to
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objns As Outlook.NameSpace
Set olApp = Outlook.Application
Set objns = olApp.GetNamespace("MAPI")
Set Items = objns.GetDefaultFolder(olFolderInbox).Folders("Project").Items
End Sub
I can step through to the end.

But if I try to step into the next,
Private Sub Items_ItemAdd(ByVal item As Object)
On Error Goto ErrorHandler
Const folder As String = "d:\Desktop\Project Log\"
Dim msg As Outlook.MailItem
Dim msgAttachs As Outlook.Attachments
' assume that we have the correct item
Set msg = Item
Set msgAttachs = msg.Attachments
msgAttachs.Item(1).SaveAsFile folder & msgAttachs.Item(1).FileName
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.number & " - " & Err.Description
Resume ProgramExit
End Sub
part I just get a warning bell 'ting'

What am I missing (apart from the knowledge)

Gil

[JP2112]

You can't step through the code using traditional means, because there is no "Item" when the code is run.

Because it is event-driven, you have to either wait for a message to organically appear in that folder, or simply drag and drop an email into that folder, to trigger the event properly.

What I suggested was, after restarting Outlook, open the VB Editor and set a breakpoint in the code (highlight the first line and press F9). That way, the code will stop before it executes, and only then can you continue the code by stepping through it.

[Gil]

Hello JP2112
AhA, when you are let in to the secrets it all starts to become clear, first attempts look promising with the attachment being copied successfully.
What would trigger the Error Handler
Gi
l:cloud9::beerchug:

[JP2112]

Lots of things could trigger the error handler, for example,

1- if you copy a non-MailItem to the folder,
2- if you copy a MailItem but it has no attachments,
3- If the folder doesn't exist or is not writeable or is not available (due to network issues, if applicable).


Also, if a Rule has overlapping conditions with the code, the execution will be unpredictable (sometimes the code runs first, other times the script runs first). So if possible do not set up any Rules that would conflict with the operation of the code.

[Gil]

Hello JP2112
Thank you for your reply. It is all working well for me now. I will be quite happy to close this thread as 100% complete and judging from the many other threads that remain open requesting a similar action perhaps some may visit this thread and complete their own tasks using the info and guidance you have given me.

Many thanks
Gil
:thumb :beerchug:

[sanka66]

Hi,

I have the below code to get into my subfolders and it works as a manually driven part of the macro.. but i need to automatically run it on a incoming mail. problem is i have multiple inboxes, subfolders with rules set so incoming mail get driven to the subfolder and 'thisoutlooksession' as far as i can tell (im new to vb outlook...) can only handle one inbox/subfolder... is this correct??

Thanks,
Jay

Function GetFolder(strFolderPath As String) As MAPIFolder
' strFolderPath needs to be something like
' "Public Folders\All Public Folders\Company\Sales" or
' "Personal Folders\Inbox\My Folder"

Dim objApp As Outlook.Application
Dim objns As Outlook.NameSpace
Dim colFolders As Outlook.Folders
Dim objFolder As Outlook.MAPIFolder
Dim arrFolders() As String
Dim i As Long
On Error Resume Next

strFolderPath = Replace(strFolderPath, "/", "\")
arrFolders() = Split(strFolderPath, "\")
Set objApp = Application
Set objns = objApp.GetNamespace("MAPI")
Set objFolder = objns.Folders.item(arrFolders(0))
If Not objFolder Is Nothing Then
For i = 1 To UBound(arrFolders)
Set colFolders = objFolder.Folders
Set objFolder = Nothing
Set objFolder = colFolders.item(arrFolders(i))
If objFolder Is Nothing Then
Exit For
End If
Next
End If

Set GetFolder = objFolder
Set colFolders = Nothing
Set objns = Nothing
Set objApp = Nothing
End Function

[Gil]

Hello sanka66
I am no expert in this field at all. When you say you have multiple inboxes do you mean multiple email addresses going to one inbox and then to subfolders off that.
Gil