Outlook VBA How to Auto Export Information of Incoming Emails to an Excel File with Outlook VBA

[WillemS]

Hi There I need help please with the below code.It automatically downloads information from my outlook account but I need to get it to just automatically download the said info for a specific folder called PIA, as and when new emails arrived.
Any help please to change the code to only download the info from the PIA folder in my outlook account, please? Thanks, Willem


Public WithEvents GMailItems As Outlook.Items
Private Sub Application_Startup()
Set GMailItems = Outlook.Application.Session.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub GMailItems_ItemAdd(ByVal Item As Object)
Dim xMailItem As Outlook.MailItem
Dim xExcelFile As String
Dim xExcelApp As Excel.Application
Dim xWb As Excel.Workbook
Dim xWs As Excel.Worksheet
Dim xNextEmptyRow As Integer
On Error Resume Next
If Item.Class <> olMail Then Exit Sub
Set xMailItem = Item
xExcelFile = "C:\Users\DT168\Desktop\split document\kto-data.xlsx"
If IsWorkBookOpen(xExcelFile) = True Then
Set xExcelApp = GetObject(, "Excel.Application")
Set xWb = GetObject(xExcelFile)
If Not xWb Is Nothing Then xWb.Close True
Else
Set xExcelApp = New Excel.Application
End If
Set xWb = xExcelApp.Workbooks.Open(xExcelFile)
Set xWs = xWb.Sheets(1)
xNextEmptyRow = xWs.Range("B" & xWs.Rows.Count).End(xlUp).Row + 1
With xWs
.Cells(xNextEmptyRow, 1) = xNextEmptyRow - 1
.Cells(xNextEmptyRow, 2) = xMailItem.SenderName
.Cells(xNextEmptyRow, 3) = xMailItem.SenderEmailAddress
.Cells(xNextEmptyRow, 4) = xMailItem.Subject
.Cells(xNextEmptyRow, 5) = xMailItem.ReceivedTime
End With
xWs.Columns("A:E").AutoFit
xWb.Save
End Sub
Function IsWorkBookOpen(FileName As String)
Dim xFreeFile As Long, xErrNo As Long
On Error Resume Next
xFreeFile = FreeFile()
Open FileName For Input Lock Read As #xFreeFile
Close xFreeFile
xErrNo = Err
On Error GoTo 0
Select Case xErrNo
Case 0: IsWorkBookOpen = False
Case 70: IsWorkBookOpen = True
Case Else: Error xErrNo
End Select
End Function

 

[GWteB]

If your PIA folder is on the same level as Outlook's default folders, than the code below should do what you're asking for. Note that the code has to be split up in three modules for it to work.

This goed in the ThisOutlookSession module:

Private Sub Application_Startup()
    Set myClass = New olEvents
    Set myClass.GMailItems = Outlook.Application.Session.GetDefaultFolder(olFolderInbox).Parent.Folders("PIA").Items
End Sub

This goes in a standard module:

Option Excplicit

Public myClass As olEvents

Public Function IsWorkbookOpen(ByVal argFileName As String) As Boolean
    Dim fileID As Long, errNum As Long
    fileID = FreeFile()
    On Error Resume Next
    Open argFileName For Input Lock Read As #fileID
    errNum = Err.Number
    Close fileID
    IsWorkbookOpen = CBool(errNum)
End Function

This goes in a class module which should be renamed to olEvents:

Option Explicit

Public WithEvents GMailItems    As Outlook.Items

Private Sub GMailItems_ItemAdd(ByVal Item As Object)
    Dim xMailItem As Outlook.MailItem
    Dim xExcelFile As String
    Dim xExcelApp As Excel.Application
    Dim xWb As Excel.Workbook
    Dim xWs As Excel.Worksheet
    Dim xNextEmptyRow As Integer
    On Error Resume Next
    If Item.Class <> olMail Then Exit Sub
    Set xMailItem = Item
    
    xExcelFile = "C:\Users\DT168\Desktop\split document\kto-data.xlsx"
    If IsWorkbookOpen(xExcelFile) = True Then
        Set xExcelApp = GetObject(, "Excel.Application")
        Set xWb = GetObject(xExcelFile)
        If Not xWb Is Nothing Then xWb.Close True
    Else
        Set xExcelApp = New Excel.Application
    End If
    Set xWb = xExcelApp.Workbooks.Open(xExcelFile)
    Set xWs = xWb.Sheets(1)
    xNextEmptyRow = xWs.Range("B" & xWs.Rows.Count).End(xlUp).Row + 1
    With xWs
        .Cells(xNextEmptyRow, 1) = xNextEmptyRow - 1
        .Cells(xNextEmptyRow, 2) = xMailItem.SenderName
        .Cells(xNextEmptyRow, 3) = xMailItem.SenderEmailAddress
        .Cells(xNextEmptyRow, 4) = xMailItem.Subject
        .Cells(xNextEmptyRow, 5) = xMailItem.ReceivedTime
    End With
    xWs.Columns("A:E").AutoFit
    xWb.Save
End Sub

 

[WillemS]

Hi there. Thank you so much for this I really appreciate it. I am very very new to VBA. Not sure where are you located and or if you can please navigate me through this to get it setup properly, please?

 

[GWteB]

Okay, I see. Within Outlook press ALT F11 to open the Visual Basic Editor (VBE). Within the VBE, if the Project Explorer's window isn't open yet, press CTRL R to open it. Expand the line saying Microsoft Outlook Objects. Double Click on the line saying ThisOutlookSession in order to open its code module. The VBE's title bar will confirm whether you're in the correct code module, see attached image. Paste the appropriate code into the right hand pane and close it afterwards.

Secondly, insert a standard code module by clicking Insert on the menu bar and clicking on Module. The right hand pane will open again, will be blank and the VBE's title bar will confirm whether you're in the correct module (like e.g. Module1). Paste the appropriate code into the right hand pane.
Now you have to insert a Class Module and to paste the correct code. Then press F4 key to open the module's property window. Rename the modules current name (like e.g. Class1) to olEvents. After that you may close the property window.
At this point click Menu > Debug > Compile Project 1. When there's no message displayed you're fine. Finally, press CTRL S to save this project (Project1(VBAProject.OTM)) and you're done. Now close Outlook and open Outlook again in order to fire the startup code.
Bear in mind that this approach has some limitations, since the event procedure will not be triggered when a large number of items will be added at once into the folder we're looking at.