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

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.

By the way, if you got or are getting value from the VBA information, please click the "Donate" button to give me a small token of your appreciation, thanks!