Consulting

Results 1 to 5 of 5

Thread: Getting Attachments from Outlook with Excel VBA

  1. #1

    Getting Attachments from Outlook with Excel VBA

    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

  2. #2
    VBAX Expert Leith Ross's Avatar
    Joined
    Oct 2012
    Location
    San Francisco, California
    Posts
    544
    Location
    Hello JrTraylor3,

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

    "1N73LL1G3NC3 15 7H3 4B1L17Y 70 4D4P7 70 CH4NG3 - 573PH3N H4WK1NG"

  3. #3
    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?

  4. #4
    Knowledge Base Approver VBAX Guru
    Joined
    Apr 2012
    Posts
    4,744
    It depends of whether you want to run the code in Outlook or from another application (Word, Excel, Powerpoint. e.g.)

  5. #5
    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

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •