Leitura arquivos msg (e-mail do outlook) armazenados em um diretório do computador

[Victor J Ferreira]

Boa noite, pessoal!

Estou em um impasse no meu código que passei o dia inteiro pesquisando e não consegui chegar em nenhuma luz. Possuo uma pasta dentro dos meus documentos hd, com uns 1000 e-mails do mesmo assunto e precisaria de uma maneira de filtrar palavras-chaves dentro do corpo do e-mail. No entanto, não estou conseguindo encontrar uma maneira de fazer o excel ler os arquivos de e-mails do Outlook dentro dessa pasta física (.msg).

Tentei replicar o código presente nesse guia: Como Ler E-mails do Outlook e Colocar na Planilha com VBA (hashtagtreinamentos.com)

No entanto, na variavel "minha_pasta" criei o objeto como file system object e acabou não dando certo.

Desde já agradeço

[Basole]

Veja se ajuda:

 

Sub ObterMsgOutlook()
Dim OutlookApp As Outlook.Application
Dim OutlookNamespace As Namespace
Dim Folder As MAPIFolder
Dim OutlookMail As Variant
Dim i As Integer
Dim cbl As Boolean

Const PalavraChave = "Microsoft" ' * Coloque aqui o termo a pesquisar
Const ApartirdaData = #1/21/2021# ' * Formato MM/DD/AAAA

Set OutlookApp = New Outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
Set Folder = OutlookNamespace.GetDefaultFolder(olFolderInbox) 'caixa de entrada
i = 1
For Each OutlookMail In Folder.Items
    If InStr(1, OutlookMail.Body, PalavraChave, vbTextCompare) > 0 And _
       OutlookMail.ReceivedTime >= ApartirdaData Then
      If Not cbl Then
        Range("A1") = VBA.UCase("Assunto")
        Range("B1") = VBA.UCase("Data Recebimento")
        Range("C1") = VBA.UCase("Enviado por:")
        Range("D1") = VBA.UCase("Corpo E-mail")
        cbl = True
      End If
        Range("A1").Offset(i, 0).Value = OutlookMail.Subject
        Range("B1").Offset(i, 0).Value = OutlookMail.ReceivedTime
        Range("C1").Offset(i, 0).Value = OutlookMail.SenderName
        Range("D1").Offset(i, 0).Value = OutlookMail.Body
        RemoveHTMLTags Range("D1").Offset(i, 0)
        i = i + 1
    End If
Next OutlookMail

Set Folder = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing

End Sub

Sub RemoveHTMLTags(xRg As Range)
    Dim xCell As Range
    Dim xStr As String
    Dim xRegEx As RegExp
    Dim xMatch As Match
    Dim xMatches As MatchCollection
    Set xRegEx = New RegExp
    Application.EnableEvents = False
    With xRegEx
        .Global = True
        .Pattern = "<(""[^""]*""|'[^']*'|[^'"">])*>"
    End With
    For Each xCell In xRg
        xStr = xCell.Value
            Set xMatches = xRegEx.Execute(xCell.Text)
            For Each xMatch In xMatches
                xStr = Replace(xStr, xMatch.Value, "")
            Next
        xCell.Value = xStr
    Next
   Application.EnableEvents = True
End Sub

 

* Marque as Referencias:

Microsoft Outlook xx.x Object library 

Microsoft VBScript Regular Expression 5.5

 

Editado Maio 4, 2022 por Basole

[Victor J Ferreira]

9 minutos atrás, Basole disse:

Veja se ajuda:

 

Sub ObterMsgOutlook()
Dim OutlookApp As Outlook.Application
Dim OutlookNamespace As Namespace
Dim Folder As MAPIFolder
Dim OutlookMail As Variant
Dim i As Integer
Dim cbl As Boolean

Const PalavraChave = "Microsoft" ' * Coloque aqui o termo a pesquisar
Const ApartirdaData = #1/21/2021# ' * Formato MM/DD/AAAA

