Import E-Mails from Outlook to Access, and read them from Access?

[Pirre001]

How do I import E-Mails from specified folder in Outlook to Access. I want to read the imported mails from Access also?
How do I do that?

[Pirre001]

Someone...?

[RobDog888]

Try a search first. This has been asked before.
Here is a thread I answered on this subject.
It will also show you how to connect to Outlook using ADO.
Modify the code to connect to the Inbox instead of the Contacts.

Outlook

[Pirre001]

Thanks RobDog888,

But how can I modify the code to connect to the Inbox instead of the Contacts? I have tried, without luck.

[RobDog888]

This should do it for you. I changed the code to use the Outlook
Object Model to read the emails and ADO to export them to
Access.
Add references to Microsoft ActiveX Data Objects 2.x Library
and Microsoft Outlook x.x Object Library

Public Function Outlook_Contacts_2_Access()
 
    On Error GoTo No_Bugs
 
    Dim CnnA As ADODB.Connection
    Dim goRs As ADODB.Recordset
    
    Dim oApp As Outlook.Application
    Dim oNS As Outlook.NameSpace
    Dim oInbox As Outlook.MAPIFolder
    Dim oEmail As Outlook.MailItem
 
    Dim i As Integer
    
    Set oApp = New Outlook.Application
    Set oNS = oApp.GetNamespace("MAPI")
    Set oInbox = oNS.GetDefaultFolder(olFolderInbox)
    
    Dim sSQL As String
    
    Set CnnA = New ADODB.Connection
    Set goRs = New ADODB.Recordset
    'YOU WILL NEED TO CREATE YOUR TABLE IN ACCESS TO MATCH AND CALL IT INBOX
    sSQL = "SELECT * FROM [Inbox] WHERE 1=2;"
    goRs.Open sSQL, CnnA, adOpenKeyset, adLockOptimistic, adCmdText
    
    frmMain.prbProgress.Max = oInbox.Items.Count
    i = 1
    Do While i <= oInbox.Items.Count
        Set oEmail = oInbox.Items(i)
        DoEvents
        goRs.AddNew
        goRs!To = oEmail.To
        goRs!CC = oEmail.CC
        goRs!BCC = oEmail.BCC
        goRs!Subject = oEmail.Subject
        goRs!Body = oEmail.Body           'PLAIN TEXT BODY NOTES OR
        goRs!HTMLBody = oEmail.HTMLBody   'HTML BODY NOTES (DEPENDS UPON THE EMAIL)
        goRs!Importance = oEmail.Importance
        goRs!Received = oEmail.ReceivedTime
        goRs!MessageClass = oEmail.MessageClass 'EMAIL, MEETING RESPONSE, MEETING REQUEST, ETC.
        goRs!ReceivedByName = oEmail.ReceivedByName
        'CONTINUE ON WITH OTHER FIELDS YOU WANT
        '...
        goRs.Update
        Set oEmail = Nothing
        frmMain.prbProgress.Value = i
        i = i + 1
    Loop
    Set oEmail = Nothing
    Set oInbox = Nothing
    Set oNS = Nothing
    goRs.Close
    Set CnnA = Nothing
    Set goRs = Nothing
    Exit Function
 
No_Bugs:
    
    MsgBox Err.Number & "-" & Err.Description, vbCritical, "Outlook Email Export"
'    Resume Next
 
End Function

[Pirre001]

Thanks again RobDog888!

It works to import now.
But I have two more questions for you, that I'm sure you have the answer to.

If I want to read the mails from Access, how can I do that in a good way?

If a mail have an attachment, how can I import that to access?

[RobDog888]

To answer your second question,

'UPDATED CODE...
Public Function Outlook_Contacts_2_Access()
'   <GORS = ACCESS>
    On Error GoTo No_Bugs
 
    Dim CnnA As ADODB.Connection
    Dim goRs As ADODB.Recordset
    
    Dim oApp As Outlook.Application
    Dim oNS As Outlook.NameSpace
    Dim oInbox As Outlook.MAPIFolder
    Dim oEmail As Outlook.MailItem
 
    Dim i As Integer
    Dim ii As Integer 'ADDED
    
    Dim sAttachment As String 'ADDED
    
    Set oApp = New Outlook.Application
    Set oNS = oApp.GetNamespace("MAPI")
    Set oInbox = oNS.GetDefaultFolder(olFolderInbox)
    
    Dim sSQL As String
    
    Set CnnA = New ADODB.Connection
    Set goRs = New ADODB.Recordset
    
    sSQL = "SELECT * FROM [Inbox] WHERE 1=2;"
    goRs.Open sSQL, CnnA, adOpenKeyset, adLockOptimistic, adCmdText
    
    frmMain.prbProgress.Max = oInbox.Items.Count
    i = 1
    Do While i <= oInbox.Items.Count
        Set oEmail = oInbox.Items(i)
        DoEvents
        goRs.AddNew
        goRs!To = oEmail.To
        goRs!CC = oEmail.CC
        goRs!BCC = oEmail.BCC
        goRs!Subject = oEmail.Subject
        goRs!Body = oEmail.Body           'PLAIN TEXT BODY NOTES
        goRs!HTMLBody = oEmail.HTMLBody   'HTML BODY NOTES
        goRs!Importance = oEmail.Importance
        goRs!Received = oEmail.ReceivedTime
        goRs!MessageClass = oEmail.MessageClass 'EMAIL, MEETING RESPONSE, MEETING REQUEST, ETC.
        goRs!ReceivedByName = oEmail.ReceivedByName
        'ADDED
        If oEmail.Attachments.Count > 1 Then
            'LOOP THROUGH ALL ATTACHMENTS SAVING TO DIRECTORY AND ENTERING FILENAME INTO FIELD
            For ii = 1 To oEmail.Attachments.Count
                oEmail.Attachments.Item(ii).SaveAsFile "C:\MyOutlookEmailExport\Attachments\" & oEmail.Attachments.Item(ii).FileName
                sAttachment = sAttachment & "C:\MyOutlookEmailExport\Attachments\" & oEmail.Attachments.Item(ii).FileName & vbNewLine
            Next
            goRs!Attachment = sAttachment
        Else
            goRs!Attachment = "None"
        End If
        '/ADDED
        'CONTINUE ON WITH OTHER FIELD YOU WANT
        '...
        goRs.Update
        Set oEmail = Nothing
        frmMain.prbProgress.Value = i
        i = i + 1
    Loop
    Set oEmail = Nothing
    Set oInbox = Nothing
    Set oNS = Nothing
    goRs.Close
    Set CnnA = Nothing
    Set goRs = Nothing
    Exit Function
 
No_Bugs:
    
    MsgBox Err.Number & "-" & Err.Description, vbCritical, "Outlook Email Export"
'    Resume Next
 
End Function

[RobDog888]

To answer your first question,

Easy way...
If you want to be able to just read the information, write a query
to bring up the email message you want and display the results
in a table view or report. Quick and easy although maybe ugly.

Hard way...
Shell out Outlook, creating an email and populating the Outlook
fields with the record data from Access. May create a duplicate if
the user saves the email.

Hardest and slowest way...
Create an instance of Outlook and "Find" the email message
based upon the Access info and "Display" it in an actual Outlook
enviroment.

