Getting Attachments from Outlook with Excel VBA

[JrTraylor3]

I have been trying to work with Outlook and Excel VBA the last couple weeks. I have the 3 versions of code below that allow me to find a specific attachment (cell value) and place it into a shared folder on a server. I would like to first search outlook for a specific subfolder then find the attachment, if it does not exist I want to search the inbox and all subfolders for the attachment. The reason I am trying to do it this way is strictly for how fast the code executes. Some people using this procedure will have a rule for moving emails to a specific folder some people will not. The code runs much faster when it has less emails to look through to find the attachment so looking for the specific folder first will make the people who do this most often happier.

'-----Looks through the inbox-----

Sub GetAttachmentFromInbox()
 Dim ns As Namespace
 Dim Inbox As MAPIFolder
 Dim Item As Object
 Dim Atmt As Attachment
 Dim FileName As String
 
 Set ns = GetNamespace("MAPI")
 Set Inbox = ns.GetDefaultFolder(olFolderInbox)
 
  For Each Item In Inbox.Items
    For Each Atmt In Item.Attachments
        If Atmt.FileName = Range("CORPONo").Value Then
            FileName = Range("COFolder").Value & "\" & Atmt.FileName
            MsgBox FileName
            Atmt.SaveAsFile FileName
            Exit Sub
        End If
    Next Atmt
 Next Item
 
End Sub

'-----Looks Through all Subfolders-----

Sub GetAttachmentfromAllFolders2()
    Dim olApp As Outlook.Application
    Dim olNs As Outlook.Namespace
    Dim olFolder As Outlook.MAPIFolder
    Dim eFolder As Outlook.Folder
    Dim Item As Object
    Dim Atmt As Outlook.Attachment
    Dim FileName As String
    
    Set olApp = New Outlook.Application
    Set olNs = olApp.GetNamespace("MAPI")
    For Each eFolder In olNs.GetDefaultFolder(olFolderInbox).Folders
        Set olFolder = olNs.GetDefaultFolder(olFolderInbox).Folders(eFolder.Name)
           For Each Item In eFolder.Items
                For Each Atmt In Item.Attachments
                    If Atmt.FileName = Range("CORPONo").Value Then
                        FileName = Range("COFolder").Value & "\" & Atmt.FileName
                        MsgBox FileName
                        Atmt.SaveAsFile FileName
                        Exit Sub
                    End If
                 Next Atmt
           Next Item
         Set olFolder = Nothing
    Next eFolder
End Sub

'-----Look through a specific folder-----

Sub GetAttachemntsTest()
 Dim ns As Namespace
 Dim Inbox As Outlook.MAPIFolder
 Dim Item As Object
 Dim Atmt As Outlook.Attachment
 Dim FileName As String
 
 Set ns = GetNamespace("MAPI")
 Set Inbox = ns.GetDefaultFolder(olFolderInbox).Folders("LOCUS ENERGY")
 
  For Each Item In Inbox.Items
    For Each Atmt In Item.Attachments
        If Atmt.FileName = Range("CORPONo").Value Then
            FileName = Range("COFolder").Value & "\" & Atmt.FileName
            MsgBox FileName
            Atmt.SaveAsFile FileName
            Exit Sub
        End If
    Next Atmt
 Next Item
 
End Sub