Extracao de Emails do Outlook

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