I am trying to save emails to an access database. I advice has been given as follows in the forum (I would suggest that you then get the ID number of this DB record and add this ID to the "mileage" field of the email item. Then you will always be able to find this email in outlook again (unless it is deleted) ), and have decided that this is the way to go but can't figure out how you put the ID into the mileage field. This is the code i tried (modified copy of code available online):
Code:
'This function will scan your inbox and return a mailitem that has a subject that matches subject line
Private Function ScanInbox(SubjectLine As String)
Dim strSQL As String
Dim sentTime As Date
Dim sentDate As Date
Dim sentDateTime As Date
Dim tempDate As Date
Dim tmp1Date As Date
Dim tmp1Time As Date
Dim tempTime As Date
Dim sentId As String
Dim tempId As Integer
Dim chkDate As Date
Dim TempRst As dao.Recordset
Dim OlApp As Outlook.Application
Dim Inbox As Outlook.MAPIFolder
Dim InboxItems As Outlook.Items
Dim Mailobject As Object
Set OlApp = CreateObject("Outlook.Application")
Set Inbox = OlApp.GetNamespace("Mapi").GetDefaultFolder(olFolderInbox)
Set TempRst = CurrentDb.OpenRecordset("tbl_OutlookTemp", dbOpenDynaset)
If SubjectLine <> "" Then
Set InboxItems = Inbox.Items.Restrict("[Subject] = """ & SubjectLine & """")
Else
Set InboxItems = Inbox.Items
End If
For Each Mailobject In InboxItems
'check that it is in fact an email that has been chosen
If Mailobject.Class = olMail Then
'Process as it is an email
sentDateTime = Mailobject.SentOn
sentId = Mailobject.Mileage
sentDate = FormatDateTime(Mailobject.SentOn, vbShortDate)
sentTime = FormatDateTime(Mailobject.SentOn, vbLongTime)
If TempRst.RecordCount <> 0 Then
' Date/Time checks removed. Trying Id match instead (based on MailObject.Mileage)
' strSQL = "[DateSent] = #" & sentDateTime & "#"
strSQL = "[Id] = " & sentId
TempRst.FindFirst strSQL & "9"
' Date/Time checks removed. Trying Id match instead (based on MailObject.Mileage)
' tmp1Date = [DateSent]
' tempTime = FormatDateTime(tmp1Date, vbLongTime)
' tempId = TempRst("Id")
'If Times don't match then store email
If TempRst.NoMatch Or sentId = "" Then
With TempRst
On Error Resume Next
.AddNew
!Subject = Mailobject.Subject
!From = Mailobject.SenderName
!To = Mailobject.To
!BOdy = Mailobject.BOdy
!DateSent = Mailobject.SentOn
.Update
Mailobject.Mileage = TempRst("Id")
'Mailobject.Read = True
End With
End If
Else
With TempRst
On Error Resume Next
.AddNew
!Subject = Mailobject.Subject
!From = Mailobject.SenderName
!To = Mailobject.To
!BOdy = Mailobject.BOdy
!DateSent = Mailobject.SentOn
.Update
Mailobject.Mileage = TempRst("Id")
'Mailobject.Read = True
End With
End If
End If
Next
Set OlApp = Nothing
Set Inbox = Nothing
Set InboxItems = Nothing
Set Mailobject = Nothing
Set TempRst = Nothing
End Function