VBA Code For Outlook

[Patrick.Grant01]

Can anyone help with a piece of VBA code to read all folders in an Outlook pst file and retrieve:



>>> Folder Name (e.g. Inbox & Subfolder Names)

and:

>>> Email addresses for To & From
>>> Date Sent/Received
>>> Subject
>>> Email Text

I would like to load the data into a table

Many thanks

[June7]

See if this has what you want https://www.devhut.net/vba-extract-o...mail-messages/

Instead of Debug.Print, use code to insert data to table.

[Patrick.Grant01]

See if this has what you want https://www.devhut.net/vba-extract-o...mail-messages/

Instead of Debug.Print, use code to insert data to table.

Many thanks.

The code on the link is close to what I wanted. With luck, I can figure out solutions to other other issues I have. Like an instance of Outlook with multiple pst files, how to get email address instead of name, what libraries I need to run the code and whatever other surprises crop up ;0)

[Gicu]

Give it a try and post back if\when you get stuck !

Cheers,

[Patrick.Grant01]

Give it a try and post back if\when you get stuck !

Cheers,

I am going to un-retire and see if I can make it what I want it to be .. the code is tied to a single folder, I want it to read all active folders in two outlook .pst files. I also want the email addresses rather than the names.

So I am going to crack on to add two more loops to the code .. one to identify each of the the pst files and another to identify each folder in each pst file.

My big question is once I have re-worked the code who should publish it and where?

The reason I have to do this is to out manoeuvre Weaselly Health service providers…

[June7]

Maybe for more clues review https://forums.slipstick.com/threads...sing-vba-code/

[Patrick.Grant01]

I have got the code working with a DAO record set etc. I can select a folder and load the emails in the selected folder it into a table. I have 3-4 levels of sub folders and quite a few of them.

What I would like to do is navigate down from the top folder in the hierarchy to each of the sub folders and load the emails in each. I can see the oFolder object has a property called "Folders". It also has a count of sub folders and the first level of sub folders in items 1 to 10. I can see the folder names are as expected. Each of folder items 1-10 can have 0 or more folder levels beneath them. So it is quite hierarchy of about 50 folders.

I cannot find the value of 6 for the Inbox aka olFolderInbox ... which I had expected to find there somewhere. I can see the folder entry ids and names though.

See Test Code below which I am using to examine values in the Local Variables window..

I am getting stuck in quite deep mud !!!!


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 Breakpoint on next line ******************************************
' Look at oFolder in Local Variables Window and find the Folders collection
' How can I navigate throght the Folders Collection to return all the sub folder ids ?
' and then obtain with each folder id, return all the mail items in each sub folder ?
' How as olFolderInbox = 6 obtained? It myust be in there somehwere !!!!
' ************************************************** ***********************************


Set oFolder = oNameSpace.GetDefaultFolder(olFolderInbox)
' Set oFolder = oOutlook.ActiveExplorer.CurrentFolder 'Process the currently selected folder
' Set oFolder = oNameSpace.PickFolder 'Prompt the user to select the folder to process


' ********* Set Breakpoint here and look at oFolder in Local Variablae Window
' How can I parse the Folders


On Error Resume Next

For Each oItem In oFolder.Items


With oItem


If .Class = olMail Then

Debug.Print .EntryId, .Subject, .Sender, .SentOn, .ReceivedTime,

For Each oPrp In .ItemProperties
Debug.Print , oPrp.Name, oPrp.Value
Next oPrp

End If

End With
Next oItem


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

[June7]

Please post code between CODE tags to retain indentation and readability.

I don't know about navigating these Outlook subfolders but maybe there is a clue in: http://allenbrowne.com/ser-59.html

[Gicu]

Here is some updated code to loop through the subfolders:

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,