Get list of emails from outlook - different mailboxes

[FelipeVaz]

Hi guys,

Im trying to get the list of emails (subject, sender email and date) from Outlook.

I have a lot of mailboxes and thats que question. Because Im using a code that get the list, but I am not getting from the right mailbox.

Could you guys help me to do this?

The code arent working as expected, this is not thaaat code, but...

- It is extracting the list, ok, but
- The code gets the list from primary mailbox and I would like to choose the right mailbox
- The code does not delete the last search if the date defined find less emails rows
- The code format data as table and the way that I autofit columns isnt good I guess


Sub GetFromOutlook()

Dim OutlookApp As Outlook.Application
Dim OutlookNamespace As Namespace
Dim Folder As MAPIFolder
Dim OutlookMail As Variant
Dim i As Integer
Dim tblExists As Boolean

Set OutlookApp = New Outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
Set Folder = OutlookNamespace.GetDefaultFolder(olFolderInbox)
i = 1

For Each OutlookMail In Folder.Items
If OutlookMail.ReceivedTime >= Range("From_date").Value Then
Range("email_Subject").Offset(i, 0).Value = OutlookMail.Subject
Range("email_Subject").Offset(i, 0).VerticalAlignment = xlTop
Range("email_Date").Offset(i, 0).Value = OutlookMail.ReceivedTime
Range("email_Date").Offset(i, 0).VerticalAlignment = xlTop
Range("email_Sender").Offset(i, 0).Value = OutlookMail.SenderEmailAddress
Range("email_Sender").Offset(i, 0).VerticalAlignment = xlTop
Range("A3").Select
i = i + 1
End If
Next OutlookMail

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

'Check the same already exists
tblExists = False
For Each o In Sheets("Import").ListObjects
If o.Name = "OutlookEmail" Then tblExists = True
Next o

'If exists, delete the table first
If (tblExists) Then
Sheets("Import").ListObjects("OutlookEmail").Unlist
End If

Columns("A:C").EntireColumn.AutoFit

End Sub

 

[FelipeVaz]

Ops...my bad

UPDATE
The code arent working as expected, this is not thaaat code, but...

- It is extracting the list, ok, but
- The coge gets the list from a specified date, and I would like to get all itens
- The code gets the list from primary mailbox and I would like to choose the right mailbox
- The code does not delete refresh the list, like deleting all data and gets again
- The code format data as table and the way that I autofit columns isnt good I guess

 

[FelipeVaz]

UPDATE
I got the code

Sub Emails_Outlook()
'Carregar e-mails do outlook para o excel
Dim appOutlook As Object
Dim olNS As Object
Dim olFolder As Object
Dim olItem As Object
Dim r As Long
Dim Ws As Worksheet
Dim LstObj As ListObject
Dim rngDB As Range, n As Integer

On Error Resume Next
Set appOutlook = GetObject(, "Outlook.Application")
If appOutlook Is Nothing Then
Set appOutlook = CreateObject("Outlook.Application")
End If
On Error GoTo 0
Set olNS = appOutlook.GetNamespace("MAPI")
'Abaixo preencha o nome do arquivo de dados PST e a pasta.
'Neste caso o arquivo é Douglas Godoy e a pasta Caixa de Entrada.
Set olFolder = olNS.Folders("vaz.felipe@outlook.com.br").Folders("Caixa de Entrada").Folders("Teste")
Cells.Delete
r = 3
'Cria um array montando o título das colunas no arquivo.
Range("A3:E3") = Array("Título", "Quem enviou", "Nome de quem enviou", "Para", "Data e Hora")
For Each olItem In olFolder.Items
If TypeName(olItem) = "MailItem" Then
r = r + 1
Cells(r, "A") = olItem.Subject 'Assunto do e-mail
Cells(r, "B") = olItem.SenderEmailAddress 'E-mail do remetente
Cells(r, "C") = olItem.Sender 'Nome do remetente
Cells(r, "D") = olItem.To 'E-mail do destinatário
Cells(r, "E") = olItem.ReceivedTime 'Data/Hora de recebimento

'Cells(r, "E") = olItem.Attachments.Count 'Número de anexos
'Cells(r, "F") = olItem.Size 'Tamanho da mensagem em bytes
'Cells(r, "G") = olMail.LastModificationTime 'Última modificação
'Cells(r, "H") = olMail.Categories 'Categoria
'Cells(r, "I") = olMail.SenderName 'Nome do remetente
'Cells(r, "J") = olMail.FlagRequest 'Acompanhamento
'Cells(r, "K") = olItem.Body 'Tome cuidado ao utilizar pois carrega os dados do corpo do email
Application.StatusBar = r
End If
Next olItem

For Each Ws In Worksheets
With Ws
Set rngDB = .Range("a3").CurrentRegion
For Each LstObj In Ws.ListObjects
LstObj.Unlist
Next
If WorksheetFunction.CountA(rngDB) > 0 Then
n = n + 1
Set LstObj = .ListObjects.Add(xlSrcRange, rngDB, , xlYes)
With LstObj

.Name = "AtendimentoPresencial" '& n
.TableStyle = "TableStyleLight8"
End With
End If
End With
Next Ws

Columns.AutoFit
End Sub

 

[FelipeVaz]

Do you know which mail properties I need to use to get the tracking information of the conversations (CRM)?

Library: https://docs.microsoft.com/en-us/do...irectedfrom=MSDN&view=outlook-pia#properties_