Here is some updated code to loop through the subfolders:
Code:
Sub Outlook_TestCode()
Dim oOutlook As Object 'Outlook.Application
Dim oNameSpace As Object 'Outlook.Namespace
Dim oFolder As Object 'Outlook.folder
Dim oItem As Object
Dim oPrp As Object
Const olFolderInbox = 6
Const olMail = 43
'On Error Resume Next
'************ Create Outlook Object
Set oOutlook = GetObject(, "Outlook.Application") 'Bind to existing instance of Outlook
If Err.Number <> 0 Then 'Could not get instance, so create a new one
Err.Clear
Set oOutlook = CreateObject("Outlook.Application")
End If
On Error GoTo Error_Handler
Set oNameSpace = oOutlook.GetNamespace("MAPI")
Set oFolder = oNameSpace.GetDefaultFolder(olFolderInbox)
ProcessFolder oFolder 'calls the process folder sub which calls itself recursively
Error_Handler_Exit:
On Error Resume Next
If Not oPrp Is Nothing Then Set oPrp = Nothing
If Not oItem Is Nothing Then Set oItem = Nothing
If Not oFolder Is Nothing Then Set oFolder = Nothing
If Not oNameSpace Is Nothing Then Set oNameSpace = Nothing
If Not oOutlook Is Nothing Then Set oOutlook = Nothing
Exit Sub
Error_Handler:
MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: Outlook_ExtractMessages" & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occurred!"
Resume Error_Handler_Exit
End Sub
Private Sub ProcessFolder(ByVal oParent As Folder)
Dim oFolder As Folder
Dim oMail As Object
Dim rs as DAO.recordset
Set rs=CurrentDB.Openrecordset("tblEmailInfo") 'this is your table in which you collect the email info
For Each oMail In oParent.Items
If TypeName(oMail) = "MailItem" Then
'set a recordset and insert your required data
Debug.Print .EntryId, .Subject, .Sender, .SentOn, .ReceivedTime,
rs.AddNew
rs("SenderEmail") = oMail.SenderEmailAddress
rs("ReceivedTime") = oMail.ReceivedTime
rs("Subject") = oMail.Subject
rs("Sender") = oMail.Sender
rs("To") = oMail.To
rs("EntryID")=oMail.EntryID
rs("SentOn") = oMail.SentOn
'add any other info like CC,bCC
rs.Update
End If
Next
If (oParent.Folders.count > 0) Then
For Each oFolder In oParent.Folders
ProcessFolder oFolder
Next
End If
End Sub
Some useful links:
https://stackoverflow.com/questions/...ng-sub-folders
https://stackoverflow.com/questions/...53951#33553951
And please feel free to download and have a look at my free utility that has some code that should help you with this project:
http://forestbyte.com/ms-access-util...ook-companion/
Cheers,