[Pirre001]

RobDog888, you are my hero!

Now it almost works as I want. After I modified some rows, it became as I wanted.

If oEmail.Attachments.Count > 0 Then
        For ii = 1 To oEmail.Attachments.Count
                oEmail.Attachments.Item(ii).SaveAsFile "C:\MyOutlookEmailExport\Attachments\" & oEmail.Attachments.Item(ii).FileName
                sAttachment = C:\MyOutlookEmailExport\Attachments\" & oEmail.Attachments.Item(ii).FileName & vbNewLine
            Next
            goRs!Attachment = sAttachment
        Else
            goRs!Attachment = "None"
        End If

Some final questions...

If I run same function it dublicate the rows in the table. Can I make it add only new messages from the specified folder in the table?

If I want to create an instance of Outlook and "Find" the email message based upon the Access info and "Display" it in an actual Outlook enviroment, do you have any example on that also?

[RobDog888]

The line of code...

sAttachment = sAttachment & "C:\MyOutlookEmailExport\Attachments\" & oEmail.Attachments.Item(ii).FileName & vbNewLine

Needs to be put back because with the way you
changed it if you have more than one attachment it will only
retain the last one.

You can have it add only new messages you will need to filter out the messages by .EntryID property.
To start...

goRs!EntryID = oEmail.EntryID

This is a unique 140 alpha-numeric string identifing the email in Outlook.
Then you will need to perform a query on the Access db the next
time you export to check for a matching .EntryID. If found, then
skip. If not found then add it to the table.

Hold on for a sample for the Find in Outlook.

[RobDog888]

Here is a working example for your first question. I had to make
some changes so I posted the entire code so it will be easier to
see where the changes are.

Option Explicit
'MODULAR DECLARATIONS
Private oApp As Outlook.Application
Private oNS As Outlook.NameSpace
Private oInbox As Outlook.MAPIFolder
Private CnnA As ADODB.Connection
 
Private Sub Form_Load()
    'MOVED INITIALIZATION OF OUTLOOK AND CONNECTION TO 
    'ACCESS SO IT WILL BE AVAILABLE TO THE NEW FUNCTION 
    'WITHOUT HAVING TO RECREATE IT.
    Set oApp = New Outlook.Application
    Set oNS = oApp.GetNamespace("MAPI")
    Set oInbox = oNS.GetDefaultFolder(olFolderInbox)
    
    Set CnnA = New ADODB.Connection
    CnnA.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & frmMain.txtDBPath & ";Persist Security Info=False"
    CnnA.Open
    
End Sub
 
Private Function Outlook_Contacts_2_Access()
'   <GORS = ACCESS>
    On Error GoTo No_Bugs
 
    Dim goRs As ADODB.Recordset
    Dim oEmail As Outlook.MailItem
 
    Dim i As Integer
    Dim ii As Integer
    
    Dim sAttachment As String
    
    Dim sSQL As String
    
    Set goRs = New ADODB.Recordset
    
    sSQL = "SELECT * FROM [Inbox] WHERE 1=2;"
    goRs.Open sSQL, CnnA, adOpenKeyset, adLockOptimistic, adCmdText
    
    frmMain.prbProgress.Max = oInbox.Items.Count
    i = 1
    Do While i <= oInbox.Items.Count
        Set oEmail = oInbox.Items(i)
        DoEvents
        'TEST FOR EMAIL IN ACCESS
        If FindOutlookEmail(oEmail.EntryID) = False Then
            goRs.AddNew
            goRs!To = oEmail.To
            goRs!CC = oEmail.CC
            goRs!BCC = oEmail.BCC
            goRs!Subject = oEmail.Subject
            goRs!Body = oEmail.Body           'PLAIN TEXT BODY NOTES
            goRs!HTMLBody = oEmail.HTMLBody   'HTML BODY NOTES
            goRs!Importance = oEmail.Importance
            goRs!Received = oEmail.ReceivedTime
            goRs!MessageClass = oEmail.MessageClass 'EMAIL, MEETING RESPONSE, MEETING REQUEST, ETC.
            goRs!ReceivedByName = oEmail.ReceivedByName
            If oEmail.Attachments.Count > 1 Then
                'LOOP THROUGH ALL ATTACHMENTS SAVING TO DIRECTORY AND ENTERING FILENAME INTO FIELD
                For ii = 1 To oEmail.Attachments.Count
                    oEmail.Attachments.Item(ii).SaveAsFile "C:\MyOutlookEmailExport\Attachments\" & oEmail.Attachments.Item(ii).FileName
                    sAttachment = sAttachment & "C:\MyOutlookEmailExport\Attachments\" & oEmail.Attachments.Item(ii).FileName & vbNewLine
                Next
                goRs!Attachment = sAttachment
            Else
                goRs!Attachment = "None"
            End If
            'CONTINUE ON WITH OTHER FIELD YOU WANT
            '...
            goRs.Update
        End If
        Set oEmail = Nothing
        frmMain.prbProgress.Value = i
        i = i + 1
    Loop
    Set oEmail = Nothing
    Set oInbox = Nothing
    Set oNS = Nothing
    goRs.Close
    Set CnnA = Nothing
    Set goRs = Nothing
    Exit Function
 
No_Bugs:
    
    MsgBox Err.Number & "-" & Err.Description, vbCritical, "Outlook Email Export"
'    Resume Next
 
End Function
 
Private Function FindOutlookEmail(ByVal oEmailEntryID As String) As Boolean
 
    Dim oRsAccessEmail As ADODB.Recordset 'EMAIL IN ACCESS TO CHECK AGAINST
    
    Dim i As Integer
    
    Set oRsAccessEmail = New ADODB.Recordset
    oRsAccessEmail.Open "SELECT EntryID FROM Inbox WHERE EntryID = '" & oEmailEntryID & "';", CnnA, adOpenKeyset, adLockReadOnly, adCmdText
    If oRsAccessEmail.BOF = True And oRsAccessEmail.EOF = True Then
        FindOutlookEmail = False
    Else
        FindOutlookEmail = True
    End If
    Set oRsAccessEmail = Nothing
 
End Function

Although this will only add new emails, it
will not catch any changes to emails theat already have been
exported.

[RobDog888]

Answer to second question...

Private Function OpenOutlookEmail(ByVal oEmailEnrtyID As String)
    
    Dim oDisplayEmail As Outlook.MailItem
    
    Set oDisplayEmail = oInbox.Items.Find("[EntryID] = '" & oEmailEntryID & "'")
    If TypeName(oDisplayEmail) <> "Nothing" Then
        oDisplayEmail.Display 'THE USE CAN MAKE CHANGES AND SAVE THEM TO OUTLOOK
    Else
        MsgBox "Email not found in Outlook!", vbOKOnly + vbExclamation
    End If
 
End Function

[Pirre001]

This is like a dream, everything works!

But I get a little error on function OpenOutlookEmail. Error 91...Do you know why?

If this is a public database, everybody can't read the mail with function OpenOutlookEmail then, or am I wrong?

[RobDog888]

Step throught the code by pressing F8 to execute each line of
code and see exactly where you are getting the error.

If the database is a public database then each use will not be
able to "Display" in Outlook the email messages that are not in
their own "Inbox in Outlook". Its Outlook security.

