Get feild details from outlook to excel

[THE_NEW_XL_GUY]

Hello guys,

can someone help me to get this code work, it just freezes whenever I run macro.. and

in detail:

I have the code below which I got from internet and it is used to get data like subject, received time, sender name etc from specific date which I give as input

later I tweaked it to work with sharedmailbox mails only.

Now problem:

it just freezes and I also want to include categorized mails I mean on what category it is categorized, need that details as well..


Any help, I really appreciate it. thanks in advance!

Sub GetFromOutlook()
Dim OutlookApp As Outlook.Application
Dim OutlookNamespace As Namespace
Dim Folder As MAPIFolder
Dim OutlookMail As Variant
Dim i As Integer

Set OutlookApp = New Outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
Set olShareName = OutlookNamespace.CreateRecipient("email@exAMPLE.com")
Set Folder = OutlookNamespace.GetSharedDefaultFolder(olShareName, 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_date").Offset(i, 0).Value = OutlookMail.ReceivedTime
        Range("eMail_sender").Offset(i, 0).Value = OutlookMail.SenderName
        Range("eMail_size").Offset(i, 0).Value = OutlookMail.Size
        'Range("eMail_categories").Offset(i, 0).Value = OutlookMail.Categorize // is there way to get categorized mails with name of category 
        
        
        i = i + 1
    End If
Next OutlookMail
Set Folder = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing
End Sub

 

[Domenic]

Writing to cells that way is very inefficient. Instead, use an array to fill it with the desired data, and then transfer the contents of that array to your worksheet. Maybe something like this...

Sub GetFromOutlook()    Dim OutlookApp As Outlook.Application
    Dim OutlookNamespace As Outlook.Namespace
    Dim olShareName As Outlook.Recipient
    Dim Folder As MAPIFolder
    Dim OutlookMail As Variant
    Dim arrResults() As Variant
    Dim ItemCount As Long
    
    Set OutlookApp = New Outlook.Application
    Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
    Set olShareName = OutlookNamespace.CreateRecipient("email@exAMPLE.com")
    Set Folder = OutlookNamespace.GetSharedDefaultFolder(olShareName, olFolderInbox)
    
    If Folder.Items.Count > 0 Then
        ReDim arrResults(1 To Folder.Items.Count, 1 To 5)
        ItemCount = 0
        For Each OutlookMail In Folder.Items
            ItemCount = ItemCount + 1
            arrResults(ItemCount, 1) = OutlookMail.Subject
            arrResults(ItemCount, 2) = OutlookMail.ReceivedTime
            arrResults(ItemCount, 3) = OutlookMail.SenderName
            arrResults(ItemCount, 4) = OutlookMail.Size
            arrResults(ItemCount, 5) = OutlookMail.Categories
        Next OutlookMail
        Worksheets("Sheet1").Range("A1").Resize(UBound(arrResults, 1), 5) = arrResults
    Else
        MsgBox "No items found!", vbExclamation
    End If
    
    Set Folder = Nothing
    Set OutlookNamespace = Nothing
    Set olShareName = Nothing
    Set OutlookApp = Nothing
End Sub

Hope this helps!

 

[THE_NEW_XL_GUY]

Hi @Domenic, thanks for replying! so its still freezing when ever I run macro.
and also the macro I posted had option to select a date from which we need the data to be pulled, can you just help me to add from date in code.

I have added it. correct me if wrong

Sub GetFromOutlook()
Dim OutlookApp As Outlook.Application
    Dim OutlookNamespace As Outlook.Namespace
    Dim olShareName As Outlook.Recipient
    Dim Folder As MAPIFolder
    Dim OutlookMail As Variant
    Dim arrResults() As Variant
    Dim ItemCount As Long
    
    Set OutlookApp = New Outlook.Application
    Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
    Set olShareName = OutlookNamespace.CreateRecipient("example@email[EMAIL="milind.p@.com"].com[/EMAIL]")
    Set Folder = OutlookNamespace.GetSharedDefaultFolder(olShareName, olFolderInbox)
    
    If OutlookMail.ReceivedTime >= Range("From_date").Value Then // cell name is given as from_date and run button place next to it run macro.    

If Folder.Items.Count > 0 Then
        ReDim arrResults(1 To Folder.Items.Count, 1 To 5)
        ItemCount = 0
        For Each OutlookMail In Folder.Items
            ItemCount = ItemCount + 1
            arrResults(ItemCount, 1) = OutlookMail.Subject
            arrResults(ItemCount, 2) = OutlookMail.ReceivedTime
            arrResults(ItemCount, 3) = OutlookMail.SenderName
            arrResults(ItemCount, 4) = OutlookMail.Size
            arrResults(ItemCount, 5) = OutlookMail.Categories
        Next OutlookMail
        Worksheets("Sheet1").Range("A5").Resize(UBound(arrResults, 1), 5) = arrResults
    Else
        MsgBox "No items found!", vbExclamation
    End If
    End If
    
    
    Set Folder = Nothing
    Set OutlookNamespace = Nothing
    Set olShareName = Nothing
    Set OutlookApp = Nothing
End Sub

 

[Domenic]

Try using the Restrict method of the Items object to filter the data based on the date...

Sub GetFromOutlook()
    Dim OutlookApp As Outlook.Application
    Dim OutlookNamespace As Outlook.Namespace
    Dim olShareName As Outlook.Recipient
    Dim Folder As MAPIFolder
    Dim olItems As Outlook.Items
    Dim OutlookMail As Variant
    Dim arrResults() As Variant
    Dim ItemCount As Long
    
    Set OutlookApp = New Outlook.Application
    Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
    Set olShareName = OutlookNamespace.CreateRecipient("example@email.com")
    Set Folder = OutlookNamespace.GetSharedDefaultFolder(olShareName, olFolderInbox)
    Set olItems = Folder.Items.Restrict("[ReceivedTime] >= '" & Range("From_date").Value & "'")
    
    If olItems.Count > 0 Then
        ReDim arrResults(1 To olItems.Count, 1 To 5)
        ItemCount = 0
        For Each OutlookMail In olItems
            ItemCount = ItemCount + 1
            arrResults(ItemCount, 1) = OutlookMail.Subject
            arrResults(ItemCount, 2) = OutlookMail.ReceivedTime
            arrResults(ItemCount, 3) = OutlookMail.SenderName
            arrResults(ItemCount, 4) = OutlookMail.Size
            arrResults(ItemCount, 5) = OutlookMail.Categories
        Next OutlookMail
        Worksheets("Sheet1").Range("A5").Resize(UBound(arrResults, 1), 5) = arrResults
    Else
        MsgBox "No items found!", vbExclamation
    End If
    
    Set olItems = Nothing
    Set Folder = Nothing
    Set OutlookNamespace = Nothing
    Set olShareName = Nothing
    Set OutlookApp = Nothing
End Sub

Does this help?

 

[THE_NEW_XL_GUY]

Hi mate, very sorry for delayed reply.

I got the following error while handling: script out of range.

when I debug its showing in line

Worksheets("Sheet1").Range("A5").Resize(UBound(arrResults, 1), 5) = arrResults

.

so I didn't quite understand what it meant. help me kindly

 

[Domenic]

That line of code transfers the content of the array to a worksheet called "Sheet1" in the active workbook. So if the active workbook doesn't contain a sheet called "Sheet1", you'll get that error. Either make sure that the workbook containing that sheet is the active workbook or qualify the reference to your worksheet...

Workbooks("Book1.xlsx").[COLOR=#333333]Worksheets("Sheet1").Range("A5").Resize(UBound(arrResults, 1), 5) = arrResults[/COLOR]

Hope this helps!

 

[THE_NEW_XL_GUY]

thanks a ton mate!! it worked. but categorization field is not working. is there way to call inbuilt function just like outlook.subject or outlook.sendername kinda function

 

[Domenic]

outlook.categories should return the category or categories. If it doesn't return anything, the category likely has not been set.

 

[THE_NEW_XL_GUY]

yeah! correct thanks mate. Its working great. One last question does adding another olitems to include "To_date" work?

Does this line code work:

Set olItems = Folder.Items.Restrict("[ReceivedTime] >= '" & Range("From_date").Value & "'")
    Set olItems2 = Folder.Items.Restrict("[ReceivedTime] >= '" & Range("to_date").Value & "'")

If not any other better option to include to date in code just like from date.


thanks for all the help.

 

[Domenic]

Try...

Set olItems = Folder.Items.Restrict("[ReceivedTime] >= '" & Range("From_date").Value & "' and [ReceivedTime] <= '" & Range("to_date").Value & "'")

Hope this helps!