outlook.vb

'Option Explicit





        
        

Sub Retrieve_http()

'our Outlook folder- deifinitions
    Dim myItem As MailItem
    Dim myFolder As Folder
    Dim myNamespace As NameSpace
    Set myNamespace = Application.GetNamespace("MAPI")
    'put your folders name here
    '1st one is store folder which should refer to [email protected]
    'second is possibly 'inbox folder'
    Set myFolder = myNamespace.Folders("ELM").Folders("Inbox")
    
    ' Set up DAO objects (uses existing Access "Email" table).
    Dim rst As DAO.Recordset
    Set rst = CurrentDb.OpenRecordset("Email")

    'Set Up Outlook objects.
    Dim cMail As Outlook.MailItem
    Dim cAtch As Outlook.Attachments
    
    
    Set myMail = myFolder.Items
    'MsgBox myMail.Count

    Set objProp = myMail

    iNumMessages = objProp.Count
    If iNumMessages <> 0 Then
        For i = 5 To iNumMessages
        
            Debug.Print TypeName(objProp(i))
            If TypeName(objProp(i)) = "MailItem" Then
                Set cMail = objProp(i)
                'Debug.Print cMail.SentOn
                If (CDate(cMail.SentOn) > CDate("2017-06-29") And CDate(cMail.SentOn) < CDate("2018-08-01")) Then
                'If ([rst]![EmailLocation] <> ofProp.Name) And ([rst]![EntryID] <> cMail.EntryID) Then

                'End If
                End If
            Else
                'Debug.Print TypeName(objProp(i))
            End If
        Next i
    End If



End Sub

Sub ms_access()
Dim tbl As DAO.Recordset
End Sub




Private Sub Command3_Click()
    ImportMailPropFromOutlook
End Sub

Sub ImportMailPropFromOutlook()

    ' Code for specifing top level folder and initializing routine.

    ' Set up Outlook objects.
    Dim ol As New Outlook.Application
    Dim olNs As Outlook.NameSpace
    Dim ofO As Outlook.MAPIFolder
    Dim ofSubO As Outlook.MAPIFolder
    Dim objItems As Outlook.Items

    Set olNs = ol.GetNamespace("MAPI")
    'Set ofO = olNs.Folders("ELM").Folders("Inbox")
    Set ofO = olNs.GetDefaultFolder(olFolderInbox) '--- Specifies top level folder for     importing Oultook mail.
    
    
    'Set of = olNs.PickFolder '--- Allows user to select top level folder for importing     Outlook mail.
    
    'Set info and call GetMailProp code.
    Set objItems = ofO.Items
    GetMailProp objItems, ofO

    'Set info and call ProcessSubFolders.
    'For Each ofSubO In olns.Folders
     '   Set objItems = ofSubO.Items
      '  ProcessSubFolders objItems, ofSubO
    'Next

End Sub

Sub GetMailProp(objProp As Outlook.Items, ofProp As Outlook.MAPIFolder)

    ' Code for writeing Outlook mail properties to Access.

    ' Set up DAO objects (uses existing Access "Email" table).
    Dim rst As DAO.Recordset
    Set rst = CurrentDb.OpenRecordset("Email")

    'Set Up Outlook objects.
    Dim cMail As Outlook.MailItem
    Dim cAtch As Outlook.Attachments
    Dim iNumMessages As Integer

    'Dim myNamespace As NameSpace
    'Set myNamespace = Application.GetNamespace("MAPI")
   'Set myFolder = myNamespace.Folders("ELM").Folders("Inbox")
    
    'Write Outlook mail properties to Access "Email" table.
    iNumMessages = objProp.Count
    If iNumMessages <> 0 Then
        For i = 5 To iNumMessages
            If TypeName(objProp(i)) = "MailItem" Then
                Set cMail = objProp(i)
                'If ([rst]![EmailLocation] <> ofProp.Name) And ([rst]![EntryID] <> cMail.EntryID) Then
                    rst.AddNew
                    rst!EntryID = cMail.EntryID
                    rst!ConversationID = cMail.ConversationID
                    rst!Sender = cMail.SenderEmailAddress
                    rst!SenderEmailType = cMail.SenderEmailType
                    rst!SenderID = cMail.Sender.ID
                    rst!SenderName = cMail.SenderName
                    rst!SentOn = cMail.SentOn
                    rst!To = cMail.To
                    rst!CC = cMail.CC
                    rst!BCC = cMail.BCC
                    rst!Subject = cMail.Subject
                    Set cAtch = cMail.Attachments
                    cntAtch = cAtch.Count
                    If cntAtch > 0 Then
                        For j = cntAtch To 1 Step -1
                            strAtch = cAtch.Item(j).FileName
                            rst!Attachments = strAtch
                        Next
                    Else
                        rst!Attachments = "No Attachments"
                    End If
                    'rst!Count = cMail.Attachments.Count
                    rst!Body = cMail.Body
                    rst!HTMLBody = cMail.HTMLBody
                    rst!Importance = cMail.Importance
                    rst!Size = cMail.Size
                    rst!CreationTime = cMail.CreationTime
                    rst!ReceivedTime = cMail.ReceivedTime
                    rst!ExpiryTime = cMail.ExpiryTime
                    'rst!EmailLocation = ofProp.Name
                    rst.Update
                'End If
            End If
        Next i
    End If

End Sub

Sub ProcessSubFolders(objItemsR As Outlook.Items, OfR As Outlook.MAPIFolder)

    'Code for processing subfolders

    ' Set up Outlook objects.
    Dim ofSubR As Outlook.MAPIFolder

    'Set info and call GetMailProp code.
    GetMailProp objItemsR, OfR

    'Set info and call ProcessSubFolders. Recursive.
    For Each ofSubR In OfR.Folders
        Set objItemsR = ofSubR.Items
        ProcessSubFolders objItemsR, ofSubR
    Next

End Sub