Access and Outlook

[sdc1234]

I am trying to save all of my email tracking into a database in Access for about 1500 people , is this possible? If so, would I have to enter them one by one or is there an easier way? Thank you

[Dal Jeanis]

If there's a lot of them, I'm sure there's an easier way.

For instance, assuming your emails are currently stored in Outlook, you could use VBA from within Access to pull them over from Outlook, or VBA from Outlook to push them over to Access. Either direction, you'll have to work out the syntax to open the other application and copy the emails.

I've seen specific info here on how to do that to/from Excel, but i haven't seen much on Outlook. Then again, I haven't been looking for it.

[live2ride]

below code will import emails from outlook to access

Private Function emailCount()
importFromOutlook
End Function

Sub importFromOutlook()
On Error GoTo err_LogError

Dim rs As DAO.Recordset
Set rs = CurrentDb.OpenRecordset("table")
Dim outlookApp As Outlook.Application
Set outlookApp = CreateObject("outlook.Application")
Dim inboxMain As Outlook.MAPIFolder
Set inboxMain = outlookApp.GetNamespace("MAPI").GetDefaultFolder(o lFolderInbox)
'' below is if your email is stored in sub folder
Dim inboxSubfolder1 As Outlook.MAPIFolder
Set inboxSubfolder1 = inboxMain.Folders("sub folder 1")
Dim inboxSubfolder2 As Outlook.MAPIFolder
Set inboxSubfolder2 = inboxSubfolder1.Folders("sub folder 2")
Dim InboxItems As Outlook.Items
Set InboxItems = inboxSubfolder2.Items ''change to 'inboxMain' if email is in main inbox folder
Dim emails As Object

For Each emails In InboxItems
'if emails.unread then ' if emails are read or unread
With rs
.AddNew
!Subject = emails.Subject
!Contents = emails.Body
!Received = emails.ReceivedTime
!Created = emails.SentOn
' you can add additional fields as you want
.Update

''''''' below updates your emails in outlook, i prefer to do something to emails like change category so you know you have imported this email and prevent duplicates
emails.UnRead = False
emails.Categories = "imported by access"
' emails.Importance = 0
emails.TaskCompletedDate = Now()
emails.Save
emails.move inboxSubfolder1 ''' if you want to move your emails to another folder

End With
'end if
Next

''''' when going through many emails something gets broken and only few emails are imported
If InboxItems.count <> 0 Then
Call emailCount
End If

rs.Close
Set outlookApp = Nothing
Set inboxMain = Nothing
Set inboxSubfolder1 = Nothing
Set inboxSubfolder2 = Nothing
Set emails = Nothing
Set rs = Nothing


Exit_LogError: ' Label to resume after error.
Exit Sub
err_LogError:
MsgBox Err.Number & Err.Description

End Sub

[sdc1234]

below code will import emails from outlook to access

Private Function emailCount()
importFromOutlook
End Function

Sub importFromOutlook()
On Error GoTo err_LogError

Dim rs As DAO.Recordset
Set rs = CurrentDb.OpenRecordset("table")
Dim outlookApp As Outlook.Application
Set outlookApp = CreateObject("outlook.Application")
Dim inboxMain As Outlook.MAPIFolder
Set inboxMain = outlookApp.GetNamespace("MAPI").GetDefaultFolder(o lFolderInbox)
'' below is if your email is stored in sub folder
Dim inboxSubfolder1 As Outlook.MAPIFolder
Set inboxSubfolder1 = inboxMain.Folders("sub folder 1")
Dim inboxSubfolder2 As Outlook.MAPIFolder
Set inboxSubfolder2 = inboxSubfolder1.Folders("sub folder 2")
Dim InboxItems As Outlook.Items
Set InboxItems = inboxSubfolder2.Items ''change to 'inboxMain' if email is in main inbox folder
Dim emails As Object

For Each emails In InboxItems
'if emails.unread then ' if emails are read or unread
With rs
.AddNew
!Subject = emails.Subject
!Contents = emails.Body
!Received = emails.ReceivedTime
!Created = emails.SentOn
' you can add additional fields as you want
.Update

''''''' below updates your emails in outlook, i prefer to do something to emails like change category so you know you have imported this email and prevent duplicates
emails.UnRead = False
emails.Categories = "imported by access"
' emails.Importance = 0
emails.TaskCompletedDate = Now()
emails.Save
emails.move inboxSubfolder1 ''' if you want to move your emails to another folder

End With
'end if
Next

''''' when going through many emails something gets broken and only few emails are imported
If InboxItems.count <> 0 Then
Call emailCount
End If

rs.Close
Set outlookApp = Nothing
Set inboxMain = Nothing
Set inboxSubfolder1 = Nothing
Set inboxSubfolder2 = Nothing
Set emails = Nothing
Set rs = Nothing


Exit_LogError: ' Label to resume after error.
Exit Sub
err_LogError:
MsgBox Err.Number & Err.Description

End Sub

am I to create a macro?

[Dal Jeanis]

Macros don't look like that. That's VBA. It could go behind a button on a form, or in a ribbon if you know how and want to put it there.