Set OutlookApp = New Outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
Set Folder = OutlookNamespace.GetDefaultFolder(olFolderInbox) 'caixa de entrada
i = 1
For Each OutlookMail In Folder.Items
    If InStr(1, OutlookMail.Body, PalavraChave, vbTextCompare) > 0 And _
       OutlookMail.ReceivedTime >= ApartirdaData Then
      If Not cbl Then
        Range("A1") = VBA.UCase("Assunto")
        Range("B1") = VBA.UCase("Data Recebimento")
        Range("C1") = VBA.UCase("Enviado por:")
        Range("D1") = VBA.UCase("Corpo E-mail")
        cbl = True
      End If
        Range("A1").Offset(i, 0).Value = OutlookMail.Subject
        Range("B1").Offset(i, 0).Value = OutlookMail.ReceivedTime
        Range("C1").Offset(i, 0).Value = OutlookMail.SenderName
        Range("D1").Offset(i, 0).Value = OutlookMail.Body
        RemoveHTMLTags Range("D1").Offset(i, 0)
        i = i + 1
    End If
Next OutlookMail

Set Folder = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing

End Sub


Sub RemoveHTMLTags(xRg As Range)
    Dim xCell As Range
    Dim xStr As String
    Dim xRegEx As RegExp
    Dim xMatch As Match
    Dim xMatches As MatchCollection
    Set xRegEx = New RegExp
    Application.EnableEvents = False
    With xRegEx
        .Global = True
        .Pattern = "<(""[^""]*""|'[^']*'|[^'"">])*>"
    End With
    For Each xCell In xRg
        xStr = xCell.Value
            Set xMatches = xRegEx.Execute(xCell.Text)
            For Each xMatch In xMatches
                xStr = Replace(xStr, xMatch.Value, "")
            Next
        xCell.Value = xStr
    Next
   Application.EnableEvents = True
End Sub

 

Basole, obrigado por responder!

Acredito que cometi alguns erros na minha maneira de expor o problema, vou tentar exemplificar melhor. 

Eu não possuo mais acesso a caixa de e-mail do outlook que contém os e-mails, possuo apenas os e-mails salvos em um diretório, no caso "D:\Acesso rápido\Documentos\E-mails". Precisaria que o código verificasse cada um dos e-mails dentro desse diretório no disco D, e não diretamente na caixa de entrada do outlook como no seu código que define o objeto Folder como a caixa de entrada do outlook.


A seguir o código que tentei realizar sem sucesso:

 

Sub Extrair_Outlook()



Dim OutlookApp As Object

Dim OutlookNamespace As Object

Dim Pasta As Outlook.Store

Dim Caminho_Pasta As String

Dim OutlookMail As Object

Dim i As Integer



Set OutlookApp = CreateObject("Outlook.Application")

Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")



Caminho_Pasta = "D:\Acesso rápido\Documentos\E-mails"



Set Pasta = CreateObject("Scripting.FileSystemObject").GetFolder(Caminho_Pasta)



i = 2



Range("A1:D1") = Array("Remetente", "Assunto", "Data Recebimento", "Corpo do e-mail")



For Each OutlookMail In Pasta.Files

    If TypeName(OutlookMail) = "MailItem" Then

        i = i + 1

            Cells(i, "A") = OutlookMail.SenderEmailAddress

            Cells(i, "B") = OutlookMail.Subject

            Cells(i, "C") = OutlookMail.ReceivedTime

            Cells(i, "D") = OutlookMail.Body

       

    End If

Next OutlookMail



Set Pasta = Nothing

Set OutlookNamespace = Nothing

Set OutlookApp = Nothing



Columns.AutoFit



End Sub

 

[Victor J Ferreira]

Infelizmente venho buscando em inúmeros forums e não encontrei nada dessa interação Outlook Mail com pasta de trabalho.

[Basole]

1 hora atrás, Victor J Ferreira disse:

....possuo apenas os e-mails salvos em um diretório, no caso "D:\Acesso rápido\Documentos\E-mails".

 

Seria um arquivo no formato "*.pst" ? 

 

[Victor J Ferreira]

13 minutos atrás, Basole disse:

Seria um arquivo no formato "*.pst" ? 

 

Nos diretórios ele possuí a extensão ".msg", mas lendo um pouco verifiquei algo a respeito dos .pst nos próprios diretorios da microsoft quando eles explicam o Objeto Store. Fiquei um pouco confuso, confesso. É possível tentar converter de .msg para .pst? 

[Basole]

Em 04/05/2022 em 15:34, Victor J Ferreira disse:

.....É possível tentar converter de .msg para .pst? 

Acho que não é necessario converter.

Até onde eu sei, não dá fazer isso com o VBA padrão e pesquisando não encontrei nenhuma bibiloteca gratuita ou open source relacionada que pudesse ler arquivos com essas extensões, somente aplicativos pagos.