Extracao de Emails do Outlook

[Morpheus#2005 1]

Opa! bão com vcs ?

 

estou quebrando a cabeça para extrair todos os emails do  outlook em VBA... tem como alguem me ajudar? to meio enferrujadoooo...rs

 

Ele ate roda, mais nao pega todos os emails com a palavra REPORT no cabeçalho.....

 

ta ossadaaaaaa... abraços aii

 

 

Sub lerEmails()

' Criando a aplicação do Outlook
Dim objOutlook As Object
Set objOutlook = CreateObject("Outlook.Application")

' Criando um Namespace, que seria uma sessão no Outlook
Dim objNSpace As Object
Set objNSpace = objOutlook.GetNamespace("MAPI")

Dim Pasta_Destino As Outlook.MAPIFolder
Dim Pasta_Raiz As Outlook.MAPIFolder

Set Pasta_Destino = objNSpace.Folders("email@email.com").Folders("Inbox").Folders("Marcia")
Set Pasta_Raiz = objNSpace.Folders("femail@email.com").Folders("Inbox").Folders("Marcia")

' Cria um objeto com a pasta Inbox do Outlook
Dim minhaPasta As Object
Set minhaPasta = objNSpace.GetDefaultFolder(olFolderInbox)

Dim i As Long
Dim itemPasta As Object
Dim testCheck As String

Selection.End(xlDown).Select

Linha = Sheets("Planilha1").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).row

i = Sheets("Planilha1").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).row

 'Linha que vai começar preenchendo na planilha

' Percorrer todos os itens dentro da pasta
    For Each itemPasta In minhaPasta.Items
    
     testCheck = Trim(UCase(Left(itemPasta, 6)))
    
    If testCheck = "REPORT" Then
    
        If itemPasta.Class = olMail Then
            Dim objEmail As Outlook.MailItem
            Set objEmail = itemPasta
            Set Pasta_Destino = objNSpace.Folders("email@email.com").Folders("Inbox").Folders("Marcia")
            
            If objEmail.SenderName = "Relatorios_BI" Then GoTo fim:
    
            Cells(i, 1).Value = objEmail.SenderName
            Cells(i, 2).Value = objEmail.Subject
            Cells(i, 3).Value = objEmail.ReceivedTime
            
             'Set minhaPasta = objNSpace.GetDefaultFolder(olFolderInbox)
             
             objEmail.Move Pasta_Destino
            
             Set Pasta_Raiz = objNSpace.Folders("email@email.com").Folders("Inbox")
             
        End If

        i = i + 1
        
        Set Pasta_Raiz = objNSpace.Folders("email@email.com").Folders("Inbox")
    
    End If
    
fim:
        Set Pasta_Destino = objNSpace.Folders("email@email.com").Folders("Inbox")
    Next

        MsgBox ("FIM")
        
        Set objEmail = Nothing
        Set objOutlook = Nothing
        Set objNSpace = Nothing
        Set minhaPasta = Nothing
        Set Pasta_Destino = Nothing
        Set itemPasta = Nothing

End Sub