Resolution - Save Attachment from email programmatically from specific senders.
:clap: 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.
:cloud9: 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