One way around this may be to export the emails to Access and
create a duplicate email message in Outlook in a shared
or "Public Inbox". Then every use will be able to view the email
messages from everyone.

[RobDog888]

The only possibility I can see if the oInbox object may not be set.
Although this is being set at the Form_Load event.

Be back in 30 mins. Going to lunch.

[Pirre001]

Hi again RobDog888,

I have a little problem when the mail is a MEETING RESPONSE type. I get error: Type mismatch. Error 13.

And it stops on row:
Set oEmail = oInbox.Items(i)

And then if the mail has a picture in it self, I get error:
Outlook cannot do this action on this type of attachment.

Here I want to import the mail, but I want to skip the picture that is inside the mail. The mailtype is Rich Text.

Can you still help me?

[binduau]

Awesome!!




bindu

[RobDog888]

Thanks, binduau.

Pirre001,
I am working on a solution for the attachments right now.
You only want to save the attachments that are of olByValue type, correct?

The types are as follows...
olByReference = linked attachment.
olByValue = file attachment.
olEmbeddeditem = something like a picture embedded in the body notes.
olOLE = the type like if you were to view a Journal entry.

The 91 error is fixed.

I will post it in a few.

[RobDog888]

This is what I have. I created three objects to handel Email messages, Meeting Items, and Distribution List Items.

These are the three most common types of Outlook Items in the Inbox.
If the Outlook Inbox item is not of these three types then it will
skip it.It may be a task or some other item.

Option Explicit
 
Private oApp As Outlook.Application
Private oNS As Outlook.NameSpace
Private oInbox As Outlook.MAPIFolder
Private CnnA As ADODB.Connection
 
Private Sub cmdExportEmails_Click()
 
    Call Outlook_Emails_2_Access
 
End Sub
 
Private Sub Form_Load()
 
    Set oApp = New Outlook.Application
    Set oNS = oApp.GetNamespace("MAPI")
    Set oInbox = oNS.GetDefaultFolder(olFolderInbox)
    
    Set CnnA = New ADODB.Connection
    CnnA.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & txtDBPath & ";Persist Security Info=False"
    CnnA.Open
    
End Sub
 
Private Function Outlook_Emails_2_Access()
'   <GORS = ACCESS>
    On Error GoTo No_Bugs
 
    Dim goRs As ADODB.Recordset
    
    Dim oEmail As Outlook.MailItem
    Dim oMeetingType As Outlook.MeetingItem
    Dim oDistributionList As Outlook.DistListItem
    
    Dim vType As Variant
    
    Dim i As Integer
    Dim ii As Integer
    
    Dim sAttachment As String
    
    Dim sSQL As String
    
    Set goRs = New ADODB.Recordset
    
    sSQL = "SELECT * FROM [Inbox] WHERE 1=2;"
    goRs.Open sSQL, CnnA, adOpenKeyset, adLockOptimistic, adCmdText
    
    prbProgress.Max = oInbox.Items.Count
    i = 1
    Do While i <= oInbox.Items.Count
        DoEvents
        Select Case oInbox.Items(i).Class
            Case olMail
                vType = "Email"
            Case olMeetingRequest
                vType = "MeetingItem"
            Case olMeetingResponseNegative
                vType = "MeetingItem"
            Case olMeetingResponsePositive
                vType = "MeetingItem"
            Case olMeetingResponseTentative
                vType = "MeetingItem"
            Case olDistributionList
                vType = "DistListItem"
        End Select
        If vType = "Email" Then 'ONLY EMAIL TYPES
            Set oEmail = oInbox.Items(i)
            If FindOutlookEmail(oEmail.EntryID) = False Then
                goRs.AddNew
                goRs!To = oEmail.To
                goRs!CC = oEmail.CC
                goRs!BCC = oEmail.BCC
                goRs!Subject = oEmail.Subject
                goRs!Body = oEmail.Body           'PLAIN TEXT BODY NOTES
                goRs!HTMLBody = oEmail.HTMLBody   'HTML BODY NOTES
                goRs!Importance = oEmail.Importance
                goRs!Received = oEmail.ReceivedTime
                goRs!Class = oEmail.Class 'EMAIL, MEETING RESPONSE, MEETING REQUEST, DIST. LIST, ETC.
                goRs!ReceivedByName = oEmail.ReceivedByName
                If oEmail.Attachments.Count > 1 Then
                    'LOOP THROUGH ALL ATTACHMENTS SAVING TO DIRECTORY AND ENTERING FILENAME INTO FIELD
                    For ii = 1 To oEmail.Attachments.Count
                        'DETERMINE ATTACHMENT CLASS TYPE ATTACHED, LINKED, EMBEDDED, OR OLE
                        If oEmail.Attachments.Item(ii).Type = olByValue Then
                            oEmail.Attachments.Item(ii).SaveAsFile "C:\MyOutlookEmailExport\Attachments\" & oEmail.Attachments.Item(ii).FileName
                            sAttachment = sAttachment & "C:\MyOutlookEmailExport\Attachments\" & oEmail.Attachments.Item(ii).FileName & vbNewLine
                        End If
                    Next
                    goRs!Attachment = sAttachment
                Else
                    goRs!Attachment = "None"
                End If
                'CONTINUE ON WITH OTHER FIELD YOU WANT
                '...
                goRs.Update
            End If
            Set oEmail = Nothing
        ElseIf vType = "MeetingItem" Then
            Set oMeetingType = oInbox.Items(i)
            If FindOutlookEmail(oMeetingType.EntryID) = False Then
                goRs.AddNew
                goRs!To = oMeetingType.Recipients.Item(1).Name
                goRs!CC = IIf(oMeetingType.Recipients.Count > 1, oMeetingType.Recipients.Item(2).Name, "")
                goRs!BCC = ""
                goRs!Subject = oMeetingType.Subject
                goRs!Body = oMeetingType.Body           'PLAIN TEXT BODY NOTES
                goRs!HTMLBody = ""
                goRs!Importance = oMeetingType.Importance
                goRs!Received = oMeetingType.ReceivedTime
                goRs!Class = oMeetingType.Class 'EMAIL, MEETING RESPONSE, MEETING REQUEST, DIST. LIST, ETC.
                goRs!ReceivedByName = ""
                If oMeetingType.Attachments.Count > 1 Then
                    'LOOP THROUGH ALL ATTACHMENTS SAVING TO DIRECTORY AND ENTERING FILENAME INTO FIELD
                    For ii = 1 To oMeetingType.Attachments.Count
                        'DETERMINE ATTACHMENT CLASS TYPE ATTACHED, LINKED, EMBEDDED, OR OLE
                        If oMeetingType.Attachments.Item(ii).Type = olByValue Then
                            oMeetingType.Attachments.Item(ii).SaveAsFile "C:\MyOutlookEmailExport\Attachments\" & oMeetingType.Attachments.Item(ii).FileName
                            sAttachment = sAttachment & "C:\MyOutlookEmailExport\Attachments\" & oMeetingType.Attachments.Item(ii).FileName & vbNewLine
                        End If
                    Next
                    goRs!Attachment = sAttachment
                Else
                    goRs!Attachment = "None"
                End If
                'CONTINUE ON WITH OTHER FIELD YOU WANT
                '...
                goRs.Update
            End If
            Set oMeetingType = Nothing
        ElseIf vType = "DistListItem" Then
            Set oDistributionList = oInbox.Items(i)
            If FindOutlookEmail(oDistributionList.EntryID) = False Then
                goRs.AddNew
                goRs!To = oDistributionList.DLName
                goRs!CC = oDistributionList.MemberCount & "-Members"
                goRs!BCC = ""
                goRs!Subject = oDistributionList.Subject
                goRs!Body = oDistributionList.Body           'PLAIN TEXT BODY NOTES
                goRs!HTMLBody = ""
                goRs!Importance = oDistributionList.Importance
                goRs!Received = ""
                goRs!Class = oDistributionList.Class 'EMAIL, MEETING RESPONSE, MEETING REQUEST, DIST. LIST, ETC.
                goRs!ReceivedByName = ""
                If oDistributionList.Attachments.Count > 1 Then
                    'LOOP THROUGH ALL ATTACHMENTS SAVING TO DIRECTORY AND ENTERING FILENAME INTO FIELD
                    For ii = 1 To oDistributionList.Attachments.Count
                        'DETERMINE ATTACHMENT CLASS TYPE ATTACHED, LINKED, EMBEDDED, OR OLE
                        If oDistributionList.Attachments.Item(ii).Type = olByValue Then
                            oDistributionList.Attachments.Item(ii).SaveAsFile "C:\MyOutlookEmailExport\Attachments\" & oDistributionList.Attachments.Item(ii).FileName
                            sAttachment = sAttachment & "C:\MyOutlookEmailExport\Attachments\" & oDistributionList.Attachments.Item(ii).FileName & vbNewLine
                        End If
                    Next
                    goRs!Attachment = sAttachment
                Else
                    goRs!Attachment = "None"
                End If
                'CONTINUE ON WITH OTHER FIELD YOU WANT
                '...
                goRs.Update
            End If
            Set oDistributionList = Nothing
        Else
            MsgBox "Unsupported message type!", vbOKOnly + vbExclamation
        End If
        Set oEmail = Nothing
        prbProgress.Value = i
        i = i + 1
    Loop
    
    Set oInbox = Nothing
    Set oNS = Nothing
    goRs.Close
    Set CnnA = Nothing
    Set goRs = Nothing
    Exit Function
 
