Pesquisar na Comunidade

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