vitorhsh,

Bom dia!

Veja se esse arquivo pode te ajudar. Tente fazer as adaptações necessárias. O código não é meu e não sei quem é o autor. Peguei em algum lugar na intrnet.

Boa Tarde Famalia

Wanger Obrigado pela atenção dei uma olhada nesse arquivo
e nessa linha que gostaria de a macro, mais esse codigo e muito complexo para mim
onde eu editaria para procura o nome no email para baixa o arquivo
seria em uma dessas linha

 Set objNS = Application.GetNamespace("MAPI")
Set objInbox = objNS.GetDefaultFolder(olFolderInbox)
Set objAttFld = objInbox.Folders(strAttFldName)

nessa outra coloco o caminho onde quero que salve?

strAttFldName = "Quarentena"

Att, Vitor Hugo

vitorhsh,

Boa noite!

Infelizmente também não entendo de código VBA para Outlook. Tem que sair fazendo tentativas...

Boa Tarde Familia,

Wagner Obrigado pela Atenção
Infelizmente não usei seu codigo pois achei meio complexo
peguei um da internet e adaptei pra mim esta funcionando perfeitamente
basta cria um mudulo no VBA do Outlook, cola o cod muda os parâmetros comentados

Sub Mulheres(Item As MailItem) ' caso utiliza uma regra deixa o (Item As MailItem) caso nao retire



Dim OutlookOpened As Boolean
Dim outApp As Outlook.Application
Dim outNs As Outlook.NameSpace
Dim outFolder As Outlook.MAPIFolder
Dim outAttachment As Outlook.Attachment
Dim outItem As Object
Dim outMailItem As Outlook.MailItem
Dim inputDate As String, subjectFilter As String
Dim saveInFolder As String

SendKeys ("{ENTER}")
saveInFolder = "C:2017"  ' adiciona caminha do arquivo
If Right(saveInFolder, 1) <> "" Then saveInFolder = saveInFolder & ""

subjectFilter = "EXER RAP mulheres" ' Adiciona nome do assunto

SendKeys ("{ENTER}")

OutlookOpened = False
On Error Resume Next
Set outApp = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then
Set outApp = New Outlook.Application
OutlookOpened = True
End If
On Error GoTo 0

If outApp Is Nothing Then
MsgBox "Cannot start Outlook.", vbExclamation
Exit Sub
End If

Set outNs = outApp.GetNamespace("MAPI")
SendKeys ("{ENTER}")

'Set outFolder = outNs.Folders("Personal Folders").Folders("Inbox") 'CHANGE FOLDER AS NEEDED



Set outFolder = outNs.PickFolder 'OR USER SELECTS FOLDER




If Not outFolder Is Nothing Then
For Each outItem In outFolder.Items
If outItem.Class = Outlook.OlObjectClass.olMail Then
Set outMailItem = outItem
If outMailItem.Subject = subjectFilter Then
Debug.Print outMailItem.Subject
For Each outAttachment In outMailItem.Attachments
outAttachment.SaveAsFile saveInFolder & outAttachment.FileName
Next
End If
End If
Next
End If

If OutlookOpened Then outApp.Quit

Set outApp = Nothing

End Sub

Att, Vitor Hugo