[blue]Public Sub ImportOutlookItems()
Dim Olapp As Outlook.Application, _
OlBody As String, _
OlItems As Outlook.Items, _
Olfolder As Outlook.MAPIFolder, _
OlMail As Object, _
Olmapi As Outlook.NameSpace, _
flgSave As Boolean, flgPrompt As Boolean, DQ As String, _
db As DAO.Database, rst As DAO.Recordset
Set db = CurrentDb
Set rst = db.OpenRecordset("tbl_Mail", dbOpenDynaset)
DQ = """"
[green]'Create a connection to outlook[/green]
Set Olapp = CreateObject("Outlook.Application")
Set Olmapi = Olapp.GetNamespace("MAPI")
[green]'Open the PSC-EMEA inbox[/green]
Set Olfolder = Olmapi.GetDefaultFolder(olFolderInbox)
Set OlItems = Olfolder.Items
For Each OlMail In OlItems
OlBody = [purple][b]Replace(OlMail.Body, DQ, "'")[/b][/purple]
If rst.RecordCount = 0 Then
flgSave = True 'no records ok to save
Else
rst.FindFirst "[Body] = " & DQ & OlBody & DQ
If rst.NoMatch Then
flgSave = True [green]'body not found, ok to save[/green]
End If
End If
If flgSave Then
rst.AddNew
rst!Date = OlMail.ReceivedTime
rst!Time = OlMail.ReceivedTime
rst!From = OlMail.SenderName
rst!Subject = OlMail.Subject
[purple][b]rst!Body = OlBody[/b][/purple] [green]'Not OlMail.Body![/green]
rst!CreationTime = OlMail.CreationTime
rst!LastModificationTime = OlMail.LastModificationTime
rst!Last_Checked = Now
rst.Update
[purple][b]rst.Requery[/b][/purple] [green]'Update rst to currently saved item![/green]
flgPrompt = True
End If
flgSave = False
Next
If flgPrompt Then
MsgBox "New mails have been updated. Please check the tbl_Mail details", vbOKOnly
Else
MsgBox "No Mail saved! . . ."
End If
[green]'Release memory[/green]
Set OlItems = Nothing
Set Olfolder = Nothing
Set Olmapi = Nothing
Set Olapp = Nothing
End Sub[/blue]