How To Extract Data From Outlook To Access With VBA

In this post you are going to find out how you can extract data From Outlook to Access with VBA”.

Someone at the place I’m working at was let go, and they wanted the information, primarily from the user’s Outlook inbox, to be extracted to an outside
application so the particular information about various projects the “let go person” was working on could be continued as previously planned.

So I decided to design a little utility that would extract the data from the user’s inbox, and input the messages into an Access table. Some of the code snippets I found online, and some I new from previous experience. You can put all the pieces together using common sense and logic.

You essentially can use this on any computer to read the inbox. This is because the machine you are running this from, should have a email account on the Microsoft Exchange Server.

Here’s the code. I start in “LoopInbox” by pressing F5


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
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
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
   
    'clean out the tables
    CurrentDb.Execute ("DELETE * FROM tblOutlook")
    CurrentDb.Execute ("DELETE * FROM tblOutlookAttachments")
   
    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")
   
    'start at the inbox folder
    Set olParentFolder = olNs.GetDefaultFolder(olFolderInbox)

    'process each folder in the inbox
    ProcessFolder olParentFolder
   
    MsgBox "Complete"
   
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 objAtt As Outlook.Attachment
    Dim strSaveFolder As String
   
    Dim strSQL As String
   
    Dim lngMainId As Long
    Dim rst As Recordset
    Dim strAttachSQL As String
   
    On Error Resume Next
   
    strSaveFolder = CurrentProject.Path
   
    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

            'PUT THE INBOX INFORMATION INTO AN ACCESS TABLE.
            strSQL = "INSERT INTO tblOutlook (out_Folder, out_Subject, out_ReceivedTime, out_SenderEmailAddress, out_Body) "
            strSQL = strSQL & " VALUES ('" & strMainFolder & "','" & strSubFolder & "','" & SQLFixup(olMail.Subject) & "',#" & olMail.ReceivedTime & "#,'" & olMail.SenderEmailAddress & "','" & SQLFixup(olMail.Body) & "')"
           
            CurrentDb.Execute strSQL
           
           
            'DO THIS IF THE EMAIL HAS ATTACHMENTS
            If olMail.Attachments.Count > 0 Then
                   
                'get the main id of the email, that way you can match the attachments to the correct email, since all the attachments will be in one folder.
               
                Set rst = CurrentDb.OpenRecordset("SELECT TOP 1 out_ID FROM tblOutlook ORDER BY out_ID DESC ")
                lngMainId = rst.Fields(0)
                                               
                'Stop
                             
                For Each objAtt In olMail.Attachments
                    'save the attachment to a file folder (I don't normally use the "Attachment" table datatype)
                    objAtt.SaveAsFile strSaveFolder & "" & objAtt.DisplayName
                   
                    'Insert the attachment data into a table.
                    strAttachSQL = "INSERT INTO tblOutlookAttachments (oa_MainID, oa_Name, oa_Path) "
                    strAttachSQL = strAttachSQL & " VALUES ('" & lngMainId & "','" & objAtt.DisplayName & "','" & strSaveFolder & "" & objAtt.DisplayName & "')"
                   
                    CurrentDb.Execute strAttachSQL
                                                       
                    Set objAtt = Nothing
                Next
            End If

            strSQL = vbNullString
            rst.Close
        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

'THESE ARE FUNCTIONS I USE TO CORRECT ANY SQL INSERT ISSUES
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

After this is complete, you can use a simple Access form to view your messages and attachments:

All the attachments are stored in a file folder:

Here are the structures of the 2 tables (“tblOutlook” and “tblOutlookAttachments”)

tblOutlook

tblOutlookAttachments

That’s all, let me know if you have any questions.


Need more help? Click here for another example.

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: , ,