No_Bugs:
    
    MsgBox Err.Number & "-" & Err.Description, vbCritical, "Outlook Email Export"
'    Resume Next
 
End Function
 
Private Function FindOutlookEmail(ByVal oEmailEntryID As String) As Boolean
 
    Dim oRsAccessEmail As ADODB.Recordset 'EMAIL IN ACCESS TO CHECK AGAINST
    
    Dim i As Integer
    
    Set oRsAccessEmail = New ADODB.Recordset
    oRsAccessEmail.Open "SELECT EntryID FROM Inbox WHERE EntryID = '" & oEmailEntryID & "';", CnnA, adOpenKeyset, adLockReadOnly, adCmdText
    If oRsAccessEmail.BOF = True And oRsAccessEmail.EOF = True Then
        FindOutlookEmail = False
    Else
        FindOutlookEmail = True
    End If
    Set oRsAccessEmail = Nothing
 
End Function
 
Private Function OpenOutlookEmail(ByVal oEmailEnrtyID As String)
    
    Dim oDisplayEmail As Outlook.MailItem
    
    Set oDisplayEmail = oInbox.Items.Find("[EntryID] = '" & oEmailEntryID & "'")
    If TypeName(oDisplayEmail) <> "Nothing" Then
        oDisplayEmail.Display 'THE USE CAN MAKE CHANGES AND SAVE THEM TO OUTLOOK
    Else
        MsgBox "Email not found in Outlook!", vbOKOnly + vbExclamation
    End If
 
End Function

This should get you just about there.
I wasn't able to test the dist. list. I didn't have the time.
Please note: there are changes throughout the code.
Need to get back to billable work.
Let me know how it goes.

Later, and enjoy.

[Pirre001]

Jesus RobDog888!!

What should I do without you?

Big Thanks!

That solve my problems...

But I have two more questions, and belive me, thats my last questions...

If I only want to save the attachments that are olByValue and olEmbeddeditem type, how do I do that?

And if I in a easy want to change folder where I import the mail from, how do I do that?
Now we use the default folder.

[RobDog888]

To change the import folder location:

Private Sub Form_Load()
 
    Set oApp = New Outlook.Application
    Set oNS = oApp.GetNamespace("MAPI")
    'Set oInbox = oNS.GetDefaultFolder(olFolderInbox)
    'MUST BE A FOLDER WITH A DEFAULT MESSAGE TYPE OF POST!!!
    'RIGHT CLICK ON THE DESIRED NEW FOLDER AND CLICK PROPERTIES.
    'THEN LOOK AT THE BOTTON AND IT SHOULD SAY -
    '"WHEN POSTING TO THIS FOLDER, USE: POST"
    Set oInbox = oNS.Folders("[color=red]Your Custom Folder Name Here![/color]")
    
    Set CnnA = New ADODB.Connection
    CnnA.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & txtDBPath & ";Persist Security Info=False"
    CnnA.Open
    
End Sub

[RobDog888]

Your welcome.

If I only want to save the attachments that are olByValue and olEmbeddeditem type, how do I do that?

The way the code is now, it only saves Attachments that are file attachments.
To enable it to save Embedded items is a bit more difficult.
Let me test something out and I will get back to you, but this is
how to filter both types.

'THIS IS A SAMPLE FROM THE IMPORT CODE
'LOOP THROUGH ALL ATTACHMENTS SAVING TO DIRECTORY AND ENTERING FILENAME INTO FIELD
For ii = 1 To oEmail.Attachments.Count
    'DETERMINE ATTACHMENT CLASS TYPE ATTACHED, LINKED, EMBEDDED, OR OLE
    If oEmail.Attachments.Item(ii).Type = olByValue Then
        oEmail.Attachments.Item(ii).SaveAsFile "C:\MyOutlookEmailExport\Attachments\" & oEmail.Attachments.Item(ii).FileName
        sAttachment = sAttachment & "C:\MyOutlookEmailExport\Attachments\" & oEmail.Attachments.Item(ii).FileName & vbNewLine
    ElseIf oEmail.Attachments.Item(ii).Type = olEmbeddeditem Then
        'CODE WILL GO HERE
 
    End If
Next

[Pirre001]

When I'm use:
Set oInbox = oNS.Folders("MyFolder")
I get error: The measure failed. ??
And I use "POST" rule for this folder.


I'm waiting with tension for the "Save Embedded items" solution...

[RobDog888]

I'm sorry, I forgot to tell you that you need to drill down the
folder path to the target folder.

Set oApp = New Outlook.Application
Set oNS = oApp.GetNamespace("MAPI")
Set oPF = oNS.Folders("Public Folders")
Set oAPF = oPF.Folders("All Public Folders")
Set oInbox = oAPF.Folders("Public Emails")

Also dont forget to Dim the objects also.
Same as the oInbox.

[RobDog888]

Here is the modified code snip for saving both types of
attachments that you wanted.

