Solved

Import Outlook 2007 emails with vba

Posted on 2014-02-27
3
1,106 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

Highfive + Dolby Voice = No More Audio Complaints!

Poor audio quality is one of the top reasons people don’t use video conferencing. Get the crispest, clearest audio powered by Dolby Voice in every meeting. Highfive and Dolby Voice deliver the best video conferencing and audio experience for every meeting and every room.

Join & Write a Comment

Suggested Solutions

ADCs have gained traction within the last decade, largely due to increased demand for legacy load balancing appliances to handle more advanced application delivery requirements and improve application performance.
This article explains in simple steps how to renew expiring Exchange Server Internal Transport Certificate.
The video tutorial explains the basics of the Exchange server Database Availability groups. The components of this video include: 1. Automatic Failover 2. Failover Clustering 3. Active Manager
With Microsoft Access, learn how to start a database in different ways and produce different start-up actions allowing you to use a single database to perform multiple tasks. Specify a start-up form through options: Specify an Autoexec macro: Us…

757 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

Need Help in Real-Time?

Connect with top rated Experts

22 Experts available now in Live!

Get 1:1 Help Now