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

[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