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

[Leith Ross]

Hello JrTraylor3,

Did you have a specific question or is this post to share your findings with others?

[JrTraylor3]

Sorry I guess I should have separated the question after stating what I have and it probably could have been asked better. This was what I was asking poorly.

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.

So, how can I search outlook for a specific subfolder, if the folder does not exist continue searching the inbox and all subfolders until it is found to find a specific attachment like in the 3 versions of code above?

[snb]

It depends of whether you want to run the code in Outlook or from another application (Word, Excel, Powerpoint. e.g.)

[JrTraylor3]

It is being run from Excel. The attachment name will be determined based on a value entered into a cell. The code I have listed references 2 named ranges that need to be part of my code.

A user is filling out a form in Excel, That form has a button that currently creates a folder directory on our server, saves the file based on values entered into named ranges in the folder, then sends an email to specific users with a hyperlink to the file. It also creates a hyperlink for a file that is manually transferred from an email into the created folder. I added 2 of the versions of code together (look in inbox and look in subfolders) so that I can find the attachment automatically and add it to the same code but it takes a little more time than what I would like. The people that will be using this process will most likely have a rule in place to put emails in a subfolder. So I came up with the code to search in a specific folder (that executes real fast as there is not as much email in that folder).

Then I realized if someone else is ever asked to run this process they wont be able to, so I tried to teach myself how to use the .Find method to find the subfolder and add it to an if statement so that if it is not found then search all other folders but could not get it to work.

The code that I need to add to is listed below.

Sub CreateFolderandSaveFile()
Dim wb As Workbook
Dim ws As Worksheet
Dim suffix, suffix1, fName, fName1, fName2, fpath,  As String, 
Set wb = ThisWorkbook
Set ws = ThisWorkbook.Sheets("Change Order Report")
Set ws2 = ThisWorkbook.Sheets("Hidden For VBA")
If Range("CORCODesc") = "" Then
    MsgBox "Please enter a general description for this Change Order"
    Range("CORCODesc").Select
    Exit Sub
Else
    'Do Nothing
End If
If Range("CORProjectNo") = "" Then
    MsgBox "Please enter a Project Number"
    Range("CORProjectNo").Select
    Exit Sub
Else
    'Do Nothing
End If
If Range("CORCONo") = "" Then
    MsgBox "Please enter a Change Order Number"
    Range("CORCONo").Select
    Exit Sub
Else
    'Do Nothing
End If
For Each Cell In Range("Directory")
    If Cell = "" Then
        'do nothing
    ElseIf Len(Dir(Cell, vbDirectory)) = 0 Then
        MkDir Cell
    End If
Next Cell
suffix = ".xlsm"
suffix1 = ".pdf"
fpath = Range("COFolder") & "\"
fName = Range("CORProjectNo") & " CO-" & Range("CORCONo") & " " & Range("CORCODesc") _
        & " Qty. " & Range("CORLine1Qty") & " COReportBA"
fName1 = fpath + fName + suffix
fName2 = fpath & Range("CORCustPONo") + suffix1
wb.SaveAs fName1, FileFormat:=xlOpenXMLWorkbookMacroEnabled
    Dim OutApp As Object
    Dim OutMail As Object
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
            strbody = "font size=""3"" face=""Calibri"">" & _
                  "Hello :br B" & _
                  fName & "/B COR has been created.<br>" & _
                  "Click " & _
                  "A HREF=""file://" & fName1 & _
                  """HereA" & _
                  " to open the live file." & _
                  "brClick " & _
                  "A HREF ""file://" & fName2 & _
                  """Her</A>" & _
                  " to open the PO." & _
                  "<br><br>A copy of the COR has also been attached." & _
                  "<br><br><br>Regards," & _
                  "<br><br>Sales</font>"
    On Error Resume Next
    With OutMail
        .To = ""
        .CC = ""
        .BCC = ""
        .Subject = "A New Change Order Report has been Entered for job " & Range("CORProjectNo")
        .HTMLBody = strbody
        .Attachments.Add fName1
        'You can add other files also like this
        '.Attachments.Add ("C:\test.txt")
        .Send
    End With
    On Error GoTo 0
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub