Auto Save Attachments from multiple senders

[telepicker]

Brian,

Here is the full code as it stands. It was posted above the snipet and a few other comments above.

For now any code actions should only be performed on the 1st Sender & Subject combination 2 and 3 are only testing that the attachment is saved on receipt from those 2 Sender & Subject.

But - Upon receipt of an valid Sender & Subject combination (i.e. conditions met for email 2 or 3) my code/actions/process that is supposed to be specific to email 1 kicks off.
In other words my code is not distinguishing when it should run and when it should not based on the email received.

I hope that makes sense

Here is what mode is actually doing:

1. Save the attachment to the designated folder.
2. Calling code from PERSONAL.XLSB!TA_Unzip and unzipping the attachment (As I know it will be in a zip file).
3. Saving the unzipped file to a new folder.
4. Close the Excel Personal Wkbook.
5. Opening Access 2010.
6. Importing the "saved file" (original attachment).
7. Running the macro "Report Process" which is a series of macros that creates an Excel report with multiple worksheets.
8. Programatically emails the reports to designated receipients (Access 2010 through Outlook 2010 with help from ClickYES).
9. Send completion email to my self for verification
10. Close Access
11. Mark the original email as read.

[vba]
Private WithEvents Items As Outlook.Items
Option Explicit

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).Items
End Sub
Private Sub Items_ItemAdd(ByVal Item As Object)

Dim Msg As Outlook.MailItem
Dim attPath As String
Dim Att As String
Dim myAttachments As Attachments
Dim XLApp As Object ' Excel.Application
Dim appAccess As Object ' Access.Application
Dim XlWK As Object ' Excel.Workbook
Dim boolDownload As Boolean
boolDownload = False

On Error Goto ErrorHandler
'Only act if it's a MailItem

If TypeName(Item) = "MailItem" Then
Set Msg = Item


If Msg.Sender = "Doe, Jane" And Msg.Subject = "Test1" Then
attPath = "G:\Daily\TA\"
boolDownload = True
ElseIf Msg.SenderEmailAddress = "someone@gmail.com" And Msg.Subject = "Test2" Then
attPath = "G:\Daily\TA\"
boolDownload = True
ElseIf Msg.Sender = "Doe, John" And Msg.Subject = "Test3" Then
attPath = "G:\Daily\TA\"
boolDownload = True
End If
If boolDownload = True Then

' open wkbk and run import macro
Dim olDestFldr As Outlook.MAPIFolder


' New Excel.Application
Set XLApp = CreateObject("Excel.Application")

' save attachment
Set myAttachments = Item.Attachments
Att = myAttachments.Item(1).DisplayName
myAttachments.Item(1).SaveAsFile attPath & Att


' open personal.xls where macro is stored, and run macro
On Error Resume Next
XLApp.Workbooks.Open ("C:\Documents and Settings\gregory.l.young\Application Data\Microsoft\Excel\XLSTART\PERSONAL.XLSB")
On Error Goto 0
XLApp.Run ("PERSONAL.XLSB!TA_Unzip")
XLApp.Workbooks.Close
Kill attPath & Att
XLApp.Quit

' Get a reference to the Access Application object.
Set appAccess = CreateObject("Access.Application")

' open TA database and build reports with timer pause to allow time to run
Dim tim As Long
appAccess.OpenCurrentDatabase ("G:\Daily\TA\TA.accdb")
tim = Timer
Do While Timer < tim + 2
DoEvents
Loop

' hide the application.
appAccess.Visible = False
appAccess.DoCmd.RunMacro "Report Process"

' Close the database and quit Access
'appAccess.CloseCurrentDatabase
'appAccess.Quit

' Close the object variable.
Set appAccess = Nothing

' mark as read and move to msgs folder
Msg.UnRead = False
'Msg.Move olDestFldr
End If
End If
ProgramExit:
Exit Sub

ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub

[/vba]

[BrianMH]

Ok if I'm clear if it meets the conditions for the first email/subject combo you want it to do everything.

If it meets the conditions of the second and third combinations you want it to download the attachment but do nothing else?

if so then this should work

[VBA]Private WithEvents Items As Outlook.Items
Option Explicit

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).Items
End Sub
Private Sub Items_ItemAdd(ByVal Item As Object)

