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
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.
How To Parse A Flat File In Excel VBA
In another post I demonstrated how to access a file on your computer using the MS Office Library. Here it is if you don’t know what I’m talking about. In this post, I am going to show you how to access the file and load it into your spreadsheet. I will do the same thing […]
What is the purpose of the Me keyword in Access VBA?
What does the Me keyword mean? “Me” refers to the Access form currently in focus. Instead of writing out the entire form reference, you can just use the keyword “Me” which is easier. Like: Me.txtbox = “I am a textbox on the form that currently has the focus.” or you can update a label’s caption […]
How can I interact with other Office applications (Excel) using VBA in Access?
Need to write your Access data or query to an Excel file? Here is the how to do it: Most people are familiar with Excel and know how to use it well (enough), and when you start talking about Access, they get scared off, and don’t know what to do anymore. Well, here you are […]
How To Exit A VBA Loop
Hi, there are times when you need to exit a loop after a certain condition has been met. How do you exit function in VBA? In the following example, you are going to see how to exit a function in VBA: Sub StartNumbers() Dim intNumber As Integer intNumber = ExitTest ‘the number is going to […]