Código VBA para Salvar Anexos de Novas Mensagens do Outlook numa Pasta do computador

Question

Boa tarde Pessoal,

Recebo diariamente cerca de 30 e-mail´s com assuntos diferentes. Preciso salvar cada anexo em uma pasta determinada.

Peguei esse código de VBA nesse site, salva os anexos de acordo com o assunto escolhido. Infelizmente o assunto muda diariamente e como é um e-mail genérico para envio, gostaria de pegar o e-mail de quem esta enviando em vez do assunto.

Infelizmente não sou especialista em VBA então não consegui troca os código.

será que alguém pode me ajudar. Apenas gostaria de mudar a verificação de Assunto para Email DE: (Ex. [e-mail])

A macro, verificar o assunto e salva o anexo em uma planilha já definida.

Sub Baixar_Anexo()
On Error GoTo GetAttachments_err
' Declaração de variáveis
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 na sua caixa de entrada se existe algum anexo de acordo com o assunto especificado
If Inbox.Items.Count = 0 Then
MsgBox "Ainda não existem mensagens na Caixa de Entrada.", vbInformation, _
"Nada Encontrado."
Exit Sub
End If

' Verifique cada mensagem para anexos
For Each Item In Inbox.Items

'Este nome entre aspas duplas é o assunto do email que contém o anexo, MUDE DE ACORDO COM SEU EMAIL
If Item = "ALR_NA_TP_SAOPAULO_IAN_SERVICE_AAS 2015-04-28 Report" Then

' Salve o anexo se encontrado
For Each Atmt In Item.Attachments

' Em nome do arquivo você irá inserir o caminho de onde quer salvar seu anexo, MUDE DE ACORDO COM SEU AMBIENTE.
FileName = "\\C:\Users\natanael.valentim\Documents\Scanned Documents\Documents\" & Atmt.FileName
Atmt.SaveAsFile FileName
i = i + 1
Next Atmt
End If
Next Item

' Notificar se a Macro bem sucedida ou não.
If i > 0 Then
MsgBox "Foi encontrado " & i & " Arquivos com anexo." _
& vbCrLf & "Foram salvos RELATORIOS MIS\BD\REPORT_EMAIL." _
& vbCrLf & vbCrLf & "Tenha um bom dia.", vbInformation, "Acabou!"
Else
MsgBox "Não foi encontrado nenhum arquivo anexo em seu email.", vbInformation, "Acabou!"
End If

' Limpar Memoria
GetAttachments_exit:
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
Exit Sub

' Handle errors
GetAttachments_err:
'MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: GetAttachments" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume GetAttachments_exit
End Sub