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 SubDiscussão (0)
Carregando comentários...