If oEmail.Attachments.Count > 1 Then
    'LOOP THROUGH ALL ATTACHMENTS SAVING TO DIRECTORY AND ENTERING FILENAME INTO FIELD
    For ii = 1 To oEmail.Attachments.Count
        'DETERMINE ATTACHMENT CLASS TYPE ATTACHED, LINKED, EMBEDDED, OR OLE
        If oEmail.Attachments.Item(ii).Type = olByValue Or oEmail.Attachments.Item(ii).Type = olEmbeddeditem Then
            oEmail.Attachments.Item(ii).SaveAsFile "C:\MyOutlookEmailExport\Attachments\" & oEmail.Attachments.Item(ii).FileName
            sAttachment = sAttachment & "C:\MyOutlookEmailExport\Attachments\" & oEmail.Attachments.Item(ii).FileName & vbNewLine
        End If
    Next
    goRs!Attachment = sAttachment
Else
    goRs!Attachment = "None"
End If

It turned out that it works the same for either type.

[binduau]

HI RobDog

I don't suppose you know how to open an outlook folder and view it... i tried this with no success

strFileName = "Outlook.exe /select outlook:Orders"
Shell strFileName, vbNormalFocus

This works....

strFileName = "c:\msoffice2k\office\Outlook.exe /select outlook:Orders"
   Shell strFileName, vbNormalFocus

but ...


this >> "Outlook.exe /select outlook:Orders <<<< works in the
windows run dialog but i can't get it to run from shell..

but ....

what if a user puts outlook or office in a different place upon install... .... such as d:\blah... instead of C:\program files\blah


i could get the default root install folder from the registry of office
but i dunno how........

this is where it is...

HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Office\8.0\Common\InstallRootSR1

I know how to use getsettings....

DefEmailTemplate = GetSetting("EmailOrderProcessor", "EmailAddresses", _
"DefaultEmailTemplateFolder", App.path & "\defaulttpl.tpl")

but how do i configure that for the keys of ....

HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Office\8.0\Common\InstallRootSR1

with respect


bindu

[RobDog888]

In order to read a reqistry key that is not in the VB and VBA
Program Settings key (GetSetting and SaveSetting location) you
need to use the APIs for reading the registry.
Try searching for RegOpenKey.

The shelling issue you say works from the run dialog box, but not
from the shell function?
What is the actual location of the Order folder in Outlook?
Is it a top level folder or is it nested down some path?

PS. this should really be a new thread.

[Pirre001]

Fantastic RobDog888!!!

Everything gets better and better..;-)

If the mails empty (no text inside) I get error.

And I still get error 91 when I use function OpenOutlookEmail?

[RobDog888]

When you say that "If the mails empty..." do you mean that the
Outlook email body is empty or the folder is empty?

I found part of the problem with the function - OpenOutlookEmail.
The passed variable declaration is spelled wrong (my dyslexia!).

Private Function OpenOutlookEmail(ByVal [color=red]oEmailEntryID[/color] As String)
    
    Dim oDisplayEmail As Outlook.MailItem
    
    Set oDisplayEmail = oInbox.Items.Find("[EntryID] = '" & oEmailEntryID & "'")
    If TypeName(oDisplayEmail) <> "Nothing" Then
        oDisplayEmail.Display 'THE USE CAN MAKE CHANGES AND SAVE THEM TO OUTLOOK
    Else
        MsgBox "Email not found in Outlook!", vbOKOnly + vbExclamation
    End If
 
End Function

Give me a minute and I will figure it out.

[Pirre001]

Yepp, I mean that Outlook email body is empty.

I have also seen that you spelled wrong there..
But the error is still there?

[RobDog888]

I think you may have the field (Body and HTMLBody) definitions
defined to not allow nulls or zero length strings.

Here are the other fixes.

'...
    '...
    If FindOutlookEmail(oEmail.EntryID) = False Then
        'ADDED FOR TESTING ONLY SO YOU CAN SEE HOW TO PASS THE ITEMS.
        'TAKE OUT AND PLACE WHERE YOU ARE CALLING IT FROM
        'OTHERWISE IT WILL OPEN ALL EXPORTED EMAILS
        Call OpenOutlookEmail(oEmail.EntryID, CStr(oInbox.Items(i).Class))
        goRs.AddNew
        '...
        '...
        '...
End Sub
 
'...
'...
 
Private Function OpenOutlookEmail(ByVal oEmailEntryID As String, sType As String)
'PASS THE .ENTRYID AND THE .TYPE PROPERTY OF THE OUTLOOK ITEM
    On Error GoTo No_Bugs
    
    Dim oDisplayEmail As Outlook.MailItem
    Dim oDisplayMeetingItem As Outlook.MeetingItem
    Dim oDistListItem As Outlook.DistListItem
    Dim oItem As Object
    Dim i As Integer
    Dim bFound As Boolean
    
    'CHECK EACH ITEMS ENTRYID PROPERTY FOR A MATCH (.FIND NOT COMPATIBLE WITH .ENTRYID PROPERTY)
    bFound = False
    For i = 1 To oInbox.Items.Count
        Set oItem = oInbox.Items(i)
        If oItem.EntryID = oEmailEntryID Then
            bFound = True
            Exit For
        Else
            bFound = False
        End If
        Set oItem = Nothing
    Next
    
    If bFound = True Then
        Select Case CLng(sType)
            Case olMail
                sType = "Email"
            Case olMeetingRequest, olMeetingResponseNegative, olMeetingResponsePositive, olMeetingResponseTentative
                sType = "MeetingItem"
            Case olDistributionList
                sType = "DistListItem"
            Case Else
                sType = ""
        End Select
        Select Case sType
            Case "Email"
                Set oDisplayEmail = oInbox.Items(i)
                If TypeName(oDisplayEmail) <> "Nothing" Then
                    oDisplayEmail.Display 'THE USE CAN MAKE CHANGES AND SAVE THEM TO OUTLOOK
                Else
                    MsgBox "Email not found in Outlook!", vbOKOnly + vbExclamation
                End If
            Case "MeetingItem"
                Set oDisplayMeetingItem = oInbox.Items(i)
                If TypeName(oDisplayMeetingItem) <> "Nothing" Then
                    oDisplayMeetingItem.Display 'THE USE CAN MAKE CHANGES AND SAVE THEM TO OUTLOOK
                Else
                    MsgBox "Meeting Item not found in Outlook!", vbOKOnly + vbExclamation
                End If
            Case "DistListItem"
                Set oDistListItem = oInbox.Items(i)
                If TypeName(oDistListItem) <> "Nothing" Then
                    oDistListItem.Display 'THE USE CAN MAKE CHANGES AND SAVE THEM TO OUTLOOK
                Else
                    MsgBox "Distribution List not found in Outlook!", vbOKOnly + vbExclamation
                End If
            Case Else
                MsgBox "Invalid Outlook Item Type Passed!", vbOKOnly + vbCritical
        End Select
    Else
        MsgBox "Item not found in Outlook!", vbOKOnly + vbInformation
    End If
    Exit Function
    
No_Bugs:
 
    MsgBox Err.Number & " = " & Err.Description, vbOKOnly + vbExclamation
    Exit Function
    Resume
End Function

[binduau]

I cracked it anywhooo

thanks


bindu

[RobDog888]

binduau, what was the solution?

[Pirre001]

RobDog888, I'm so satisfied now!!

Thanks for your help!

