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.


1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
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
        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 at the following link:


See How To Extract Outlook Emails To Excel

outlook excel to access table vba

Offsite Related Information:

“Go Fund Me” Page


($5 suggested amount)

(…10% of your gift amount will go to charity)

Free! Subscribe To Our YouTube Channel!

Free MS Access VBA Programming Course

Facebooktwitterredditpinterestlinkedinmailby feather
Tags: ,