I export email data from a folder that has subfolders, from a shared mailbox.
I am trying to loop through the existing values in column E, comparing the string value of the email.EntryID field to the string value of the cell, to skip the emails (email fields) that were already exported.
Option Explicit
Sub inbox_working()
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim Sht As Excel.Worksheet
Dim olApp As Outlook.Application
Set olApp = New Outlook.Application
Dim olNs As Outlook.Namespace
Set olNs = olApp.GetNamespace("MAPI")
Dim olRecip As Outlook.Recipient
Set olRecip = olNs.CreateRecipient("exampleEmail@email.com") ' Update email
Dim Inbox As Outlook.MAPIFolder
Set Inbox = olNs.GetSharedDefaultFolder(olRecip, olFolderInbox)
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
Set xlWB = xlApp.Workbooks.Open("C:\Desktop\mails.xlsm")
Set Sht = xlWB.Sheets("inbox_email_data")
With Sht
.Range("A3").Value = "Sender"
.Range("B3").Value = "Received_Date_Time"
.Range("C3").Value = "Converation Topic"
.Range("D3").Value = "Category"
.Range("E3").Value = "message_ID"
.Range("F3").Value = "conversation_ID"
.Range("G3").Value = "Folder Name"
End With
' // Process Current Folder
LoopFolders Inbox, Sht
End Sub
Private Sub LoopFolders( _
ByVal CurrentFolder As Outlook.MAPIFolder, _
ByVal Sht As Worksheet _ )
Dim Items As Outlook.Items
Set Items = CurrentFolder.Items
Dim i As Long
Dim last_row As Long
Dim Item As Object ' Outlook.MailItem
Dim cell As Range
With Sht
last_row = Sht.Range("A" & .Rows.Count).End(xlUp).Row + 1
For i = Items.Count To 1 Step -1 ' run loop
Set Item = Items(i)
'DoEvents
If TypeOf Item Is Outlook.MailItem Then
For Each cell In .Range("ID_inbox").Cells '----> the range here =$E$4:$Erowatendofworksheet
If CStr(Item.entryID) = CStr(cell.Value) Then
' do nothing
Else
.Range("A" & last_row).Value = Item.SenderName '----> at this line it breaks with 1004 error
.Range("B" & last_row).Value = Item.ReceivedTime
.Range("C" & last_row).Value = Item.ConversationTopic
.Range("D" & last_row).Value = Item.categories
.Range("E" & last_row).Value = Item.entryID
.Range("F" & last_row).Value = Item.ConversationID
.Range("G" & last_row).Value = CurrentFolder.Name
End If
Next
Else
' do nothing
End If
Next
last_row = last_row + 1
' // Recurse through subfolders
Dim folder As Outlook.MAPIFolder
If CurrentFolder.Folders.Count > 0 Then
For Each folder In CurrentFolder.Folders
LoopFolders folder, Sht
Next
End If
End With
' // Cleanup
Set folder = Nothing
Set Item = Nothing
Set Items = Nothing
End Sub
The code writes the data (fields) of the first email and then gives the error at that line.
I gather, it fails to 'do nothing if the string values match.
The cells in the sheet are unlocked (Ctrl+A->Right click->Permissions->Locked field is unticked).
Later edit:
Using the below, exports every time, all email items from all folders and subfolders of the Inbox folder.
Using event the lightest filering (fx. Item.ReceivedTime > a specific date) or other (as the one mentioned in the answer), renders the Outlook frozen.
Option Explicit
Sub all_email()
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim Sht As Excel.Worksheet
Dim olApp As Outlook.Application
Set olApp = New Outlook.Application
Dim olNs As Outlook.Namespace
Set olNs = olApp.GetNamespace("MAPI")
Dim olRecip As Outlook.Recipient
Set olRecip = olNs.CreateRecipient("email@email.com") ' Update email
Dim Inbox As Outlook.MAPIFolder
Set Inbox = olNs.GetSharedDefaultFolder(olRecip, olFolderInbox)
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
Set xlWB = xlApp.Workbooks.Open("C:\Desktop\mails.xlsm")
Set Sht = Sheets("email_data")
With Sht
.Range("A3").Value = "Sender"
.Range("B3").Value = "Date_Time"
.Range("C3").Value = "Conversation_Topic"
.Range("D3").Value = "Category"
.Range("E3").Value = "Entry_ID"
.Range("F3").Value = "Conversation_ID"
.Range("G3").Value = "Mailbox"
End With
' // Process Current Folder
LoopFolders Inbox, Sht
End Sub
Sub LoopFolders( _
ByVal CurrentFolder As Outlook.MAPIFolder, _
ByVal Sht As Worksheet _
)
Dim Items As Outlook.Items
Set Items = CurrentFolder.Items
Dim i As Long
Dim last_row As Long
Dim Item As Object ' Outlook.MailItem
With Sht
last_row = Sht.Range("A" & .Rows.Count).End(xlUp).Row + 1
For i = Items.Count To 1 Step -1 ' run loop
Set Item = Items(i)
DoEvents
If TypeOf Item Is Outlook.MailItem Then
Debug.Print Item
.Range("A" & last_row).Value = Item.SenderName
.Range("B" & last_row).Value = Item.ReceivedTime
.Range("C" & last_row).Value = Item.ConversationTopic
.Range("D" & last_row).Value = Item.categories
.Range("E" & last_row).Value = Item.entryID
.Range("F" & last_row).Value = Item.ConversationID
.Range("G" & last_row).Value = CurrentFolder.Name
Else
End If
last_row = last_row + 1
Next
' // Recurse through subfolders
Dim folder As Outlook.MAPIFolder
If CurrentFolder.Folders.Count > 0 Then
For Each folder In CurrentFolder.Folders
LoopFolders folder, Sht
Next
End If
End With
' // Cleanup
Set folder = Nothing
Set Item = Nothing
Set Items = Nothing
End Sub
Later edit 2:
After using @niton's comments and partial solution, as it stands now, only the items from subfolders of the Inbox folder are extracted. When the script encounters a subfolder of a subfolder (i.e. Inbox->Subfolder->Subfolder) it stops.
How would I iterate through subfolders of each of the subfolder in the Inbox?
I tried:
// Recurse through subfolders
Dim folder As Outlook.MAPIFolder
Dim subfolder As Outlook.folder
If CurrentFolder.Folders.Count > 0 Then
For Each folder In CurrentFolder.Folders
LoopFolders folder, Sht
If folder.Folders.Count > 0 Then
For Each subfolder In folder.Folders
LoopFolders subfolder, Sht
Next
End If
Next
End If
But with no awail.
Also, how would I be able to extract the mail items data from the Sent folder?
Thank you.
