Saving .XLSX Attachments from Outlook 2010 w/ VBA

Question

We use Outlook 2010 and receive emails with Excel attachments. We manually save the attachment in a sub-folder that we create within a divisional folder on a network drive.

What I'm curious about is if it's possible to

1. Use code to check incoming emails to see if they have an attachment,
2. Then check the attachment to see if it's an .XLSX,
3. If so, open the attachment, check the value of a particular cell,
4. then store the account name and account number as a string and a variable
5. then use those to create the sub-folders in the appropriate Windows directory.

** I forgot to post what I had done so far. I believe Brett answered my ??, but maybe someone else would be able to use snippets of it.

Private Sub cmdConnectToOutlook_Click()
Dim appOutlook As Outlook.Application
Dim ns As Outlook.Namespace
Dim inbox As Outlook.MAPIFolder
Dim item As Object
Dim atmt As Outlook.Attachment
Dim filename As String
Dim i As Integer

Set appOutlook = GetObject(, "Outlook.Application")
Set ns = appOutlook.GetNamespace("MAPI")
Set inbox = ns.GetDefaultFolder(olFolderInbox)
i = 0 

If inbox.Items.Count = 0 Then
    MsgBox "There are no messages in the Inbox.", vbInformation, _
           "Nothing Found"
    Exit Sub
End If

For Each item In inbox.Items
  For Each atmt In item.Attachments

    If Right(atmt.filename, 4) = "xlsx" Then
        filename = "\\temp\" & atmt.filename
        atmt.SaveAsFile filename
       i = i + 1
    End If

  Next atmt
Next item

MsgBox "Attachments have been saved.", vbInformation, "Finished"

Set atmt = Nothing
Set item = Nothing
Set ns = Nothing

End Sub

Answer 1

Having said it is lengthy here is one way to do it. My code from VBA Code to save an attachment (excel file) from an Outlook email that was inside another email as an attachment may also be of interest

You will need to update your file path, and the cell range from the file that you are opening

In my testing I sent a message to myself with a pdf file and an excel workbook with "bob" in the A1 in the first sheet

The code below found the excel file, saved it, opened it, create a directory c:\temp\bob then killed the saved file

Private Sub Application_NewMailEx _
    (ByVal EntryIDCollection As String)

'Uses the new mail techniquer from http://www.outlookcode.com/article.aspx?id=62

Dim arr() As String
Dim lngCnt As Long
Dim olAtt As Attachment
Dim strFolder As String
Dim strFileName As String
Dim strNewFolder
Dim olns As Outlook.NameSpace
Dim olItem As MailItem
Dim objExcel As Object
Dim objWB As Object

'Open Excel in the background
Set objExcel = CreateObject("excel.application")

'Set working folder
strFolder = "c:\temp"

On Error Resume Next
Set olns = Application.Session
arr = Split(EntryIDCollection, ",")
On Error GoTo 0

For lngCnt = 0 To UBound(arr)
    Set olItem = olns.GetItemFromID(arr(lngCnt))
    'Check new item is a mail message
    If olItem.Class = olMail Then
        'Force code to count attachments
        DoEvents
        For Each olAtt In olItem.Attachments
            'Check attachments have at least 5 characters before matching a ".xlsx" string
            If Len(olAtt.FileName) >= 5 Then
                If Right$(olAtt.FileName, 5) = ".xlsx" Then
                    strFileName = strFolder & "\" & olAtt.FileName
                    'Save xl attachemnt to working folder
                    olAtt.SaveAsFile strFileName
                    On Error Resume Next
                    'Open excel workbook and make a sub directory in the working folder with the value from A1 of the first sheet
                    Set objWB = objExcel.Workbooks.Open(strFileName)
                    MkDir strFolder & "\" & objWB.sheets(1).Range("A1")
                    'Close the xl file
                    objWB.Close False
                    'Delete the saved attachment
                    Kill strFileName
                    On Error Goto 0
                End If
            End If
        Next
    End If
Next
'tidy up
Set olns = Nothing
Set olItem = Nothing
objExcel.Quit
Set objExcel = Nothing
End Sub