Dim Msg As Outlook.MailItem
Dim attPath As String
Dim Att As String
Dim myAttachments As Attachments
Dim XLApp As Object ' Excel.Application
Dim appAccess As Object ' Access.Application
Dim XlWK As Object ' Excel.Workbook
Dim boolDownload As Boolean
boolDownload = False

On Error Goto ErrorHandler
'Only act if it's a MailItem

If TypeName(Item) = "MailItem" Then
Set Msg = Item

Set myAttachments = Item.Attachments
Att = myAttachments.Item(1).DisplayName

If Msg.Sender = "Doe, Jane" And Msg.Subject = "Test1" Then
attPath = "G:\Daily\TA\"
boolDownload = True
myAttachments.Item(1).SaveAsFile attPath & Att
ElseIf Msg.SenderEmailAddress = "someone@gmail.com" And Msg.Subject = "Test2" Then
attPath = "G:\Daily\TA\"
myAttachments.Item(1).SaveAsFile attPath & Att

ElseIf Msg.Sender = "Doe, John" And Msg.Subject = "Test3" Then
attPath = "G:\Daily\TA\"
myAttachments.Item(1).SaveAsFile attPath & Att
End If
If boolDownload = True Then

' open wkbk and run import macro
Dim olDestFldr As Outlook.MAPIFolder


' New Excel.Application
Set XLApp = CreateObject("Excel.Application")




' open personal.xls where macro is stored, and run macro
On Error Resume Next
XLApp.Workbooks.Open ("C:\Documents and Settings\gregory.l.young\Application Data\Microsoft\Excel\XLSTART\PERSONAL.XLSB")
On Error Goto 0
XLApp.Run ("PERSONAL.XLSB!TA_Unzip")
XLApp.Workbooks.Close
Kill attPath & Att
XLApp.Quit

' Get a reference to the Access Application object.
Set appAccess = CreateObject("Access.Application")

' open TA database and build reports with timer pause to allow time to run
Dim tim As Long
appAccess.OpenCurrentDatabase ("G:\Daily\TA\TA.accdb")
tim = Timer
Do While Timer < tim + 2
DoEvents
Loop

' hide the application.
appAccess.Visible = False
appAccess.DoCmd.RunMacro "Report Process"

' Close the database and quit Access
'appAccess.CloseCurrentDatabase
'appAccess.Quit

' Close the object variable.
Set appAccess = Nothing

' mark as read and move to msgs folder
Msg.UnRead = False
'Msg.Move olDestFldr
End If
End If
ProgramExit:
Exit Sub

ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub [/VBA]

[telepicker]

Yes - that is exactly what I am trying to accomplish.

I see where you have associated the
[vba]myAttachments.Item(1).SaveAsFile attPath & Att
[/vba]

to each mail item. My question is how does this explicitly associate the Excel and Access macros to mail item 1?

What if I needed (and I will) to run a different Macro or other function explicitly for mail tem 2 or 3 individually?

Should I go back and build from the method you posted
Yesterday, 12:41 PM post # 34 and incorporate the Call method?

It looked very neat and clean - I just do not understand how to apply the call for each seperate instance based on the mail item. I get the concept just not the format of how to code it.

I believe it would be a different set of "functions or actions" for each call type and then associate them to the mail item as they apply. Is that the idea?

[BrianMH]

[vba]Private WithEvents Items As Outlook.Items
Option Explicit

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).Items
End Sub
Private Sub Items_ItemAdd(ByVal Item As Object)

Dim myItem As Outlook.MailItem
Dim strAttPath As String
Dim strAtt As String
Dim strFullPath As String
Dim myAttachments As Attachments
Dim myAtt As Attachment
Dim olDestFldr As Outlook.MAPIFolder


On Error GoTo ErrorHandler
'Only act if it's a MailItem

If TypeName(Item) = "MailItem" Then
Set myItem = Item

Set myAttachments = Item.Attachments
Set myAtt = myAttachments.Item(1)
strAtt = myAtt.DisplayName
strFullPath = strAttPath & strAtt

If (myItem.SenderEmailAddress = "someone@ltr.com" Or myItem.Sender = "someone@ltr.com") And myItem.Subject = "Test1" Then
strAttPath = "G:\Daily \Test\TT Report\"
myAtt.SaveAsFile strFullPath
Call xlAcsub(strFullPath)
myItem.UnRead = False
'myItem.Move olDestFldr

