Solved

Import Outlook 2007 emails with vba

Posted on 2014-02-27
3
1,111 Views
Last Modified: 2014-08-06
I'm am trying to import the body of emails that are located in a specific folder in Outlook 2007

The email folder name is 2 Showtime

The access table I want to import them into is  Email

The name of the field the table  Remarks

My email is on an exchange server

In researching EE I found the code below and tried to tweak it for my purposes... but alas no luck.

Does the code need to be written differently since i am on an exchange server?



    Dim objOutlook As Object 'Outlook.Application
    Dim objNameSpace As Object 'Outlook.NameSpace
    Dim objMAPI As Object 'Outlook.MAPIFolder
    Dim objItems As Object 'Outlook.Items
    Dim objMailItem As Object
    Dim sSubject As String
    Dim sBody As String
    Dim i As Integer, j As Integer
    Dim lFolderID
    Dim rs As DAO.Recordset

   
    Set objOutlook = CreateObject("Outlook.Application") 'New Outlook.Application
    Set objNameSpace = objOutlook.GetNamespace("MAPI")          'Get to the current session of Outlook.



'Find out folder - assume its within Personal Folders and its called accept
    lFolderID = -1
    For i = 1 To objNameSpace.Folders.Count

        If InStr(1, objNameSpace.Folders(i).Name, "Personal Folder") > 0 Then
        MsgBox InStr(1, objNameSpace.Folders(i).Name, "Mailbox - Ashley Lowe")
            For j = 1 To objNameSpace.Folders.Item(i).Folders.Count

                If objNameSpace.Folders.Item(i).Folders.Item(j).Name = "2 Showtime" Then
               
                    lFolderID = objNameSpace.Folders.Item(i).Folders.Item(j).EntryID
                End If
            Next j
        End If
    Next i

    If lFolderID <> -1 Then
   
        Set objMAPI = objNameSpace.GetFolderFromID(lFolderID)
        Set objItems = objMAPI.Items
   
        If objItems.Count = 0 Then
            MsgBox "No mail items found"
           
        Else
       
            Set rs = CurrentDb.OpenRecordset("Email")

            For Each objMailItem In objItems
           
                sSubject = objMailItem.Subject
                sBody = objMailItem.Body
                Debug.Print sSubject

                'DO INSERT HERE
                With rs

                    !Remarks = sBody

                    .Update
                End With
               
            Next

            rs.Close
            Set rs = Nothing
        End If
    End If
0
Comment
Question by:Worcse
  • 2
3 Comments
 
LVL 76

Accepted Solution

by:
David Lee earned 500 total points
ID: 39894697
Hi, Worcse.

This code will do what you described.

'On the next line edit the path to the Outlook folder you want to export from
Const OUTLOOK_FOLDER_PATH = "Mailbox - Doe, John\Inbox"
'On the next line edit the path to the Access database you want to import to
Const ACCESS_FILE_PATH = "C:\Users\Worcse\Documents\Worcse.accdb"

Sub ImportToAccess()
    Dim adoCon As Object, olkFld As Outlook.MAPIFolder
    Set olkFld = OpenOutlookFolder(OUTLOOK_FOLDER_PATH)
    Set adoCon = CreateObject("ADODB.Connection")
    adoCon.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ACCESS_FILE_PATH & ";Persist Security Info=False;"
    For Each olkItm In olkFld.Items
        adoCon.Execute "INSERT INTO Email (Subject,Body) VALUES('" & Replace(olkItm.Subject, "'", "''") & "','" & Replace(olkItm.Body, "'", "''") & "')"
    Next
    adoCon.Close
    Set olkItm = Nothing
    Set olkFld = Nothing
    Set adoCon = Nothing
    MsgBox "Done"
End Sub

Private Function OpenOutlookFolder(strFolderPath As String) As Outlook.MAPIFolder
    ' Purpose: Opens an Outlook folder from a folder path.
    ' Written: 4/24/2009
    ' Author:  David Lee
    ' Outlook: All versions
    Dim arrFolders As Variant, _
        varFolder As Variant, _
        bolBeyondRoot As Boolean
    On Error Resume Next
    If strFolderPath = "" Then
        Set OpenOutlookFolder = Nothing
    Else
        Do While Left(strFolderPath, 1) = "\"
            strFolderPath = Right(strFolderPath, Len(strFolderPath) - 1)
        Loop
        arrFolders = Split(strFolderPath, "\")
        For Each varFolder In arrFolders
            Select Case bolBeyondRoot
                Case False
                    Set OpenOutlookFolder = Outlook.Session.Folders(varFolder)
                    bolBeyondRoot = True
                Case True
                    Set OpenOutlookFolder = OpenOutlookFolder.Folders(varFolder)
            End Select
            If Err.Number <> 0 Then
                Set OpenOutlookFolder = Nothing
                Exit For
            End If
        Next
    End If
    On Error GoTo 0
End Function

Open in new window

0
 

Author Closing Comment

by:Worcse
ID: 40244191
BlueDevilFan - thank you for the help...!!!
Worcse
0
 
LVL 76

Expert Comment

by:David Lee
ID: 40244270
You're welcome!
0

Featured Post

Best Practices: Disaster Recovery Testing

Besides backup, any IT division should have a disaster recovery plan. You will find a few tips below relating to the development of such a plan and to what issues one should pay special attention in the course of backup planning.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Phishing attempts can come in all forms, shapes and sizes. No matter how familiar you think you are with them, always remember to take extra precaution when opening an email with attachments or links.
A list of top three free exchange EDB viewers that helps the user to extract a mailbox from an unmounted .edb file and get a clear preview of all emails & other items with just a single click on mailboxes.
In Microsoft Access, learn different ways of passing a string value within a string argument. Also learn what a “Type Mis-match” error is about.
In Microsoft Access, learn the trick to repeating sub-report headings at the top of each page. The problem with sub-reports and headings: Add a dummy group to the sub report using the expression =1: Set the “Repeat Section” property of the dummy…

808 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question