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.
Free! Subscribe To Our YouTube Channel!
by 