ElseIf (myItem.SenderEmailAddress = "someoneelse@ltr.com" Or myItem.Sender = "someoneelse@ltr.com") And myItem.Subject = "Test2" Then
strAttPath = "G:\Daily \Test\UMTA Report\"
myAtt.SaveAsFile strFullPath
'Call anothersub
myItem.UnRead = False
'myItem.Move olDestFldr

ElseIf (myItem.SenderEmailAddress = "email@gmail.com" Or myItem.Sender = "email@gmail.com") And myItem.Subject = "test1" Then
strAttPath = "C:\Users\Brian\Desktop\"
myAtt.SaveAsFile strFullPath
'Call stillanothersub
myItem.UnRead = False
'myItem.Move olDestFldr

End If


End If
ProgramExit:
Exit Sub

ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub

Sub xlAcsub(strToKill As String)
On Error GoTo ErrorHandler
Dim XLApp As Object ' Excel.Application
Dim appAccess As Object ' Access.Application
Dim XlWK As Object ' Excel.Workbook
Dim tim As Long
Set XLApp = CreateObject("Excel.Application")
Set appAccess = CreateObject("Access.Application")

XLApp.Workbooks.Open ("C:\Documents and Settings\gregory.l.young\Application Data\Microsoft\Excel\XLSTART\PERSONAL.XLSB")
XLApp.Run ("PERSONAL.XLSB!TA_Unzip")
XLApp.Workbooks.Close
Kill strToKill
XLApp.Quit

tim = Timer
Do While Timer < tim + 2
DoEvents
Loop
appAccess.Visible = False
appAccess.DoCmd.RunMacro "Report Process"
' Close the database and quit Access
'appAccess.CloseCurrentDatabase
'appAccess.Quit

' Close the object variable.
Set appAccess = Nothing

ProgramExit:
Exit Sub

ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub


[/vba]
This should be more like what your looking for. Personally I would add references to excel and access and code it all in outlook instead of calling the functions in those applications but thats just my personal preference. I left quite a bit of your commented out code in because I wasn't sure what you were wanting to uncomment in the future.

Hope that clears it up a bit. I would also suggest you do some reading about vba functions and passing variables. Once you understand this it will really help your coding. Another helpful bit is to learn to assign object variables instead of using references to them.

ie

[vba]
sub openandcloseworkbook
dim wbToOpen as workbook
set wbToOpen = workbooks.open("C:\workbook.xls")
wbToOpen.close false
end sub
[/vba]
instead of

[vba]
sub openandcloseworkbook
workbooks.open("C:\workbook.xls")
workbooks("workbook.xls").close false
end sub
[/vba]

when you define objects as what they are when you type wbToOpen. <
you will get a dropdown of all the options you have to work with this object.

[telepicker]

Brian - thank you. I have not had a chance to try this yet. I will let you know as soon as I do. Thanks again for staying with me on this.

[BrianMH]

No problem. Got to keep busy. Idle hands and all .

[telepicker]

I have test the code this am it does not save the attachment file. The only part that is working is the
[vba]
myItem.UnRead = False
'myItem.Move olDestFldr
[/vba]

[BrianMH]

Can't see anything that would cause it not to work. Do you get an error message?

[telepicker]

The code did not through an error it just failed to save the attachment or call the script.
I am trying to work through debugging now - I will follow up when I either

1) succeed
2) fail
3) get lost

Thanks for keeping an eye out.

[telepicker]

Thanks to Brian, I have finally resolved this completely and it works tremendously! I am posting trhe code with the names of the drives and email senders to protect the guilty.

Hopefully this will help someone else out somewhere down the line.
Here is what the code is actually doing:

• Checks Outlook inbox for a specific MSG Sender and MSG Subject with an attachment. (Not tested on any file type other than Excel, but I would believe it could process any type of attachment).
• If there is a match then the attachement is saved in the designated folder.
• If Sender or Subject does not match then no action is taken.
• In my code If the email from Sender, Joe has a zip file attached, the Sub TA_Unzip is called and the zip file is automatically unzipped and saved in the designated location. I use XStandard.ZIP - google it and you will find it easily - free app you just need to save the .dll file and make it active in your Resources - Library.
• After that file is unzipped then the Sub Opens an Access db, imports the file and then process through 10 different macros to produce various reports.
• When completed the reports are automatically emailed through Outlook 2010 (Must use an like ClickYes to work around the security pop-ups in Outlook).

