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
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 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.
“Go Fund Me” Page
(…10% of your gift amount will go to charity)
Free! Subscribe To Our YouTube Channel!
