Não sei se ajuda, mas este código salva todos os anexos dos emails recebidos(inbox), numa pasta em C:\AnexosRecebidos
Tem de habilitar a referencia VBA:
Microsoft Outlook xx.0 Object Library
Option Explicit
Sub SalvaAnexosDosEmails()
On Error GoTo SalvaAnexosDosEmails_err
Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim i As Integer
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
i = 0
' Verifica a caixa de entrada de mensagens
If Inbox.Items.Count = 0 Then
MsgBox "Não existem mensagens na sua Caixa de Entrada", vbInformation, "Erro"
Exit Sub
End If
' Verifica se os emails têm anexos
For Each Item In Inbox.Items
' Salva os anexos encontrados
For Each Atmt In Item.Attachments
FileName = "C:\AnexosRecebidos" & Atmt.FileName
Atmt.SaveAsFile FileName
i = i + 1
Next Atmt
Next Item
If i > 0 Then
MsgBox "Encontrados " & i & " anexos." _
& vbCrLf & "Salvos na pasta C:\AnexosRecebidos" _
& vbCrLf & vbCrLf & "Sucesso.", vbInformation, "Fim!"
Else
MsgBox "Não foram encontrados anexos nos emails recebidos", vbInformation, "Fim!"
End If
SalvaAnexosDosEmails_exit:
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
Exit Sub
SalvaAnexosDosEmails_err:
MsgBox "Ocorreu um erro inesperado." _
& vbCrLf & "Erro numero: " & Err.Number _
& vbCrLf & "Erro Descrição: " & Err.Description _
, vbCritical, "Erro!"
Resume SalvaAnexosDosEmails_exit
End Sub