'Referencias:
    'Microsoft Outlook 11 Object Library
    'Microsoft Office  11 Object Library
    'Microsoft DAO 3.6 Object Library


'Definicion de Varibles

Option Explicit
    Dim RsTbl As Recordset
    Dim xBody As String
    Dim xPer As String
    Dim xFile As String

Public Sub EmailDetach()
    Dim ObjOutlook, ObjMsg, myNameSpace, myMailItem, myAttach, myFolder As Object
    Dim ObjOL As Outlook.Application
    Dim ObjSelection As Outlook.Selection
    
    Dim i, j, k As Integer
    
    Dim myDiskFolder, myFileExt, myFileName As String
        
   'Aqui se define donde se bajaran los archivos
    myDiskFolder = "C:\MiCarpeta\"
    
   'Aqui se determina el tipo de extension del archivo a identificar y bajar
    xFile = ".xls"

    Set ObjOutlook = Application
    Set ObjOL = CreateObject("Outlook.Application")
    Set ObjSelection = ObjOL.ActiveExplorer.Selection
    Set myNameSpace = ObjOutlook.GetNamespace("MAPI")
    Set myFolder = ObjOutlook.ActiveExplorer.CurrentFolder  
   

    If myFolder = "MiCarpeta" Then
         For i = 1 To myFolder.Items.Count
         Set myMailItem = myFolder.Items.Item(i)
         If myMailItem.UnRead = True Then
            For k = 1 To myMailItem.Attachments.Count
            
           'Guarda cada archivo anexo 
            Set myAttach = myMailItem.Attachments
            
            myFileName = myAttach.Item(k).FileName
            
	    	
            If (InStr(myFileName, xFile) <> 0 Or InStr(myFileName, UCase(xFile)) <> 0) Then
               myAttach.Item(k).SaveAsFile myDiskFolder & myFileName
               myMailItem.UnRead = False
            End If
            
            Next k
         End If
         Next i
        
         For Each ObjMsg In ObjSelection
             If ObjMsg.Class = olMail Then
                For k = 1 To myMailItem.Attachments.Count
       
               'Guarda cada archivo anexo
                Set myAttach = myMailItem.Attachments
                myFileName = myAttach.Item(k).FileName
                
                If (InStr(myFileName, xFile) <> 0 Or InStr(myFileName, UCase(xFile)) <> 0) Then
                   myAttach.Item(k).SaveAsFile myDiskFolder & myFileName
                   myMailItem.UnRead = False
                End If
                
                Next k
                ObjMsg.Save
             End If
         Next
    End If