VBA To Save Outlook Attachments 1

[vzdog]

Hello everyone. I have a VBA script cobbled together that will successfully capture an email attachment from a specific sender with a specific subject. My problem is that it will only capture 1 instance.

I would like to be able to add additional Senders and Subjects to capture - and be able to specifiy the path to save the attachment in to (likely a different drive and folder).

I am not a VBA user at all, so I would appreciate any assistence offered.


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).Items
End Sub

Private Sub Items_ItemAdd(ByVal Item As Object)

On Error GoTo ErrorHandler

'Only act if it's a MailItem
Dim Msg As Outlook.MailItem
If TypeName(Item) = "MailItem" Then
Set Msg = Item

'Change variables to match need. Comment or delete any part unnecessary.
If (Msg.SenderName = "Last, First") And _
(Msg.Subject = "My_Special_File") And _
(Msg.Attachments.Count >= 1) Then

'Set folder to save in.
Dim olDestFldr As Outlook.MAPIFolder
Dim myAttachments As Outlook.Attachments
Dim Att As String

'location to save in. Can be root drive or mapped network drive.
Const attPath As String = "I:\Test\Folder\"


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

' mark as read
Msg.UnRead = False
End If
End If


ProgramExit:
Exit Sub

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

 

[yooneek]

Try this:

Private Sub Items_ItemAdd(ByVal Item As Object)

On Error GoTo ErrorHandler

'Only act if it's a MailItem
Dim msg As Outlook.MailItem
Dim i As Long
Dim olDestFldr As Outlook.MAPIFolder
Dim myAttachments As Outlook.Attachments
Dim Att As String
Dim attPath As String

'If TypeName(Item) = "MailItem" Then
' Set msg = Item

Set msg = ActiveExplorer.Selection.Item(1)

Select Case msg.SenderName
Case "Last, First", "Last2, First2", "Last3, First3"
Select Case InStr(1, msg.Subject, "My_Special_File")
Case Is > 0
Select Case msg.Attachments.Count
Case Is >= 1
'location to save in. Can be root drive or mapped network drive.
attPath = "I:\Test\Folder\"

' save attachment
Set myAttachments = msg.Attachments

' loop through all attachments and save
For i = 1 To myAttachments.Count
Att = myAttachments.Item(i).DisplayName
myAttachments.Item(i).SaveAsFile attPath & Att
Next i

' mark as read
msg.UnRead = False

Exit Sub
End Select
End Select
End Select

Exit Sub

ErrorHandler:
MsgBox Err.Number & " - " & Err.Description

End Sub



This way you can add more names to the list.

 

[vzdog]

yooneek - Thanks for the reply. I have been trying to read more about using case versus a If then Else - and thought that may be the way to go. As I said in the post I do not use VBA but see where I need to learn.

Is there a way to use case where I would be able to set a certain sender and subject line to go to a particular folder and then have other cases that would do the same for other senders and subjects but be saved in a different file or folder?

 

[vzdog]

Actaully just had a chance to try this and it does not actually save the attachments. Perhaps something is missing. I tried usinga test set up of 2 different senders and both instances failed to save the attached file.

 

[yooneek]

Sorry for the late reply.. were you able to get this working?

 

[vzdog]

No not yet. I have a code that will do everything I want it to do begining with saving an attachment from a particular sender with a particular subject line.

However, I have yet to accomplish saving different attachments from different senders.

Typically the attacment would be .xls file.

 

[jedraw]

Try doing the For Loop in reverse. I had this issue previously.

This sort of thing (air code)
For i = Attachments.Count to 0 step -1

' your work here
Next i

 

[jedraw]

Note in my previous post, the reverse order routine was to DELETE attachments after they were moved to a special folder I had for email attachments.

It was not (repeat NOT) for saving an email.

Sorry for any confusion.

 

[PHV]

What is your actual code not working ?

Hope This Helps, PH.
FAQ219-2884
FAQ181-2886

 

[vzdog]

My code is working - as written in the original post. My code that basically looks for an email from a specific sender with a specific subject line. Once that email is received then my code saves the attachment to the designated folder and the kicks off some macros in Access.

My problem/question is this.. How can I modify this code so that I can run the process on different different senders sending different attachments. This would all be excel attachments.

I would like to be able to specify a save to folder for each individual sender, but if I can not I could create a single Inbound Attachments folder.

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).Items
End Sub

Private Sub Items_ItemAdd(ByVal Item As Object)


On Error GoTo ErrorHandler

'Only act if it's a MailItem
Dim Msg As Outlook.MailItem
If TypeName(Item) = "MailItem" Then
Set Msg = Item

Begining here, is where I need to be to distinguish between different Senders and Subjects:


'Change variables to match need. Comment or delete any part unnecessary.
If (Msg.SenderName = "Last, First") And _
(Msg.Subject = "Daily Report") And _
(Msg.Attachments.Count >= 1) Then

' open wkbk and run import macro
Dim olDestFldr As Outlook.MAPIFolder
Dim myAttachments As Outlook.Attachments
Dim XLApp As Object ' Excel.Application
Dim XlWK As Object ' Excel.Workbook
Dim Att As String

'location to save in. Can be root drive or mapped network drive.
Const attPath As String = "G:\Report\TA\"

' 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,
' just in case it doesn't open on its own
On Error Resume Next
XLApp.Workbooks.Open _
("C:\Documents and Settings\Application Data\Microsoft\Excel\XLSTART\PERSONAL.XLSB")
On Error GoTo 0

' open workbook and run macro
XLApp.Workbooks.Open ("C:\Documents and Settings\Application Data\Microsoft\Excel\XLSTART\PERSONAL.XLSB")

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:\Report\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

As the code is now it works perfectly - other than my ability to collect from multiple senders.

Thanks for looking.

 

[PHV]

Sorry, but I don't see the issue: you seems to already know how to test Msg.SenderName and Msg.Subject.

Hope This Helps, PH.
FAQ219-2884
FAQ181-2886

 

[vzdog]

Trying to do it for different instances.. Issuse is I do not know how.

 

[PHV]

You do not know to do WHAT ?

Hope This Helps, PH.
FAQ219-2884
FAQ181-2886

 

[yooneek]

The problem, as I read it, is that you are asking to capture a variable subject line with a variable attachment name.

You can use the Select Case .SenderName statements I wrote for adding multiple people into the Case, and add it to encompass the code you have for opeing excel/access. But ultimately if you don't have any other checks to make sure that the file you are trying to import will actually merge to access then this process will continue to fail.

--Easier solution for you
My suggestion is to mandate something you can key off of in the Subject and also specify that the excel file name contains specific characters. ie Subj must contain: "...Updated File...", and xls file name must contain:"For DB XX"

--Takes a little more work (and processing time)
If the subject line and file name cannot be specified, then is there anything in the xls file that you can permorm tests on after you open it? (ensure that it is a file to import to access)