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

  • Pergunta

  • 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. Ana.maria@google.com.br)

    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

    quinta-feira, 30 de abril de 2015 17:20

Respostas

  • Olá N_Valentim,

    Segue o Trecho de código de que precisa para pegar o email

    Espero ter ajudado

    Dim olFolder As Outlook.MailItem
    
    For Each olFolder In Inbox.Items
    If olFolder.SenderEmailAddress = "ColocarOemailDesejadoAqui@depoisSalvardaMesmaformadoAnexo" Then
    MsgBox "Achou"
    End If
    
    Next olFolder

    • Marcado como Resposta N_Valentim quinta-feira, 30 de abril de 2015 20:21
    quinta-feira, 30 de abril de 2015 18:41