Here is the code:

[vba]
Private WithEvents Items As Outlook.Items
Option Explicit

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).Items
End Sub
Private Sub Items_ItemAdd(ByVal Item As Object)

Dim Msg As Outlook.MailItem
Dim attPath As String
Dim Att As String
Dim strFullPath As String
Dim myAttachments As Attachments
Dim myAtt As Attachment
Dim olDestFldr As Outlook.MAPIFolder


On Error GoTo ErrorHandler
'Only act if it's a MailItem

If TypeName(Item) = "MailItem" Then
Set Msg = Item
Set myAttachments = Item.Attachments
Att = myAttachments.Item(1).DisplayName
myAttachments.Item(1).SaveAsFile attPath & Att
If (Msg.Sender = "Sender, Joe") And _
(Msg.Subject = "My Report") And _
(Msg.Attachments.Count >= 1) Then
attPath = "G:\Daily Report\Reports\"
myAttachments.Item(1).SaveAsFile attPath & Att
Call Report_Unzip
Msg.UnRead = False
'Msg.Move olDestFldr

ElseIf (Msg.Sender = "Jane Sender") And _
(Msg.Subject = "Test Mail 2") And _
(Msg.Attachments.Count >= 1) Then
attPath = "I:\Mail\"
myAttachments.Item(1).SaveAsFile attPath & Att
Msg.UnRead = False
'Msg.Move olDestFldr

ElseIf (Msg.Sender = "Mail Subscriptions") And _
(Msg.Subject = "Test Mail 3") And _
(Msg.Attachments.Count >= 1) Then
attPath = "C:\Documents and Settings\myfolder name\My Documents\Test File\"
myAttachments.Item(1).SaveAsFile attPath & Att
Msg.UnRead = False
'Msg.Move olDestFldr


End If
End If
ProgramExit:
Exit Sub

ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub

Sub TA_Unzip()
On Error GoTo ErrorHandler
Dim appAccess As Object ' Access.Application
Dim objZip
Set objZip = CreateObject("XStandard.Zip")
objZip.UnPack "G:\Daily Report\Reports\Daily_Report.zip", "G:\Daily Report\Reports\"
Set objZip = Nothing
' Get a reference to the Access Application object.
Set appAccess = CreateObject("Access.Application")

' open TA database and build reports with timer pause to allow time to run
Dim tim As Long
appAccess.OpenCurrentDatabase ("G:\Daily Report\Reports\Report_db.accdb")
tim = Timer
Do While Timer < tim + 2
DoEvents
Loop

' hide the application.
appAccess.Visible = False
appAccess.DoCmd.RunMacro "Report Process"

' Close the database and quit Access
appAccess.CloseCurrentDatabase
appAccess.Quit

' Close the object variable.
Set appAccess = Nothing
ProgramExit:
Exit Sub

ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub

[/vba]


Thanks Brian and also to JP2112 for getting me on the path!

Regards,
Greg

[telepicker]

Ok I may have jumped too soon. It appears I have a small issue.

I am getting
Run-time error '-2147352567 (80020009)':
Array index out of bounds.

When I Debug it highlights this line of code:
[vba]
Att = myAttachments.Item(1).DisplayName
[/vba]

Any thoughts on what I messed up here?

[telepicker]

BTW - this prompted when I receive an email from a Sender that is not part of my If.. ElseIf code.

I am guessing the code would like to see something that says if it isn't one these Senders then take no action.

[BrianMH]

Sorry been away for a bit. Just add and else (not elseif) to the end of the if statement and either say exit sub or goto programexit

That should sort it for you.

[telepicker]

Brian - That resolved it.
I have definetly learned many things over the past few weeks.
I sincerely appreciate your help.

Regards,

Greg

[telepicker]

Ok - so no it didn't resolve it. It worked fine on the 1st email that meet the criteria I received this am. Then when I received another email that did not meet my criteria I received the error in a message box.

See post #50 for full code - with the exception of adding the Else to the end of the statemnt.

Same error message:
Run-time error '-2147352567 (80020009)':
Array index out of bounds


Debugging shows this line as issue:
[vba]

