VBA Outlook - Run automatically for all email in inbox? - vba

Question

I have the following code which I am using to save an email attachment into a folder. I want to make this vba run automatically each time I open outlook and check all emails in my creditchecks#hewden.co.uk inbox (non default inbox).
At the moment though it only checks the email which is selected in the active inbox. can someone please show me how I can edit my code to get it to do what I need. thanks
Public Sub SaveAttachments()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderPath As String
Dim strDeletedFiles As String
Dim withParts As String
Dim withoutParts As String
' Get the path to your My Documents folder
On Error Resume Next
' Instantiate an Outlook Application object.
Set objOL = CreateObject("Outlook.Application")
' Get the collection of selected objects.
Set objSelection = objOL.ActiveExplorer.Selection
' The attachment folder needs to exist
' You can change this to another folder name of your choice
' Set the Attachment folder.
strFolderPath = "\\UKSH000-FILE06\Purchasing\New_Supplier_Set_Ups_&_Audits\ATTACHMENTS\"
' Check each selected item for attachments.
For Each objMsg In objSelection
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count
If lngCount > 0 Then
' Use a count down loop for removing items
' from a collection. Otherwise, the loop counter gets
' confused and only every other item is removed.
For i = lngCount To 1 Step -1
' Get the file name.
strFile = objAttachments.item(i).FileName
If Right(strFile, 3) = "pdf" Then
' Combine with the path to the Temp folder.
withParts = strFile
withoutParts = Replace(withParts, ".pdf", "")
strFile = strFolderPath & withoutParts & "\" & strFile
' Save the attachment as a file.
objAttachments.item(i).SaveAsFile strFile
End If
Next i
End If
Next
ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub

Answer 1

Just need to edit some lines. Use something like objOL.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Parent.Folders("credutchecks#hewden.co.uk") to a folder in the same level of your Inbox folder. Here is your code modified:
Public Sub SaveAttachments()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderPath As String
Dim strDeletedFiles As String
Dim withParts As String
Dim withoutParts As String
' Get the path to your My Documents folder
On Error Resume Next
' Instantiate an Outlook Application object.
Set objOL = CreateObject("Outlook.Application")
' Get the collection of selected objects.
'Set objSelection = objOL.ActiveExplorer.Selection
'Istead set this to the selected objects you just need to set to your email folder
'This is for a inbox same level folder
Set objSelection = objOL.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Parent.Folders("credutchecks#hewden.co.uk")
'This is for a folder inside the inbox folder
'Set objSelection = objOL.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders("credutchecks#hewden.co.uk")
' The attachment folder needs to exist
' You can change this to another folder name of your choice
' Set the Attachment folder.
strFolderPath = "\\UKSH000-FILE06\Purchasing\New_Supplier_Set_Ups_&_Audits\ATTACHMENTS\"
' Check each selected item for attachments.
For Each objMsg In objSelection
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count
If lngCount > 0 Then
' Use a count down loop for removing items
' from a collection. Otherwise, the loop counter gets
' confused and only every other item is removed.
For i = lngCount To 1 Step -1
' Get the file name.
strFile = objAttachments.item(i).FileName
If Right(strFile, 3) = "pdf" Then
' Combine with the path to the Temp folder.
withParts = strFile
withoutParts = Replace(withParts, ".pdf", "")
strFile = strFolderPath & withoutParts & "\" & strFile
' Save the attachment as a file.
objAttachments.item(i).SaveAsFile strFile
End If
Next i
End If
Next
ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub
To run it automatically when the Outlook starts just put it on the 'ThisOutlookSession' in the objects folder and name it 'Sub Application_Startup()'. Don't forget to enable macros before.