Hi
Years ago I did a similar thing but instead of trying to figure out importing emails directly from outlook I create a form where users were pasting the text of the email and then Process Email ran a code which parsed and appended the values in a table. I did it because it was easier. Please see the attached screenshot and code behind process button. Hope it will help
Code
On Error Resume Next
Dim db As DAO.Database
Dim Rst As DAO.Recordset
Dim strTitle, strEmailText As String
Dim strStatus, strSurname, strGivenName, strAgencyName, strAddress, strSuburb, strPostCode, strPhone, strFax, strEmail As String
Dim strC1, strReferName, strReferDate, strC2, strMediaName, strMediaDate, strDate, strTime As String
Dim strGroup, strBasis, strMainConcern, strAttempts, strAchieve, strSuggestions, strComments As String
Set db = CurrentDb
strEmailText = Me.TxtEmail
strTitle = (ParseText("TxtTitle:", "TxtStatus:", 0, 0))
strStatus = (ParseText("TxtStatus:", "TxtSurname:", 0, 0))
strSurname = (ParseText("TxtSurname:", "TxtGivenNames:", 0, 0))
strGivenName = (ParseText("TxtGivenNames:", "TxtAgencyName:", 0, 0))
strAgencyName = (ParseText("TxtAgencyName:", "TxtAddress:", 0, 0))
strAddress = (ParseText("TxtAddress:", "TxtSuburb:", 0, 0))
strSuburb = (ParseText("TxtSuburb:", "TxtPostCode:", 0, 0))
strPostCode = (ParseText("TxtPostCode:", "TxtPhone:", 0, 0))
strPhone = (ParseText("TxtPhone:", "TxtFax:", 0, 0))
strFax = (ParseText("TxtFax:", "TxtEmail:", 0, 0))
strEmail = (ParseText("TxtEmail:", "C1:", 0, 0))
strC1 = Nz(ParseText("C1:", "refername:", 0, 0), "No")
strReferName = ParseText("refername:", "referdate:", 0, 0)
strReferDate = Left(ParseText("referdate:", "C2:", 0, 0), 10)
strC2 = Nz(ParseText("C2:", "medianame:", 0, 0), "No")
strMediaName = ParseText("medianame:", "mediadate:", 0, 0)
strMediaDate = ParseText("mediadate:", "B1:", 0, 0)
strGroup = ParseText("TxtGroup:", "TxtBasis:", 4, 4)
strBasis = ParseText("TxtBasis:", "TxtMainConcern:", 4, 4)
If strTitle = "" And strSurname = "" Then
MsgBox "The information Pasted is not complete. Vital information like Title, Surname etc is missing. Please retry adding the record", vbCritical, "Error creating record"
Exit Sub
Else
'Check and add record
strCheckDate = "DT" & strDate & strTime
strCheck = Nz(DLookup("Autoflag", "TblComplaints", "CompDateTime Like 'DT" & strDate & strTime & "'"), "OK")
'MsgBox (strCheck)
'MsgBox DLookup("Title", "TblComplaints", "AutoFlag=10")
If strCheck = "OK" Then
Set Rst = db.OpenRecordset("TblComplaints")
Rst.AddNew
Rst.Fields(1) = Date
TrapError (Rst.Fields(1).Name)
Rst.Fields(2) = strTitle
TrapError (Rst.Fields(2).Name)
Rst.Fields(3) = strStatus
TrapError (Rst.Fields(3).Name)
Rst.Fields(4) = strSurname
TrapError (Rst.Fields(4).Name)
Rst.Fields(5) = strGivenName
TrapError (Rst.Fields(5).Name)
Rst.Fields(6) = strAgencyName
TrapError (Rst.Fields(6).Name)
Rst.Fields(7) = strAddress
TrapError (Rst.Fields(7).Name)
Rst.Fields(8) = strSuburb
TrapError (Rst.Fields(8).Name)
Rst.Fields(9) = strPostCode
TrapError (Rst.Fields(9).Name)
Rst.Fields(10) = strPhone
TrapError (Rst.Fields(10).Name)
Rst.Fields(11) = strFax
TrapError (Rst.Fields(11).Name)
Rst.Fields(12) = strEmail
TrapError (Rst.Fields(12).Name)
Rst.Fields(13) = strC1
TrapError (Rst.Fields(13).Name)
Rst.Fields(14) = strReferName
TrapError (Rst.Fields(14).Name)
Rst.Fields(27) = strEmailText
Rst.Update
If Err.Number > 0 Then
MsgBox "Errors encountered during insertion process." & vbCrLf & vbCrLf & "Following Fields have possibly encountered errors during insertion. Please reconfirm the enteries in these fields" & vbCrLf & ErrorMsg, vbExclamation
Else
MsgBox "Success: Record was inserted with no errors", vbInformation
End If
Else
strCheckTitle = DLookup("Title", "TblComplaints", "AutoFlag=" & strCheck)
MsgBox "Following record with same date and time is already exisiting in the database." & vbCrLf & vbCrLf & _
"Complaint Title: " & strCheckTitle & vbCrLf & "Date/Time: " & strDate & " " & strTime & vbCrLf & vbCrLf & "Please check your records", vbCritical
End If
End If
End Sub
Function ParseText(Start_Position As String, End_Position As String, AdjustStart As Integer, AdjustEnd As Integer)
Dim strEmail As String
Dim strStatus As String
Dim strSurname As String
strEmail = Me.TxtEmail
'MsgBox (strEmail)
'MsgBox LTrim((Mid(strEmail, 10, 6))) & vbCrLf & "Start: " & InStr(strEmail, "Txtstatus:") + 7 & vbCrLf & "End: " & InStr(strEmail, "Txtsurname")
ParseText = LTrim(Mid(strEmail, InStr(strEmail, Start_Position) + Len(Start_Position) + AdjustStart, InStr(strEmail, End_Position) - (InStr(strEmail, Start_Position) + Len(Start_Position) + AdjustEnd)))
ParseText = Left(ParseText, Len(ParseText) - 2)
End Function