Att = myAttachments.Item(1).DisplayName

[/vba]

I added the Else as you suggested. Below is the last ElseIF statement of the code.


[vba]
ElseIf (Msg.Sender = "Mail Subscriptions") And _
(Msg.Subject = "Test Mail 3") And _
(Msg.Attachments.Count >= 1) Then
attPath = "C:\Documents and Settings\myfolder name\My Documents\Test File\"
myAttachments.Item(1).SaveAsFile attPath & Att
Msg.UnRead = False
'Msg.Move olDestFldr

Else

Exit Sub

End If
End If
ProgramExit:
Exit Sub

ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub

[/vba]

[telepicker]

BTW - If I hoover over the highlighted line it shows

Att = ""

Whatever, if anything, that may be trying to tell me.

[BrianMH]

Your trying to download the file before you have confirmed it meets the criteria. I bet that email that gave an error had no attachment.

[vba]If TypeName(Item) = "MailItem" Then
Set Msg = Item
Set myAttachments = Item.Attachments
Att = myAttachments.Item(1).DisplayName
myAttachments.Item(1).SaveAsFile attPath & Att
If (Msg.Sender = "Sender, Joe") And _ [/vba]
get rid of myAttachments.Item(1).SaveAsFile attPath & Att

[telepicker]

I have removed that line - will follow up after testing.

Thanks!

[telepicker]

Nope - still getting the error msg window.
It was an email with no attachment that caused it.
Same line being highlighted:

[vba]
If TypeName(Item) = "MailItem" Then
Set Msg = Item
' save attachment
Set myAttachments = Item.Attachments
Att = myAttachments.Item(1).DisplayName


[/vba]

[BrianMH]

[vba]Private WithEvents Items As Outlook.Items
Option Explicit

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).Items
End Sub
Private Sub Items_ItemAdd(ByVal Item As Object)

Dim Msg As Outlook.MailItem
Dim attPath As String
Dim Att As String
Dim strFullPath As String
Dim myAttachments As Attachments
Dim myAtt As Attachment
Dim olDestFldr As Outlook.MAPIFolder


On Error Goto ErrorHandler
'Only act if it's a MailItem

If TypeName(Item) = "MailItem" and Item.Attachments.Count > 0 then
Set Msg = Item
Set myAttachments = Item.Attachments

If (Msg.Sender = "Sender, Joe") And _
(Msg.Subject = "My Report") Then
attPath = "G:\Daily Report\Reports\"
myAttachments.Item(1).SaveAsFile attPath & Att
Call Report_Unzip
Msg.UnRead = False
'Msg.Move olDestFldr

ElseIf (Msg.Sender = "Jane Sender") And _
(Msg.Subject = "Test Mail 2") Then
attPath = "I:\Mail\"
myAttachments.Item(1).SaveAsFile attPath & Att
Msg.UnRead = False
'Msg.Move olDestFldr

ElseIf (Msg.Sender = "Mail Subscriptions") And _
(Msg.Subject = "Test Mail 3") Then
attPath = "C:\Documents and Settings\myfolder name\My Documents\Test File\"
myAttachments.Item(1).SaveAsFile attPath & Att
Msg.UnRead = False
'Msg.Move olDestFldr


End If
End If
ProgramExit:
Exit Sub

ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub

Sub TA_Unzip()
On Error Goto ErrorHandler
Dim appAccess As Object ' Access.Application
Dim objZip
Set objZip = CreateObject("XStandard.Zip")
objZip.UnPack "G:\Daily Report\Reports\Daily_Report.zip", "G:\Daily Report\Reports\"
Set objZip = Nothing
' Get a reference to the Access Application object.
Set appAccess = CreateObject("Access.Application")

' open TA database and build reports with timer pause to allow time to run
Dim tim As Long
appAccess.OpenCurrentDatabase ("G:\Daily Report\Reports\Report_db.accdb")
tim = Timer
Do While Timer < tim + 2
DoEvents
Loop

' hide the application.
appAccess.Visible = False
appAccess.DoCmd.RunMacro "Report Process"

' Close the database and quit Access
appAccess.CloseCurrentDatabase
appAccess.Quit

' Close the object variable.
Set appAccess = Nothing
ProgramExit:
Exit Sub

ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
[/vba]
Try that, it was trying to assign the attachment name to att where there was no attachment to save.