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

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

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

End If

End Sub

Public Sub saveAttachtoDisk(itm As Outlook.MailItem)

Dim objAtt As Outlook.Attachment