VBA attachments auto save help

[cxm687]

Hi all,

I am fairly new to VBA, and in a nutshell when 2 specific email addresses send me an email I need
1. to process a certain excel document and associated macros (which I have successfully done)
2. have all attachments on the email saved as excel documents.

for the second instance I currently do this is another sub by selecting the email to save (which works), however I want to move it to the outlook session and for it to auto save on arrival.

Could anyone please adjust my current code for me and explain it? I know it’s to do with the “selection” section… but by removing it can’t identify the sender section.

Many thanks in advance

Option Explicit
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")
' default local Inbox
Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
'Set Items = Items.Folders("Biz Ops Report")
End Sub
Private Sub Items_ItemAdd(ByVal item As Object)

On Error GoTo ErrorHandler
Dim Msg As Outlook.MailItem
Dim xlApp As Object
Dim oxl As Excel.Application
Dim owb As Excel.Workbook
Dim wsheet As Excel.Worksheet
Dim asd As Object
Dim ExApp As Excel.Application
Dim ExWbk As Workbook
Dim myDestFolder As Outlook.Folder
Dim Attachment As Outlook.Attachment
Dim Attachments As Outlook.Attachments '
Dim AttachmentsCount As Integer '
Dim Email As Object '
Dim FolderObj As Object '
Dim FolderPath As String '
Dim i As Long '
Dim OutlookApp As Outlook.Application '
Dim User As String '
Dim Selection As Outlook.Selection

If TypeName(item) = "MailItem" Then


Set Msg = item


If Msg.Sender = "name of email I want" Then

User = (Environ$("my names"))
FolderPath = "\\jdw39n\users$\myname\folder desired"

Set FolderObj = CreateObject("Scripting.FileSystemObject")
If FolderObj.FolderExists(FolderPath) Then 'The Folder has been found
Else: FolderObj.CreateFolder (FolderPath) 'The Folder has been created
End If

Set OutlookApp = Outlook.Application
Set Selection = OutlookApp.ActiveExplorer.Selection

AttachmentsCount = 0

For Each Email In Selection
If Email.SenderEmailAddress = "name of email I want" Then
Set Attachments = Email.Attachments
For i = Attachments.Count To 1 Step -1
'If InStr(1, Attachments.Item(i).Filename, "File Type Extension") > 1 Then 'Check File Type before saving
Attachments.item(i).SaveAsFile FolderPath & "\" & Attachments.item(i).FileName 'Save attachment to the Folder Path using naming convention: Email's Received Time - Attachment's File Name
AttachmentsCount = AttachmentsCount + 1
'End If
Next i
End If
Next

If AttachmentsCount > 0 Then
MsgBox "Email Attachment saved"
ElseIf AttachmentsCount = 0 Then
MsgBox "No Email Attachment found"
End If

Set Attachments = Nothing
Set Email = Nothing
Set FolderObj = Nothing
Set OutlookApp = Nothing
Set Selection = Nothing

End If


End If

If TypeName(item) = "MailItem" Then


Set Msg = item


If Msg.Sender = "working name" Then

Set ExApp = New Excel.Application
Set ExWbk = ExApp.Workbooks.Open("\\working folderpath.xlsm")
ExApp.Visible = True


ExWbk.Application.Run "Module2.DataRefresh"
ExWbk.Application.Run "Module4.import data"

'Dim myNameSpace As Outlook.NameSpace
'Dim myInbox As Outlook.Folder


' Set myNameSpace = Application.GetNamespace("MAPI")
' Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
' Set myItems = myInbox.Items
' Set myDestFolder = myInbox.Folders("Test")


' **Msg.Move myDestFolder**
'Not working


End If


End If

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