Want to protect your cyber security and still get fast solutions? Ask a secure question today.Go Premium

x
?
Solved

Import Outlook 2007 emails with vba

Posted on 2014-02-27
3
Medium Priority
?
1,128 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 2000 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

Creating Active Directory Users from a Text File

If your organization has a need to mass-create AD user accounts, watch this video to see how its done without the need for scripting or other unnecessary complexities.

Question has a verified solution.

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

Beware when using the ListIndex and the Column() properties of a listbox in Access 2007.  A bug has been identified in the Access 2007 listbox code which can cause the .ListIndex property to return a -1, and the .Columns(#) property to return a NULL…
A Case Study of using the Windows API to provide RS232 communications capability in Access without the use of Active-X controls.
Add bar graphs to Access queries using Unicode block characters. Graphs appear on every record in the color you want. Give life to numbers. Hopes this gives you ideas on visualizing your data in new ways ~ Create a calculated field in a query: …
Whether it be Exchange Server Crash Issues, Dirty Shutdown Errors or Failed to mount error, Stellar Phoenix Mailbox Exchange Recovery has always got your back. With the help of its easy to understand user interface and 3 simple steps recovery proced…
Suggested Courses

564 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