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