Public Sub EmailsToAccess()
'Dim Session As Outlook.NameSpace
Dim currentExplorer As Explorer
Dim oSelection As Outlook.Selection
Dim strSubject1 As String, strSubject2 As String
Dim objAccess As Object, rsEmail As Object
Dim dbs As Object
Dim i As Long
Dim obj As Object
Dim strDB As String
' Initialize string to database path.
Const strDBPath = "C:\Users\Paul\Documents\"
Set currentExplorer = Application.ActiveExplorer
Set oSelection = currentExplorer.Selection
Set objAccess = CreateObject("Access.Application")
objAccess.opencurrentdatabase (strDBPath & "OutlookEmails.accdb")
Set dbs = CurrentDb
Set rsEmail = dbs.openrecordset("SELECT * from tblEmail WHERE ID=0", 2) 'dbopendynaset
For Each obj In Selection
With obj
rsEmail.addnew
rsEmail!EmailSubject = .Subject
rsEmail!EmailPerson = .Sender
rsEmail!EmailDate = .datesent
rsEmail!EmailTime = .timesent
rsEmail.Update
End With
Next
' strSubject1 = oSelection.Item(1).Subject
' For i = 2 To oSelection.Count
' strSubject2 = oSelection.Item(i).Subject
' 'Debug.Print "1 " & strSubject1
' 'Debug.Print "2 " & strSubject2
' If strSubject1 = strSubject2 Then
' oSelection.Item(i).Delete
' Else
' strSubject1 = oSelection.Item(i).Subject
' End If
' Next i
Close rsEmail
Set rsEmail = Nothing
Set dbs = Nothing
Set objAccess = Nothing
'Set Session = Nothing
Set currentExplorer = Nothing
Set obj = Nothing
Set oSelection = Nothing
End Sub