Guess what....I have a last question...

If I want to import from the task folder, how do I do then?

Now it's working to open and read a mail, is it possible to decrease that code a little?

[RobDog888]

I guess we could use late binding and have the function reduced that way.
Short partial sample of OpenOutlookEmail function.

Dim oObject as Object 'INSTEAD OF
'Dim oDisplayEmail As Outlook.MailItem
'Dim oDisplayMeetingItem As Outlook.MeetingItem
'Dim oDistListItem As Outlook.DistListItem
 
'THEN INSTEAD OF THREE BRANCHES OF CODE TO HANDEL EACH 
'ONE YOU CAN HAVE JUST ONE
 
Set oObject = oInbox.Items(i)
If TypeName(oObject) <> "Nothing" Then
    oObject.Display 'THE USE CAN MAKE CHANGES AND SAVE THEM TO OUTLOOK
Else
    MsgBox "Email not found in Outlook!", vbOKOnly + vbExclamation
End If

[RobDog888]

To change the code to use the Task folder.
Then you will need to write similar function to export the tasks to
a Tasks table.

Option Explicit
 
Private oApp As Outlook.Application
Private oNS As Outlook.NameSpace
Private oInbox As Outlook.MAPIFolder
Private oTasks As Outlook.MAPIFolder
Private CnnA As ADODB.Connection
 
Private Sub cmdExportEmails_Click()
 
    Call Outlook_Emails_2_Access
 
End Sub
 
Private Sub Form_Load()
 
    Set oApp = New Outlook.Application
    Set oNS = oApp.GetNamespace("MAPI")
    Set oInbox = oNS.GetDefaultFolder(olFolderInbox)
    Set oTasks = oNS.GetDefaultFolder(olFolderTasks)
    'MUST BE A FOLDER WITH A DEFAULT MESSAGE TYPE OF POST!!!
    'RIGHT CLICK ON THE DESIRED NEW FOLDER AND CLICK PROPERTIES.
    'THEN LOOK AT THE BOTTON AND IT SHOULD SAY -
    '"WHEN POSTING TO THIS FOLDER, USE: POST"
'    Set oInbox = oNS.Folders("Your Custom Folder Name Here!")
    
    Set CnnA = New ADODB.Connection
    CnnA.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & txtDBPath & ";Persist Security Info=False"
    CnnA.Open
    
End Sub

Glad to help.
How about a honorable mention in your programs about credits?

[Pirre001]

I will certainly make honorable mention about you in my programs.
I need your e-mail and name to do that. I can't just write RobDog888 as your name...

I have tried the task code you showed me, but I can't write a working function to export the tasks to a Tasks table. Can you show me a complete way to do this?

[RobDog888]

First third of program that I have.

Option Explicit
 
Private oApp As Outlook.Application
Private oNS As Outlook.NameSpace
Private oInbox As Outlook.MAPIFolder
Private oTasks As Outlook.MAPIFolder
Private CnnA As ADODB.Connection
 
Private Sub cmdExportEmails_Click()
 
    Call Outlook_Emails_2_Access
 
End Sub
 
Private Sub Form_Load()
 
    Set oApp = New Outlook.Application
    Set oNS = oApp.GetNamespace("MAPI")
    Set oInbox = oNS.GetDefaultFolder(olFolderInbox)
    Set oTasks = oNS.GetDefaultFolder(olFolderTasks)
    'MUST BE A FOLDER WITH A DEFAULT MESSAGE TYPE OF POST!!!
    'RIGHT CLICK ON THE DESIRED NEW FOLDER AND CLICK PROPERTIES.
    'THEN LOOK AT THE BOTTON AND IT SHOULD SAY -
    '"WHEN POSTING TO THIS FOLDER, USE: POST"
'    Set oInbox = oNS.Folders("Your Custom Folder Name Here!")
    
    Set CnnA = New ADODB.Connection
    CnnA.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & txtDBPath & ";Persist Security Info=False"
    CnnA.Open
    
End Sub
 
