How To Use VBA To Extract Outlook Emails To Access Table

I use this code to extract outlook emails from a certain Outlook folder of a user (like the user’s Inbox) whenever they leave the department.

This code will loop the Outlook Inbox (or other folder) of the logged in user’s Microsoft Exchange Account, and insert the body of the message into an Access table.

Note: You need to run this on the machine where the user’s Outlook account is.

Option Compare Database

Option Explicit

Sub LoopInbox()
    '2/28/19 - loop and save outlook messages to folder
    
    Dim olApp As Outlook.Application
    Dim olNs As Outlook.NameSpace
    Dim olParentFolder As Outlook.Folder
    Dim olMail As Object
          
    On Error Resume Next
    
    CurrentDb.Execute ("DELETE * FROM tblOutlook")
    
    Set olApp = GetObject(, "Outlook.Application")
    On Error GoTo 0
    If olApp Is Nothing Then
        Set olApp = CreateObject("Outlook.Application")
    End If
    
    Set olNs = olApp.GetNamespace("MAPI")
    Set olParentFolder = olNs.GetDefaultFolder(olFolderInbox)

    
    ProcessFolder olParentFolder
    
ExitRoutine:
    
    Set olParentFolder = Nothing
    Set olNs = Nothing
    Set olApp = Nothing

End Sub


Private Sub ProcessFolder(ByVal oParent As Outlook.Folder)
    
    Dim olFolder As Outlook.Folder
    Dim olMail As Object
    
    Dim lngItem As Long
    Dim iCounter As Long
    Dim lrow As Long
    Dim lastrow As Long
    
    Dim strSQL As String
    
    On Error Resume Next
    
    
    For lngItem = oParent.Items.Count To 1 Step -1
    
        Debug.Print oParent
        If TypeOf oParent.Items(lngItem) Is MailItem Then
            Set olMail = oParent.Items(lngItem)
    
            Debug.Print " " & olMail.Subject
            Debug.Print " " & olMail.ReceivedTime
            Debug.Print " " & olMail.SenderEmailAddress
            Debug.Print " " & olMail.Body
            Debug.Print

            If olMail.Attachments.Count > 0 Then
                'MsgBox "Attachments"
                
            End If
            
            
            strSQL = "INSERT INTO tblOutlook (out_Folder, out_Subject, out_ReceivedTime, out_SenderEmailAddress, out_Body) "
            strSQL = strSQL & " VALUES ('" & oParent.Name & "','" & SQLFixup(olMail.Subject) & "',#" & olMail.ReceivedTime & "#,'" & olMail.SenderEmailAddress & "','" & SQLFixup(olMail.Body) & "')"
            
            CurrentDb.Execute strSQL
            
            strSQL = vbNullString
            
        End If
    
    Next lngItem
    
    'process the subfolders
    If (oParent.Folders.Count > 0) Then
        For Each olFolder In oParent.Folders
            ProcessFolder olFolder
        Next
    End If

End Sub


Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
saveFolder = "c:\temp"
     For Each objAtt In itm.Attachments
          objAtt.SaveAsFile saveFolder & "\" & objAtt.DisplayName
          Set objAtt = Nothing
     Next
End Sub

Function ReplaceStr(TextIn, ByVal SearchStr As String, _
    ByVal Replacement As String, _
    ByVal CompMode As Integer)
    
    '11/1/2017
    Dim WorkText As String, Pointer As Long
    
    If IsNull(TextIn) Then
        ReplaceStr = Null
    Else
        WorkText = TextIn
        Pointer = InStr(1, WorkText, SearchStr, CompMode)
        Do While Pointer <> 0
            WorkText = Left(WorkText, Pointer - 1) & Replacement & _
            Mid(WorkText, Pointer + Len(SearchStr))
            Pointer = InStr(Pointer + Len(Replacement), WorkText, _
            SearchStr, CompMode)
        Loop
        ReplaceStr = WorkText
    End If

End Function

Function SQLFixup(TextIn)
    '11/1/2017
    SQLFixup = ReplaceStr(TextIn, "'", "''", 0)

End Function

You can make this look nice and pretty if you want, but basically left click in the “LoopInbox()” procedure and press F5 (run) on your keyboard.

You may want to check out my Excel version here:

Extract Outlook Emails To Excel

By the way, if you got or are getting value from the VBA information, please give me a tip, thanks!