Salvar anexo de email com nome da assinatura.

[FMattos]

Srs, bom dia!

 

Estou tentando encontrar uma macro para salvar anexos de emails recebidos em pastas separadas.

Consegui um no forum MSDN que cria a pasta com o email de quem envia a mensagem e salva os anexos dentro.

Como trabalhamos com diversas pessoas enviando email e apenas uma conta para receber, a ideia é que todo email seja salvo em uma pasta para que todos tenham acesso.

A maioria dos emails que recebemos são respostas, então quero que a macro pegue a assinatura do email original e crie uma pasta com este nome e salve os anexos dentro.

Seria possível?

 

Exemplo: enviei email para [email protected], na minha assinatura vai meu nome, então quando o financeiro me responder, quero que a macro crie uma pasta com meu nome e salve a mensagem dentro desta pasta.

 

abaixo a macro que peguei na MSDN (Reduzi a macro por não ter necessidade de filtrar mais formatos).

Acho que alterando a parte verde da macro funciona, mas não faço ideia do que usar.

 

Public Sub ProcessarAnexo(Email As MailItem)

 Dim DirAnexo1 As String

  Dim strRem As String

 Dim MailID As String

 Dim Lido As Boolean

 Dim Mail As Outlook.MailItem

 

 DirAnexo1 = "C:\MSG"

MailID = Email.EntryID

 Set Mail = Application.Session.GetItemFromID(MailID)

 

 strRem = Mail.SenderEmailAddress

 

 For Each Anexo In Mail.Attachments

  If Right(Anexo.FileName, 3) = "msg" Then

   If Dir(DirAnexo1 & "\" & strRem, vbDirectory) = "" Then

    MkDir DirAnexo1 & "\" & strRem

    Anexo.SaveAsFile DirAnexo1 & "\" & strRem & "\" & Format(Mail.CreationTime, "yyyymmdd-hhnnss-") & Anexo.FileName

   Else

    Anexo.SaveAsFile DirAnexo1 & "\" & strRem & "\" & Format(Mail.CreationTime, "yyyymmdd-hhnnss-") & Anexo.FileName

   End If

 

  End If

 Mail.UnRead = False

 Next

 Set Mail = Nothing

End Sub