Private Function Outlook_Emails_2_Access()
'   <GORS = ACCESS>
    On Error GoTo No_Bugs
 
    Dim goRs As ADODB.Recordset
    
    Dim oEmail As Outlook.MailItem
    Dim oMeetingType As Outlook.MeetingItem
    Dim oDistributionList As Outlook.DistListItem
    
    Dim vType As Variant
    
    Dim i As Integer
    Dim ii As Integer
    
    Dim sAttachment As String
    
    Dim sSQL As String
    
    Set goRs = New ADODB.Recordset
    
    sSQL = "SELECT * FROM [Inbox] WHERE 1=2;"
    goRs.Open sSQL, CnnA, adOpenKeyset, adLockOptimistic, adCmdText
    
    prbProgress.Max = oInbox.Items.Count
    i = 1
    Do While i <= oInbox.Items.Count
        DoEvents
        Select Case oInbox.Items(i).Class
            Case olMail
                vType = "Email"
            Case olMeetingRequest
                vType = "MeetingItem"
            Case olMeetingResponseNegative
                vType = "MeetingItem"
            Case olMeetingResponsePositive
                vType = "MeetingItem"
            Case olMeetingResponseTentative
                vType = "MeetingItem"
            Case olDistributionList
                vType = "DistListItem"
        End Select
        If vType = "Email" Then 'ONLY EMAIL TYPES
            Set oEmail = oInbox.Items(i)
            If FindOutlookEmail(oEmail.EntryID) = False Then
                'ADDED FOR TESTING ONLY SO YOU CAN SEE HOW TO PASS THE ITEMS.
                'TAKE OUT AND PLACE WHERE YOU ARE CALLING IT FROM
                'OTHERWISE IT WILL OPEN ALL EXPORTED EMAILS
                Call OpenOutlookEmail(oEmail.EntryID, CStr(oInbox.Items(i).Class))
                goRs.AddNew
                goRs!To = oEmail.To
                goRs!CC = oEmail.CC
                goRs!BCC = oEmail.BCC
                goRs!Subject = oEmail.Subject
                goRs!Body = oEmail.Body           'PLAIN TEXT BODY NOTES
                goRs!HTMLBody = oEmail.HTMLBody   'HTML BODY NOTES
                goRs!Importance = oEmail.Importance
                goRs!Received = oEmail.ReceivedTime
                goRs!Class = oEmail.Class 'EMAIL, MEETING RESPONSE, MEETING REQUEST, DIST. LIST, ETC.
                goRs!ReceivedByName = oEmail.ReceivedByName
                goRs!EntryID = oEmail.EntryID
                If oEmail.Attachments.Count > 1 Then
                    'LOOP THROUGH ALL ATTACHMENTS SAVING TO DIRECTORY AND ENTERING FILENAME INTO FIELD
                    For ii = 1 To oEmail.Attachments.Count
                        'DETERMINE ATTACHMENT CLASS TYPE ATTACHED, LINKED, EMBEDDED, OR OLE
                        If oEmail.Attachments.Item(ii).Type = olByValue Or oEmail.Attachments.Item(ii).Type = olEmbeddeditem Then
                            oEmail.Attachments.Item(ii).SaveAsFile "C:\MyOutlookEmailExport\Attachments\" & oEmail.Attachments.Item(ii).FileName
                            sAttachment = sAttachment & "C:\MyOutlookEmailExport\Attachments\" & oEmail.Attachments.Item(ii).FileName & vbNewLine
                        End If
                    Next
                    goRs!Attachment = sAttachment
                Else
                    goRs!Attachment = "None"
                End If
                'CONTINUE ON WITH OTHER FIELD YOU WANT
                '...
                goRs.Update
            End If
            Set oEmail = Nothing
        ElseIf vType = "MeetingItem" Then
            Set oMeetingType = oInbox.Items(i)
            If FindOutlookEmail(oMeetingType.EntryID) = False Then
                goRs.AddNew
                goRs!To = oMeetingType.Recipients.Item(1).Name
                goRs!CC = IIf(oMeetingType.Recipients.Count > 1, oMeetingType.Recipients.Item(2).Name, "")
                goRs!BCC = ""
                goRs!Subject = oMeetingType.Subject
                goRs!Body = oMeetingType.Body           'PLAIN TEXT BODY NOTES
                goRs!HTMLBody = ""
                goRs!Importance = oMeetingType.Importance
                goRs!Received = oMeetingType.ReceivedTime
                goRs!Class = oMeetingType.Class 'EMAIL, MEETING RESPONSE, MEETING REQUEST, DIST. LIST, ETC.
                goRs!ReceivedByName = ""
                goRs!EntryID = oMeetingType.EntryID
                If oMeetingType.Attachments.Count > 1 Then
                    'LOOP THROUGH ALL ATTACHMENTS SAVING TO DIRECTORY AND ENTERING FILENAME INTO FIELD
                    For ii = 1 To oMeetingType.Attachments.Count
                        'DETERMINE ATTACHMENT CLASS TYPE ATTACHED, LINKED, EMBEDDED, OR OLE
                        If oMeetingType.Attachments.Item(ii).Type = olByValue Or oMeetingType.Attachments.Item(ii).Type = olEmbeddeditem Then
                            oMeetingType.Attachments.Item(ii).SaveAsFile "C:\MyOutlookEmailExport\Attachments\" & oMeetingType.Attachments.Item(ii).FileName
                            sAttachment = sAttachment & "C:\MyOutlookEmailExport\Attachments\" & oMeetingType.Attachments.Item(ii).FileName & vbNewLine
                        End If
                    Next
                    goRs!Attachment = sAttachment
                Else
                    goRs!Attachment = "None"
                End If
                'CONTINUE ON WITH OTHER FIELD YOU WANT
                '...
                goRs.Update
            End If
            Set oMeetingType = Nothing
        ElseIf vType = "DistListItem" Then
            Set oDistributionList = oInbox.Items(i)
            If FindOutlookEmail(oDistributionList.EntryID) = False Then
                goRs.AddNew
                goRs!To = oDistributionList.DLName
                goRs!CC = oDistributionList.MemberCount & "-Members"
                goRs!BCC = ""
                goRs!Subject = oDistributionList.Subject
                goRs!Body = oDistributionList.Body           'PLAIN TEXT BODY NOTES
                goRs!HTMLBody = ""
                goRs!Importance = oDistributionList.Importance
                goRs!Received = ""
                goRs!Class = oDistributionList.Class 'EMAIL, MEETING RESPONSE, MEETING REQUEST, DIST. LIST, ETC.
                goRs!ReceivedByName = ""
                goRs!EntryID = oDistributionList.EntryID
                If oDistributionList.Attachments.Count > 1 Then
                    'LOOP THROUGH ALL ATTACHMENTS SAVING TO DIRECTORY AND ENTERING FILENAME INTO FIELD
                    For ii = 1 To oDistributionList.Attachments.Count
                        'DETERMINE ATTACHMENT CLASS TYPE ATTACHED, LINKED, EMBEDDED, OR OLE
                        If oDistributionList.Attachments.Item(ii).Type = olByValue Or oDistributionList.Attachments.Item(ii).Type = olEmbeddeditem Then
                            oDistributionList.Attachments.Item(ii).SaveAsFile "C:\MyOutlookEmailExport\Attachments\" & oDistributionList.Attachments.Item(ii).FileName
                            sAttachment = sAttachment & "C:\MyOutlookEmailExport\Attachments\" & oDistributionList.Attachments.Item(ii).FileName & vbNewLine
                        End If
                    Next
                    goRs!Attachment = sAttachment
                Else
                    goRs!Attachment = "None"
                End If
                'CONTINUE ON WITH OTHER FIELD YOU WANT
                '...
                goRs.Update
            End If
            Set oDistributionList = Nothing
        Else
            MsgBox "Unsupported message type!", vbOKOnly + vbExclamation
        End If
        Set oEmail = Nothing
        prbProgress.Value = i
        i = i + 1
    Loop
    
    Set oInbox = Nothing
    Set oNS = Nothing
    goRs.Close
    Set CnnA = Nothing
    Set goRs = Nothing
    Exit Function
 
No_Bugs:
    
    MsgBox Err.Number & "-" & Err.Description, vbCritical, "Outlook Email Export"
    Resume
 
End Function

[RobDog888]

Second third.

Private Function FindOutlookEmail(ByVal oEmailEntryID As String) As Boolean
 
    Dim oRsAccessEmail As ADODB.Recordset 'EMAIL IN ACCESS TO CHECK AGAINST
    
    Dim i As Integer
    
    Set oRsAccessEmail = New ADODB.Recordset
    oRsAccessEmail.Open "SELECT EntryID FROM Inbox WHERE EntryID = '" & oEmailEntryID & "';", CnnA, adOpenKeyset, adLockReadOnly, adCmdText
    If oRsAccessEmail.BOF = True And oRsAccessEmail.EOF = True Then
        FindOutlookEmail = False
    Else
        FindOutlookEmail = True
    End If
    Set oRsAccessEmail = Nothing
 
End Function
 
Private Function OpenOutlookEmail(ByVal oEmailEntryID As String, sType As String)
'PASS THE .ENTRYID AND THE .TYPE PROPERTY OF THE OUTLOOK ITEM
    On Error GoTo No_Bugs
    
    Dim oOBJ As Object
    Dim oItem As Object
    Dim i As Integer
    Dim bFound As Boolean
    
    'CHECK EACH ITEMS ENTRYID PROPERTY FOR A MATCH (.FIND NOT COMPATIBLE WITH .ENTRYID PROPERTY)
    bFound = False
    For i = 1 To oInbox.Items.Count
        Set oItem = oInbox.Items(i)
        If oItem.EntryID = oEmailEntryID Then
            bFound = True
            Exit For
        Else
            bFound = False
        End If
        Set oItem = Nothing
    Next
    
    If bFound = True Then
        Select Case CLng(sType)
            Case olMail
                sType = "Email"
            Case olMeetingRequest, olMeetingResponseNegative, olMeetingResponsePositive, olMeetingResponseTentative
                sType = "MeetingItem"
            Case olDistributionList
                sType = "DistListItem"
            Case Else
                sType = ""
        End Select
        Select Case sType
            Case "Email", "MeetingItem", "DistListItem"
                Set oOBJ = oInbox.Items(i)
                If TypeName(oOBJ) <> "Nothing" Then
                    oOBJ.Display 'THE USE CAN MAKE CHANGES AND SAVE THEM TO OUTLOOK
                Else
                    MsgBox sType & " not found in Outlook!", vbOKOnly + vbExclamation
                End If
            Case Else
                MsgBox "Invalid Outlook Item Type Passed!", vbOKOnly + vbCritical
        End Select
    Else
        MsgBox "Item not found in Outlook!", vbOKOnly + vbInformation
    End If
    Exit Function
    
