Import Emails from Outlook

Video

Source codes

The highlighted code below is responsible for selecting the appropriate folder in the Outlook inbox. Checkout the video here

Import_Email.bas

'Import E-Mails from Outlook subroutine
Sub Import_Emails()

    'Empty the range
    Clear_Range

    'Create an Outlook Application object
    Dim OutlookApp As Outlook.Application

    'Create an Namespace object
    Dim OutlookNamespace As Namespace

    'Create a Outlook folder object
    Dim Folder As MAPIFolder

    'Object to store the retrieved E-Mails
    Dim OutlookItems As Outlook.items

    'Temporary object, used for iteration
    Dim OutlookMail As Variant

    'Get the folder name from excel sheet
    Dim FolderName As String
    FolderName = ActiveSheet.Range("D1").Value

    'Create an instance of Outlook
    Set OutlookApp = New Outlook.Application
    'Set the namespace
    Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
    'Error handling
    On Error GoTo ExitSub


    'If the checkbox is not checked, then the folder is at the same level as inbox
    If ActiveSheet.OLEObjects("check").Object.Value = False Then
        Set Folder = OutlookNamespace.GetDefaultFolder(olFolderInbox).Parent.Folders(FolderName)
    End If

    'If the checkbox is active, then it is a sub-folder of inbox
    If ActiveSheet.OLEObjects("check").Object.Value = True Then
        Set Folder = OutlookNamespace.GetDefaultFolder(olFolderInbox).Folders(FolderName)
    End If


    'Get the folder items and sort according to the recieved time
    Set OutlookItems = Folder.items
    OutlookItems.Sort "ReceivedTime", True

    'Results counter starting from Row 5
    Dim i As Integer
    i = 5

    'Print the output
    For Each OutlookMail In OutlookItems

        If OutlookMail.ReceivedTime >= ActiveSheet.Range("B1").Value Then
            ActiveSheet.Cells(i, 1).Value = OutlookMail.ReceivedTime
            ActiveSheet.Cells(i, 2).Value = OutlookMail.SenderName
            ActiveSheet.Cells(i, 3).Value = OutlookMail.Subject
            ActiveSheet.Cells(i, 4).Value = OutlookMail.Body
            i = i + 1
        End If

    Next OutlookMail

    'Display the total number of e-mails retrieved
    ActiveSheet.Range("B2").Value = i - 5
    ActiveSheet.Range("B2").Font.Color = vbBlack

    'Reset the obejcts
    Set OutlookItems = Nothing
    Set Folder = Nothing
    Set OutlookNamespace = Nothing
    Set OutlookApp = Nothing

    Exit Sub

'Error handling function
ExitSub:
    ActiveSheet.Range("B2").Value = "Folder name not found"
    ActiveSheet.Range("B2").Font.Color = vbRed

    Set OutlookItems = Nothing
    Set Folder = Nothing
    Set OutlookNamespace = Nothing
    Set OutlookApp = Nothing


End Sub

clear_range.bas

'Clear the range contents
Sub Clear_Range()

    Dim lastRow As Integer
    lastRow = Cells(Rows.Count, 1).End(xlUp).Row
    If lastRow > 4 Then
        ActiveSheet.Range("A5:D" & lastRow).ClearContents
    End If

End Sub

Automate the script (to be tested yet)

The functions should be assigned to 2 buttons in the Excel-Sheet.

automate.bas

Dim NextCheck As Double

Sub StartEmailCheck()
    Import_Emails
    NextCheck = Now + TimeValue("00:00:03") ' 3 seconds
    Application.OnTime NextCheck, "StartEmailCheck"
End Sub

Sub StopEmailCheck()
    On Error Resume Next
    Application.OnTime NextCheck, "StartEmailCheck", , False
End Sub