Trying to get BODY from open Outlook 2016 message into Access database RRS feed

  • Question

  • Hi all,

    I am trying to setup a mechanism, where we take a currently open email message in Outlook 2016, that has some info in the BODY of the message (First Name, Last Name, Address, Phone). Then, take
    that body and process it and put it into some fields in an access database. We
    are just trying to figure out the lines of code to fill a variable in VBA with
    the contents of an open Outlook 2016 email message, by clicking a button in
    Access 2016. This is a shared office mailbox.
    I am a newbie to VB. I did not develop the original code. Any help would be appreciated. Here is the full code (line with error is in blue). This code was working fine with Outlook 2010 and Access 2010. Once my environment was upgraded to Outlook 365 and Access 365 the error began (strEmailbody = ActiveInspector.CurrentItem.Body) when I click on the "Get from email" automation button in Access. Normally, an email with a certain subject line needs to open in Outlook along with a new record in Access to automatically import the fields from the outlook form to the Access database fields with the "Get from email" automation button. Here is the code that we currently have from 2010 to try to get the body of the Outlook email into in the record fields of the Access database.

    Any thoughts?

    Debug error code highlights: strEmailbody = ActiveInspector.CurrentItem.Body
    Access Database gives Error message is a runtime error 287

    Here is the larger portion of the Code:


    'Module requirements:
    'This Module1
    'Form - "RAT Input Form"
    'user must have RAT Input Form open!
    'Report - "RAT Email Concurrance Template - GM"
    'Query - "Query Menu - SEID Query - GM"
    'if user does not have a c:\temp folder, it will be created

    Option Compare Database
    Option Explicit

    Sub GenerateConfEmail()
    'exports a report as RTF and pastes it into an email
    Dim objOutlookApp As Outlook.Application
    Dim objEmailform As Outlook.MailItem
    Dim objWordApp As Word.Application
    Dim objReportOutput As Word.Document
    Dim strEmailSubject As String
    Dim dateCurrentTime As Date
    Dim i As Integer
    'create objects for outlook/word
    Set objOutlookApp = CreateObject("Outlook.Application")
    Set objEmailform = objOutlookApp.CreateItem(olMailItem)
    Set objWordApp = CreateObject("Word.Application")

    DoCmd.OpenReport reportname:="RAT Email Concurrance Template - GM", View:=acViewPreview
    DoCmd.OutputTo objecttype:=acOutputReport, outputformat:=acFormatRTF, outputfile:="c:\temp\tempexp.doc"
    DoCmd.Close acReport, "RAT EMAIL Concurrance Template - GM"
    'temp file stored to local c:\temp folder
    Set objReportOutput = objWordApp.Documents.Open("c:\temp\tempexp.doc")


    objEmailform.Body = ""

    BlockInput True
    'pause (approx 3 seconds)
    dateCurrentTime = Now
    Do While (Now - dateCurrentTime) < 0.00006472

    If objOutlookApp.Version Like "14*" Then
    'using sendkeys to put info in mail
    SendKeys "%u", True
    SendKeys "{TAB}", True
    SendKeys "^v", True
    SendKeys "%j", True
    SendKeys "{TAB}", True
    SendKeys "^v", True
    End If
    BlockInput False

    On Error Resume Next
    objEmailform.Recipients.Add Forms("RAT Input Form").Controls("User Email")
    objEmailform.Recipients.Add Forms("RAT Input Form").Controls("Mgr Email")
    objEmailform.Recipients.Add Forms("RAT Input Form").Controls("RAC Email")

    strEmailSubject = "Request for concurrence - " & Screen.ActiveForm.Controls("User First Name") & " " & Screen.ActiveForm.Controls("User Last Name") & " - IRAP Order #" & Screen.ActiveForm.Controls("Record number")
    objEmailform.Subject = strEmailSubject
    objEmailform.SentOnBehalfOfName = "*IRAP"
    objReportOutput.Close savechanges:=False
    'do not want to autosend mail - user will review

    End Sub
    Sub FillRATFromEmail()
    'gets the entries for RAT form from the email to *IRAP
    Dim objOutlookApp As Outlook.Application
    Dim strEmailbody As String
    Dim lStartPos As Long
    Dim strCurrentText As String
    Dim lStartNumber As Long
    Dim lEndNumber As Long
    Dim strAECategory As String
    Dim strPrimaryAECategory As String
    Dim byteIsBlind As Byte
    Dim byteIsLV As Byte
    Dim byteIsDeaf As Byte
    Dim byteIsHOH As Byte
    Dim byteISLD As Byte
    Dim byteIsMob As Byte
    Dim rectempset As Recordset
    Dim recEmpAssignRecs As Recordset

    Dim i As Integer
    'the items IN ACCESS we want to return from the email
    'each string must match the access field name perfectly
    Dim STRCheckedItems(23) As String
    STRCheckedItems(0) = "User First Name"
    STRCheckedItems(1) = "User Last Name"
    STRCheckedItems(2) = "User Email"
    STRCheckedItems(3) = "SEID"
    STRCheckedItems(4) = "User Phone"
    STRCheckedItems(5) = "User Ext"
    STRCheckedItems(6) = "User Fax Number"
    STRCheckedItems(7) = "Mgr First Name"
    STRCheckedItems(8) = "Mgr Last Name"
    STRCheckedItems(9) = "Mgr phone"
    STRCheckedItems(10) = "Mgr Ext"
    STRCheckedItems(11) = "Mgr Email"
    STRCheckedItems(12) = "Address 2"
    STRCheckedItems(13) = "Functional Area"
    STRCheckedItems(14) = "Address 1"
    STRCheckedItems(15) = "Zip"
    STRCheckedItems(16) = "City"
    STRCheckedItems(17) = "State"
    STRCheckedItems(18) = "RA Number"
    STRCheckedItems(19) = "RAC First Name"
    STRCheckedItems(20) = "RAC Last Name"
    STRCheckedItems(21) = "RAC Email"
    STRCheckedItems(22) = "RAC Phone"
    STRCheckedItems(23) = "Work Schedule"
    Dim STRReturnedItems(23) As String

    'if the current record isn't blank, abort
    If IsNull(Screen.ActiveForm.Controls("User First Name")) Then
    Select Case Screen.ActiveForm.Controls("User First Name")
    Case "", "Blank", "BLANK", "blank"
    Case Else
    MsgBox ("You must use a blank or newly created record.")
    Exit Sub
    End Select
    End If
    'activeinspector.currentitem = the active task/email open in outlook
    'if there isnt one, abort
    If ActiveInspector Is Nothing Then
    MsgBox ("You must open the Request for Adaptive Equipment email.")
    Exit Sub
    End If

    'if the email isn't a request for adaptive equipment, abort
    If Left(ActiveInspector.CurrentItem.Subject, 30) <> "Request for Adaptive Equipment" Then
    MsgBox ("You must open the Request for Adaptive Equipment email.")
    Exit Sub
    End If

    strEmailbody = ActiveInspector.CurrentItem.Body

    'email body is plain text - must use string searches to get data
    'will not be perfect - users should review
    On Error Resume Next
    'get name
    lStartNumber = InStr(1, strEmailbody, "Employee Name:")
    lEndNumber = InStr(1, strEmailbody, "Employee E-Mail:")
    strCurrentText = Mid(strEmailbody, lStartNumber + 18, lEndNumber - lStartNumber - 20)
    STRReturnedItems(0) = Proper(Left(strCurrentText, InStr(1, strCurrentText, " ") - 1))
    STRReturnedItems(1) = Proper(Mid(strCurrentText, InStrRev(strCurrentText, " ") + 1))
    'get email
    lStartNumber = InStr(1, strEmailbody, "Employee E-Mail:")
    lEndNumber = InStr(1, strEmailbody, "Employee SEID No.:")
    strCurrentText = Mid(strEmailbody, lStartNumber + 20, lEndNumber - lStartNumber - 22)
    STRReturnedItems(2) = Proper(strCurrentText)
    'get seid
    lStartNumber = InStr(1, strEmailbody, "Employee SEID No.:")
    lEndNumber = InStr(1, strEmailbody, "Employee Phone No.:")
    strCurrentText = Mid(strEmailbody, lStartNumber + 22, lEndNumber - lStartNumber - 24)
    STRReturnedItems(3) = UCase(Left(strCurrentText, 7))
    'get emp phone and ext
    lStartNumber = InStr(1, strEmailbody, "Employee Phone No.:")
    lEndNumber = InStr(1, strEmailbody, "Schedule:")
    strCurrentText = Mid(strEmailbody, lStartNumber + 23, lEndNumber - lStartNumber - 25)
    If InStr(1, strCurrentText, "x") > 0 Then
    STRReturnedItems(4) = Left(strCurrentText, InStr(1, strCurrentText, "x") - 1)
    STRReturnedItems(5) = Mid(strCurrentText, InStr(1, strCurrentText, "x") + 1)
    STRReturnedItems(4) = strCurrentText
    End If
    'get work schedule
    lStartNumber = InStr(1, strEmailbody, "Schedule:")
    lEndNumber = InStr(1, strEmailbody, "Manager Name:")
    strCurrentText = Mid(strEmailbody, lStartNumber + 13, lEndNumber - lStartNumber - 15)
    STRReturnedItems(23) = strCurrentText
    'get manager first and last name
    lStartNumber = InStr(1, strEmailbody, "Manager Name:")
    lEndNumber = InStr(1, strEmailbody, "Manager Phone No.:")
    strCurrentText = Mid(strEmailbody, lStartNumber + 17, lEndNumber - lStartNumber - 19)
    STRReturnedItems(7) = Proper(Left(strCurrentText, InStr(1, strCurrentText, " ") - 1))
    STRReturnedItems(8) = Proper(Mid(strCurrentText, InStrRev(strCurrentText, " ") + 1))
    'get mgr phone and ext
    lStartNumber = InStr(1, strEmailbody, "Manager Phone No.:")
    lEndNumber = InStr(1, strEmailbody, "Manager E-Mail:")
    strCurrentText = Mid(strEmailbody, lStartNumber + 22, lEndNumber - lStartNumber - 24)
    If InStr(1, strCurrentText, "x") > 0 Then
    STRReturnedItems(9) = Left(strCurrentText, InStr(1, strCurrentText, "x") - 1)
    STRReturnedItems(10) = Mid(strCurrentText, InStr(1, strCurrentText, "x") + 1)
    STRReturnedItems(9) = strCurrentText
    End If

    Thursday, June 22, 2017 2:29 PM

All replies

  • Rosie,

    In VB there are many tastes, there is for Visual Studio, VB for Applications, VBscript, VB for MVC and more. 

    Your seems to be VB for Application, I would advice you to visit that forum. This forum is for VB in Visual Studio


    Thursday, June 22, 2017 2:44 PM
  • Since this is a Microsoft Access application your question needs to be moved (or re-posted) in the Access for Developers forum.

    Paul ~~~~ Microsoft MVP (Visual Basic)

    Friday, June 23, 2017 11:51 AM
  • Would you like me or another moderator to move your question to the Access for a developer's forum?

    Please remember to mark the replies as answers if they help and unmark them if they provide no help, this will help others who are looking for solutions to the same or similar problem. Contact via my Twitter (Karen Payne) or Facebook (Karen Payne) via my MSDN profile but will not answer coding question on either.
    VB Forums - moderator
    profile for Karen Payne on Stack Exchange, a network of free, community-driven Q&A sites

    Friday, June 23, 2017 3:18 PM