No_Bugs:
 
    MsgBox Err.Number & " = " & Err.Description, vbOKOnly + vbExclamation
    Exit Function
    Resume
End Function

[RobDog888]

Last third.

Private Function Outlook_Tasks_2_Access()
'   <GORS = ACCESS>
    On Error GoTo No_Bugs
 
    Dim goRs As ADODB.Recordset
    
    Dim oTask As Outlook.TaskItem
    Dim oTaskReqAccpt As Outlook.TaskRequestAcceptItem
    Dim oTaskReqDcln As Outlook.TaskRequestDeclineItem
    Dim oTaskReqItm As Outlook.TaskRequestItem
    Dim oTaskReqUpd As Outlook.TaskRequestUpdateItem
    
    Dim vType As Variant
    
    Dim i As Integer
    Dim ii As Integer
    Dim iii As Integer
    
    Dim sAttachment As String
    Dim sRecipients As String
    
    Dim sSQL As String
    
    Set goRs = New ADODB.Recordset
    
    sSQL = "SELECT * FROM [Tasks] WHERE 1=2;"
    goRs.Open sSQL, CnnA, adOpenKeyset, adLockOptimistic, adCmdText
    
    prbProgress.Max = oTasks.Items.Count
    i = 1
    Do While i <= oTasks.Items.Count
        DoEvents
        Select Case oTasks.Items(i).Class
            Case olTask
                vType = "Task"
            Case olTaskRequestAccept
                vType = "TaskReqAccpt"
            Case olTaskRequestDecline
                vType = "TaskReqDcln"
            Case olTaskRequest
                vType = "TaskReqItm"
            Case olTaskRequestUpdate
                vType = "TaskReqUpd"
        End Select
        If vType = "Task" Then 'ONLY TASK TYPES
            Set oTask = oTasks.Items(i)
            If FindOutlookTask(oTask.EntryID) = False Then
                'ADDED FOR TESTING ONLY SO YOU CAN SEE HOW TO PASS THE ITEMS.
                'TAKE OUT AND PLACE WHERE YOU ARE CALLING IT FROM
                'OTHERWISE IT WILL OPEN ALL EXPORTED TASKS
                Call OpenOutlookTask(oTask.EntryID, CStr(oTasks.Items(i).Class))
                goRs.AddNew
                goRs!To = oTask.Recipients.Item(0).Name
                sRecipients = ""
                For iii = 1 To oTask.Recipients.Count - 1
                    sRecipients = sRecipients & oTask.Recipients.Item(iii).Name & "; "
                Next
                goRs!CC = sRecipients
                goRs!Subject = oTask.Subject
                goRs!Body = oTask.Body           'PLAIN TEXT BODY NOTES
                goRs!Importance = oTask.Importance
                goRs!StartDate = oTask.StartDate
                goRs!Class = oTask.Class 'TASK, TASKREQUESTACCEPT, TASKREQUESTDECLINE, ETC.
                goRs!ReceivedByName = oTask.ReceivedByName
                goRs!EntryID = oTask.EntryID
                If oTask.Attachments.Count > 1 Then
                    'LOOP THROUGH ALL ATTACHMENTS SAVING TO DIRECTORY AND ENTERING FILENAME INTO FIELD
                    For ii = 1 To oTask.Attachments.Count
                        'DETERMINE ATTACHMENT CLASS TYPE ATTACHED, LINKED, EMBEDDED, OR OLE
                        If oTask.Attachments.Item(ii).Type = olByValue Or oTask.Attachments.Item(ii).Type = olEmbeddeditem Then
                            oTask.Attachments.Item(ii).SaveAsFile "C:\MyOutlookEmailExport\Attachments\" & oTask.Attachments.Item(ii).FileName
                            sAttachment = sAttachment & "C:\MyOutlookEmailExport\Attachments\" & oTask.Attachments.Item(ii).FileName & vbNewLine
                        End If
                    Next
                    goRs!Attachment = sAttachment
                Else
                    goRs!Attachment = "None"
                End If
                'CONTINUE ON WITH OTHER FIELD YOU WANT
                '...
                goRs.Update
            End If
            Set oTask = Nothing
        'MORE CODE GOES HERE FOLOWING SAME LOGIC
        'ElseIf
        
        'ElseIf
        'etc.
        End If
 
 
End Function
 
Private Function FindOutlookTask(ByVal oTaskEntryID As String) As Boolean
 
    Dim oRsAccessTask As ADODB.Recordset 'TASK IN ACCESS TO CHECK AGAINST
    
    Dim i As Integer
    
    Set oRsAccessTask = New ADODB.Recordset
    oRsAccessTask.Open "SELECT EntryID FROM Tasks WHERE EntryID = '" & oTaskEntryID & "';", CnnA, adOpenKeyset, adLockReadOnly, adCmdText
    If oRsAccessTask.BOF = True And oRsAccessTask.EOF = True Then
        FindOutlookTask = False
    Else
        FindOutlookTask = True
    End If
    Set oRsAccessTask = Nothing
 
End Function
 
Private Function OpenOutlookTask(ByVal oTaskEntryID As String, sType As String)
'PASS THE .ENTRYID AND THE .TYPE PROPERTY OF THE OUTLOOK ITEM
    On Error GoTo No_Bugs
    
    Dim oOBJ As Object
    Dim oItem As Object
    Dim i As Integer
    Dim bFound As Boolean
    
    'CHECK EACH ITEMS ENTRYID PROPERTY FOR A MATCH (.FIND NOT COMPATIBLE WITH .ENTRYID PROPERTY)
    bFound = False
    For i = 1 To oInbox.Items.Count
        Set oItem = oTasks.Items(i)
        If oItem.EntryID = oEmailEntryID Then
            bFound = True
            Exit For
        Else
            bFound = False
        End If
        Set oItem = Nothing
    Next
    
    If bFound = True Then
        Select Case CLng(sType)
            Case olTask
                sType = "Task"
            Case olTaskRequestAccept, olTaskRequestDecline, olTaskRequest, olTaskRequestUpdate
                sType = "TaskItem"
            Case Else
                sType = ""
        End Select
        Select Case sType
            Case "Task", "TaskItem"
                Set oOBJ = oTasks.Items(i)
                If TypeName(oOBJ) <> "Nothing" Then
                    oOBJ.Display 'THE USE CAN MAKE CHANGES AND SAVE THEM TO OUTLOOK
                Else
                    MsgBox sType & " not found in Outlook!", vbOKOnly + vbExclamation
                End If
            Case Else
                MsgBox "Invalid Outlook Item Type Passed!", vbOKOnly + vbCritical
        End Select
    Else
        MsgBox "Item not found in Outlook!", vbOKOnly + vbInformation
    End If
    Exit Function
    
No_Bugs:
 
    MsgBox Err.Number & " = " & Err.Description, vbOKOnly + vbExclamation
    Exit Function
    Resume
End Function