Import Outlook 2007 emails with vba

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
WorcseOwnerAsked:
Who is Participating?
 
David LeeCommented:
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
 
WorcseOwnerAuthor Commented:
BlueDevilFan - thank you for the help...!!!
Worcse
0
 
David LeeCommented:
You're welcome!
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.