Excel Abrir anexo do Outlook VBA

[Zamboni_du]

Boa noite pessoal,

 

Preciso abrir uma planilha anexa que recebo diariamente em meu e-mail, copiar as informações e colar em outra planilha. O que eu preciso é um código para abrir esse arquivo anexo no Outlook. O arquivo tem o mesmo nome porém com a data do dia do envio no final (teste - 29/12/2021).

[Muca Costa]

Veja o anexo e faça as adaptações necessárias às suas necessidades...

BaixarAnexosMsg.rar

[Zamboni_du]

@Muca Costa boa noite,

Tentei adapta a minha necessidade mas não consegui, será que pode me ajudar?

Esse código baixa todos os email, porém eu preciso que baixe o anexo de apenas um email específico 

[Muca Costa]

Tente assim:

 

Dim olitem As Object
Dim lrow As Integer
Dim olattach As Object
Dim str As String

Const num As Integer = 6
Const path As String = "D:\Documents\Excel\Email\Outlook\AnexosMsg\Anexos\" 'Salva os anexos (CRIE ESSA PASTA)
Const emailpath As String = "D:\Documents\Excel\Email\Outlook\AnexosMsg\Msg\" 'Salva os Email's (CRIE ESSA PASTA)
Const olFolderInbox As Integer = 6

Set olp = CreateObject("Outlook.application")
Set olmapi = olp.getnamespace("MAPI")
Set olmail = olmapi.getdefaultfolder(num)

If olmail.items.restrict("[UNREAD]=True").Count = 0 Then

    MsgBox ("Nenhum e-mail não lido")

    Else

        For Each olitem In olmail.items.restrict("[UNREAD]=True")
            lrow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row + 1

            Range("A" & lrow).Value = olitem.Subject
            Range("B" & lrow).Value = olitem.senderemailaddress
            Range("C" & lrow).Value = olitem.to
            Range("D" & lrow).Value = olitem.cc
            Range("E" & lrow).Value = olitem.body

            If olitem.attachments.Count <> 0 Then
                For Each olattach In olitem.attachments
                If Left(olattach.Filename, 5) = "teste" Then 'Busca o nome comum dos anexos, neste exemplo a palávra teste tem 5 caracteres
                olattach.SaveAsFile path & olattach.Filename & " - " & Format(Date, "MM-dd-yyyy")
            End If
            Next olattach

            End If
    str = olitem.Subject
    str = Replace(str, "/", "-")
    str = Replace(str, "|", "_")
    Debug.Print str
            olitem.SaveAs (emailpath & str & ".msg")
            olitem.unread = False
            DoEvents
            olitem.Save
        Next olitem

End If

ActiveSheet.Rows.WrapText = False

MsgBox "Fim"

End Sub