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

[VBRosie]

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.

here is the code that we currently have from 2010 to try to get the body.

Any thoughts?

strEmailbody = ActiveInspector.CurrentItem.Body

Error message is a runtime error 287

 

[Micron]

That error could be as simple as not having the required reference in your Access vba project. Not sure I would ever do this from Access. How could you be certain that there isn't more than one email open at the same time? Why put the entire body into one table field then try to parse it out?

I doubt anyone could solve this with the tiny snippet of code you provided - unless it turned out to be as simple as a missing Access reference. Do you have one set for Outlook?

 

[VBRosie]

That error could be as simple as not having the required reference in your Access vba project. Not sure I would ever do this from Access. How could you be certain that there isn't more than one email open at the same time? Why put the entire body into one table field then try to parse it out?

I doubt anyone could solve this with the tiny snippet of code you provided - unless it turned out to be as simple as a missing Access reference. Do you have one set for Outlook?

------

Hi Micron,

Here is the larger portion of the Code. Unsure about the Outlook question. Appreciate any assistance you or anyone can give.
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
Else
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
Else
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
Else
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))

 

[Micron]

been busy and just popped in to look after an email the forum sent before I have to run off. In future, please use code tags around more than a few lines of code and use indentation with each block - makes it easier to read than what you have here.
First thing that pops out is your arrays are dimensioned for 23 items, but you attempt to assign 24 (count them).
Second is that you appear to be using Automation to 'connect' to Outlook but don't actually SET the object to anything. Same goes for your recordset objects. Plus, a whole lot of variables don't seem to be used - but you've cut off the code (I don't see the end of the procedure).
Will look deeper later, but I'm not hopeful, especially since I don't know how active.inspector happens to refer to an open email, much less the right one if more than one is open. The email doesn't have to be open anyway AFAIK.

Maybe Google the subject or look here since I've not seen you mention anything about the email being a form, which should make it easier
https://support.office.com/en-us/ar...database-89dc12dc-17c6-4251-bec0-689ba00a48e0

 

[stumac]

Does this need to be done from access.... it would be easier using an outlook macro as you could call from the open email removing the chance of any ambiguity over multiple open emails. I usually link them to a button on the quick access toolbar, however, it would need to be saved & maintained on every machine where the macro is required.

 

[xenou]

First thing that pops out is your arrays are dimensioned for 23 items, but you attempt to assign 24 (count them).

VBA dims arrays by declaring the upper bound, so dim STRCheckedItems(23) as String does allow for 24 elements.

Sub foo()
    Dim a(1)
    a(0) = 1
    a(1) = 2
    Debug.Print a(0)
    Debug.Print a(1)
End Sub

In general I also think it would be simpler to write this as an outlook macro (with the caveat that Outlook in general is a little more complex to script than Access). In theory, I suppose you can set a reference to Outlook from within Access and get the same results - still might be easier to write in Outlook first, then port to Access later.

Trying to get information out of plain text emails is going to be a hit or miss thing at best - too many things can go wrong. We need some Google engineers on this one.

 

[VBRosie]

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.
<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")

objWordApp.Selection.WholeStory
objWordApp.Selection.Copy

objEmailform.Body = ""

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

If objOutlookApp.Version Like "14*" Then
'using sendkeys to put info in mail
SendKeys "%u", True
SendKeys "{TAB}", True
SendKeys "^v", True
Else
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
objWordApp.Quit
'do not want to autosend mail - user will review
objEmailform.Display

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
Else
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
Else
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
Else
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)
Else
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)
Else
STRReturnedItems(9) = strCurrentText
End If

'get POD
lStartNumber = InStr(1, strEmailbody, "Mailing Address:")
lEndNumber = InStr(1, strEmailbody, "City:")
strCurrentText = Mid(strEmailbody, lStartNumber + 20, lEndNumber - lStartNumber - 22)
STRReturnedItems(12) = strCurrentText


'get zip
lStartNumber = InStr(1, strEmailbody, "Zip:")
lEndNumber = InStr(1, strEmailbody, "Disability Group:")
strCurrentText = Mid(strEmailbody, lStartNumber + 8, lEndNumber - lStartNumber - 10)
STRReturnedItems(15) = strCurrentText
'get city
lStartNumber = InStr(1, strEmailbody, "City:")
lEndNumber = InStr(1, strEmailbody, "State:")
strCurrentText = Mid(strEmailbody, lStartNumber + 9, lEndNumber - lStartNumber - 11)
STRReturnedItems(16) = Proper(strCurrentText)
'get state
lStartNumber = InStr(1, strEmailbody, "State:")
lEndNumber = InStr(1, strEmailbody, "Zip:")
strCurrentText = UCase(Mid(strEmailbody, lStartNumber + 10, lEndNumber - lStartNumber - 12))
Select Case strCurrentText
Case Is = "WY", "WV", "WI", "WA", "VT", "VA", "UT", "TX", "TN", "SD", "SC", "RI", "PR", "PA", "OR", "OK", "OH", "NY", "NV", "NM", "NJ", "NH", "NE", "ND", "NC", "MT", "MS", "MO", "MN", "MI", "ME", "MD", "MA", "LA", "KY", "KS", "IN", "IL", "ID", "IA", "HI", "GA", "FL", "DE", "DC", "CT", "CO", "CA", "AZ", "AR", "AL", "AK"
STRReturnedItems(17) = UCase(strCurrentText)
Case Else
STRReturnedItems(17) = ""
End Select

'RA information will not be shown on the refresh form
If Right(ActiveInspector.CurrentItem.Subject, 7) = "Refresh" Then
Screen.ActiveForm.Controls("Demand") = "Refresh"

'get mail stop/room
lStartNumber = InStr(1, strEmailbody, "Mail Stop / Room No.:")
lEndNumber = InStr(1, strEmailbody, "Mailing Address:")
strCurrentText = Mid(strEmailbody, lStartNumber + 25, lEndNumber - lStartNumber - 27)
STRReturnedItems(14) = strCurrentText
lStartNumber = InStr(1, strEmailbody, "Disability Group:")
lEndNumber = InStr(1, strEmailbody, "Organization:")
strAECategory = Trim(Mid(strEmailbody, lStartNumber + 21, lEndNumber - lStartNumber - 23))
strPrimaryAECategory = strAECategory
'get functional area
lStartNumber = InStr(1, strEmailbody, "Organization:")
lEndNumber = InStr(1, strEmailbody, "Product Being Refreshed:")
If lEndNumber - lStartNumber > 90 Then lEndNumber = InStr(1, strEmailbody, "RA Coordinator:")
strCurrentText = Mid(strEmailbody, lStartNumber + 17, lEndNumber - lStartNumber - 19)
strCurrentText = Replace(strCurrentText, " ", "")
strCurrentText = Replace(strCurrentText, "&", " & ")
'If strCurrentText = "Counsel" Then strCurrentText = "Chief Councel"
STRReturnedItems(13) = strCurrentText
'get mgr email
lStartNumber = InStr(1, strEmailbody, "Manager E-Mail:")
lEndNumber = InStr(1, strEmailbody, "Mail Stop / Room No.:")
strCurrentText = Mid(strEmailbody, lStartNumber + 19, lEndNumber - lStartNumber - 21)
STRReturnedItems(11) = Proper(strCurrentText)
Screen.ActiveForm.Controls("Assessment Type") = strPrimaryAECategory
Else
Screen.ActiveForm.Controls("Demand") = "RA"

'get mail stop/room
lStartNumber = InStr(1, strEmailbody, "Mail Stop / Room Number:")
lEndNumber = InStr(1, strEmailbody, "Mailing Address:")
strCurrentText = Mid(strEmailbody, lStartNumber + 27, lEndNumber - lStartNumber - 27)
STRReturnedItems(14) = strCurrentText
'get mgr email
lStartNumber = InStr(1, strEmailbody, "Manager E-Mail:")
lEndNumber = InStr(1, strEmailbody, "Mail Stop / Room Number:")
strCurrentText = Mid(strEmailbody, lStartNumber + 19, lEndNumber - lStartNumber - 21)
STRReturnedItems(11) = Proper(strCurrentText)

'get functional area
lStartNumber = InStr(1, strEmailbody, "Organization:")
lEndNumber = InStr(1, strEmailbody, "RA Coordinator:")
If lEndNumber - lStartNumber > 90 Then lEndNumber = InStr(1, strEmailbody, "RA Coordinator:")
strCurrentText = Mid(strEmailbody, lStartNumber + 17, lEndNumber - lStartNumber - 19)
strCurrentText = Replace(strCurrentText, " ", "")
strCurrentText = Replace(strCurrentText, "&", " & ")
'If strCurrentText = "Counsel" Then strCurrentText = "Chief Councel"
STRReturnedItems(13) = strCurrentText
lStartNumber = InStr(1, strEmailbody, "Blindness:")
lEndNumber = InStr(1, strEmailbody, "HardofHearing:")
strCurrentText = Mid(strEmailbody, lStartNumber + 10, lEndNumber - lStartNumber - 10)
If strCurrentText Like "*on*" Then
strAECategory = ", Blindness"
strPrimaryAECategory = "Blindness"
byteIsBlind = True
Else
End If
lStartNumber = InStr(1, strEmailbody, "HardofHearing:")
lEndNumber = InStr(1, strEmailbody, "Learning:")
strCurrentText = Mid(strEmailbody, lStartNumber + 14, lEndNumber - lStartNumber - 14)
If strCurrentText Like "*on*" Then
strAECategory = strAECategory & ", Hard of Hearing"
byteIsHOH = True
If strPrimaryAECategory = "" Then strPrimaryAECategory = "Hard of Hearing"
Else
End If
lStartNumber = InStr(1, strEmailbody, "Learning:")
lEndNumber = InStr(1, strEmailbody, "LowVision:")
strCurrentText = Mid(strEmailbody, lStartNumber + 9, lEndNumber - lStartNumber - 9)
If strCurrentText Like "*on*" Then
strAECategory = strAECategory & ", Learning"
byteISLD = True
If strPrimaryAECategory = "" Then strPrimaryAECategory = "Learning"
Else
End If
lStartNumber = InStr(1, strEmailbody, "LowVision:")
lEndNumber = InStr(1, strEmailbody, "Mobility:")
strCurrentText = Mid(strEmailbody, lStartNumber + 10, lEndNumber - lStartNumber - 10)
If strCurrentText Like "*on*" Then
strAECategory = strAECategory & ", Low Vision"
byteIsLV = True
If strPrimaryAECategory = "" Then strPrimaryAECategory = "Low Vision"
Else
End If
lStartNumber = InStr(1, strEmailbody, "Mobility:")
lEndNumber = InStr(1, strEmailbody, "Deafness:")
strCurrentText = Mid(strEmailbody, lStartNumber + 9, lEndNumber - lStartNumber - 9)
If strCurrentText Like "*on*" Then
strAECategory = strAECategory & ", Mobility"
byteIsMob = True
If strPrimaryAECategory = "" Then strPrimaryAECategory = "Mobility"
Else
End If
lStartNumber = InStr(1, strEmailbody, "Deafness:")
lEndNumber = InStr(1, strEmailbody, "Organization:")
strCurrentText = Mid(strEmailbody, lStartNumber + 9, lEndNumber - lStartNumber - 9)
If strCurrentText Like "*on*" Then
strAECategory = strAECategory & ", Deafness"
byteIsDeaf = True
If strPrimaryAECategory = "" Then strPrimaryAECategory = "Deafness"
Else
End If


'get RA number
lStartNumber = InStr(1, strEmailbody, "RA Request Number:")
lEndNumber = InStr(1, strEmailbody, "General Comments:")
strCurrentText = Mid(strEmailbody, lStartNumber + 19, lEndNumber - lStartNumber - 21)
STRReturnedItems(18) = strCurrentText

'get RA name
lStartNumber = InStr(1, strEmailbody, "RA Coordinator:")
lEndNumber = InStr(1, strEmailbody, "RA Coordinator Email:")
strCurrentText = Mid(strEmailbody, lStartNumber + 16, lEndNumber - lStartNumber - 18)
STRReturnedItems(19) = Proper(Left(strCurrentText, InStr(1, strCurrentText, " ") - 1))
STRReturnedItems(20) = Proper(Mid(strCurrentText, InStrRev(strCurrentText, " ") + 1))
'get ra coordinator email
lStartNumber = InStr(1, strEmailbody, "RA Coordinator Email:")
lEndNumber = InStr(1, strEmailbody, "RA Coordinator Phone:")
strCurrentText = Mid(strEmailbody, lStartNumber + 22, lEndNumber - lStartNumber - 24)
STRReturnedItems(21) = Proper(strCurrentText)
'get ra coordinator phone
lStartNumber = InStr(1, strEmailbody, "RA Coordinator Phone:")
lEndNumber = InStr(1, strEmailbody, "RA Request Number:")
strCurrentText = Mid(strEmailbody, lStartNumber + 22, lEndNumber - lStartNumber - 24)
STRReturnedItems(22) = strCurrentText
End If
On Error Resume Next
'write the strings to the form
For i = 0 To 23
If STRReturnedItems(i) <> "" Then Screen.ActiveForm.Controls(STRCheckedItems(i)) = STRReturnedItems(i)

Next i
On Error Resume Next
Screen.ActiveForm.Controls("GONE").SetFocus
Screen.ActiveForm.Controls("GONE") = "No"
'if the user has entered a valid POD from the POD list, the POD will be updated to be the same as Address 2
Screen.ActiveForm.Controls("Address 2").SetFocus
Set rectempset = CurrentDb.OpenRecordset(Name:="SELECT [Post of Duty DD].[POD Street Address], [Post of Duty DD].[POD City], [Post of Duty DD].[POD State], [Post of Duty DD].[POD Territory] FROM [Post of Duty DD] WHERE [Post of Duty DD].[POD Street Address] = '" & Screen.ActiveForm.Controls("Address 2").Text & "'")
Screen.ActiveForm.Controls("Post of Duty") = "Depot 2021 East Woodward St."
rectempset.Close
Set rectempset = Nothing
On Error GoTo 0

'get disability group - will be needed to determine who gets assignment
lStartNumber = InStr(1, strEmailbody, "Disability Group:")
lEndNumber = InStr(1, strEmailbody, "Organization:")
strAECategory = Trim(Mid(strEmailbody, lStartNumber + 21, lEndNumber - lStartNumber - 23))
Randomize
Select Case strPrimaryAECategory
Case "Deafness", "Deaf", "Hard of Hearing"
Set recEmpAssignRecs = CurrentDb.OpenRecordset("SELECT * FROM [IRAP Employees] WHERE [Deaf/HoH Assess] = True")

Case "Blind", "Blindness", "Low Vision"
Set recEmpAssignRecs = CurrentDb.OpenRecordset("SELECT * FROM [IRAP Employees] WHERE [LV/Blind Assess] = True")

Case "Mobility"
Set recEmpAssignRecs = CurrentDb.OpenRecordset("SELECT * FROM [IRAP Employees] WHERE [Mobility Assess] = True")
Case "Learning Disability", "Learning"
Set recEmpAssignRecs = CurrentDb.OpenRecordset("SELECT * FROM [IRAP Employees] WHERE [LD Assess] = True")
End Select
recEmpAssignRecs.MoveLast
recEmpAssignRecs.MoveFirst
recEmpAssignRecs.Move (Int(recEmpAssignRecs.RecordCount * Rnd))
Screen.ActiveForm.Controls("Assigned To") = recEmpAssignRecs.Fields("First Name")
'determine assessment type
'if more than 3 disabilities, call it multiple
If CInt(byteIsBlind) + CInt(byteIsDeaf) + CInt(byteISLD) + CInt(byteIsHOH) + CInt(byteIsLV) + CInt(byteIsMob) > 700 Then
Screen.ActiveForm.Controls("Assessment Type") = "Multiple"
Else
If byteIsBlind Then
Screen.ActiveForm.Controls("Assessment Type") = "Blind"
If byteIsDeaf Then Screen.ActiveForm.Controls("Assessment Type") = "Blind/Deaf"
If byteIsHOH Then Screen.ActiveForm.Controls("Assessment Type") = "Blind/HOH"
If byteISLD Then Screen.ActiveForm.Controls("Assessment Type") = "Blind/LD"
If byteIsLV Then Screen.ActiveForm.Controls("Assessment Type") = "Blind/LV"
If byteIsMob Then Screen.ActiveForm.Controls("Assessment Type") = "Blind/Mob"
Else
If byteIsLV Then
Screen.ActiveForm.Controls("Assessment Type") = "Low Vision"
If byteIsDeaf Then Screen.ActiveForm.Controls("Assessment Type") = "LV/Deaf"
If byteIsHOH Then Screen.ActiveForm.Controls("Assessment Type") = "LV/HOH"
If byteISLD Then Screen.ActiveForm.Controls("Assessment Type") = "LV/LD"
If byteIsMob Then Screen.ActiveForm.Controls("Assessment Type") = "LV/Mob"
Else
If byteIsDeaf Then
Screen.ActiveForm.Controls("Assessment Type") = "Deaf"
If byteIsHOH Then Screen.ActiveForm.Controls("Assessment Type") = "Deaf/HOH"
If byteISLD Then Screen.ActiveForm.Controls("Assessment Type") = "Deaf/LD"
If byteIsMob Then Screen.ActiveForm.Controls("Assessment Type") = "Deaf/Mob"
Else
If byteISLD Then
Screen.ActiveForm.Controls("Assessment Type") = "Learning Disability"
If byteIsHOH Then Screen.ActiveForm.Controls("Assessment Type") = "LD/HOH"
If byteIsMob Then Screen.ActiveForm.Controls("Assessment Type") = "LD/Mob"

Else
If byteIsHOH Then
Screen.ActiveForm.Controls("Assessment Type") = "Hard of Hearing"
If byteIsMob Then Screen.ActiveForm.Controls("Assessment Type") = "HOH/Mob"
Else
If byteIsMob Then Screen.ActiveForm.Controls("Assessment Type") = "Mobility"
End If

End If
End If

End If
End If


End If
'set todays date
Screen.ActiveForm.Controls("Request Date") = CDate(Int(Now))

End Sub


Sub ResponseMail()
Dim objOutlookApp As Outlook.Application
Dim objPriorEmail As Outlook.MailItem
Dim objOurReply As Outlook.MailItem
Dim strResponseText As String
Dim strAssignedTo As String
Dim i As Integer
Dim iStartHere As Integer
Dim iEndHere As Integer
Dim strRemovedText As String
Dim recEmpAssignRecs As Recordset
'if an email isn't open in outlook, abort
If ActiveInspector Is Nothing Then
MsgBox ("You must open the Request for Adaptive Equipment email.")
Exit Sub
Else
End If

Set objPriorEmail = ActiveInspector.CurrentItem
'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
Else
End If
Set recEmpAssignRecs = CurrentDb.OpenRecordset("SELECT * FROM [IRAP Employees] WHERE [First Name] = '" & Screen.ActiveForm.Controls("Assigned to") & "'")
Set objOurReply = objPriorEmail.Reply
objOurReply.Display
'code to remove any signatures
'removes all html from the body tag to the outlook reply header
iStartHere = InStr(1, objOurReply.HTMLBody, "******>") + 6
iEndHere = InStr(1, objOurReply.HTMLBody, "

")
If iEndHere = 0 Then iEndHere = InStr(1, objOurReply.HTMLBody, "")
If iEndHere <> 0 Then
strRemovedText = Mid(objOurReply.HTMLBody, iStartHere, iEndHere - iStartHere)
objOurReply.HTMLBody = Replace(objOurReply.HTMLBody, strRemovedText, "
")
Else
End If

On Error Resume Next
objOurReply.SentOnBehalfOfName = "*IRAP"
objOurReply.Recipients.Add (Screen.ActiveForm.Controls("User Email"))
objOurReply.Recipients.Add (Screen.ActiveForm.Controls("Mgr Email"))
objOurReply.Recipients.Add (Screen.ActiveForm.Controls("RAC Email"))
On Error GoTo 0
'future state - pull info from employee table
strAssignedTo = recEmpAssignRecs.Fields("First Name") & " " & recEmpAssignRecs.Fields("Last Name") & " at " & recEmpAssignRecs.Fields("Work Phone") & ". " & recEmpAssignRecs.Fields("First Name")
If Screen.ActiveForm.Controls("demand") = "Refresh" Then
strResponseText = "Thank you for contacting the IRAP office. Your request, Order #" & Screen.ActiveForm.Controls("Record number") & ", has been assigned to " & strAssignedTo & " will be contacting the customer to discuss this request for replacement equipment. Let us know if you have any questions." & "

" & "Thanks," & "
" & "IRAP"
Else
strResponseText = "Thank you for contacting the IRAP office. Your request, Order #" & Screen.ActiveForm.Controls("Record number") & ", has been assigned to " & strAssignedTo & " will be contacting the customer to schedule a date and time for a needs assessment. Let us know if you have any questions." & "

" & "Thanks," & "
" & "IRAP"
End If
objOurReply.HTMLBody = strResponseText & objOurReply.HTMLBody


End Sub
Sub CreateOffContract()
If InputBox("Type " & Chr(34) & "off" & Chr(34) & " to create an off contract record for this order.") <> "off" Then Exit Sub
Dim ctlTestedControl As Control
Dim objOutlookApp As Outlook.Application
Dim objNewTask As Outlook.TaskItem
Dim objCheckedTask As Outlook.TaskItem
Dim objIRAPFolder As Outlook.MAPIFolder
Dim foundit As Byte
Dim i As Integer
Dim recEmpAssignSet As Recordset
Dim strAssigneeSEID As String
Dim dateCurrentTime As Date

DoCmd.OpenForm ("Off Contract input form")
DoCmd.GoToRecord acDataForm, "Off Contract input form", acNewRec
On Error Resume Next
For Each ctlTestedControl In Forms("Off contract input form").Controls
ctlTestedControl = Forms("RAT input form").Controls(ctlTestedControl.Name)
Next ctlTestedControl
On Error GoTo 0
Set ctlTestedControl = Nothing
Set objOutlookApp = CreateObject("Outlook.Application")
If objOutlookApp.Version Like "14*" Then
Set objIRAPFolder = GetNamespace("MAPI").Folders("*IRAP")
Else
Set objIRAPFolder = GetNamespace("MAPI").Folders("Mailbox - *IRAP")
End If
foundit = 0
For Each objCheckedTask In objIRAPFolder.Folders("*IRAP tasks").Items
If objCheckedTask.Subject Like "*Order [#]" & Forms("Rat input form").Controls("record number") & " --*" Then
foundit = 1
Set objNewTask = objIRAPFolder.Folders("*IRAP tasks").Items.Add(olTaskItem)
objNewTask.Display
objNewTask.DueDate = objCheckedTask.DueDate
objNewTask.startdate = objCheckedTask.startdate
objNewTask.ReminderSet = objCheckedTask.ReminderSet
objNewTask.Categories = Forms("Rat input form").Controls("assigned to")
objNewTask.Subject = Replace(objCheckedTask.Subject, Forms("Rat input form").Controls("record number"), Forms("off contract input form").Controls("off contract Record"))
Set recEmpAssignSet = CurrentDb.OpenRecordset("SELECT * FROM [IRAP Employees] WHERE [First Name] = '" & Forms("Rat input form").Controls("Assigned To") & "'")
strAssigneeSEID = recEmpAssignSet.Fields("SEID")
recEmpAssignSet.Close

objNewTask.Recipients.Add strAssigneeSEID
objNewTask.Assign
'BlockInput True
objOutlookApp.ActiveInspector.Activate

objCheckedTask.Display
objCheckedTask.GetInspector.Activate
For i = 1 To 9
Do While (Now - dateCurrentTime) < 0.00009472
Loop
SendKeys "{TAB}", True
Debug.Print i
Next i


SendKeys "^a", True
dateCurrentTime = Now
Do While (Now - dateCurrentTime) < 0.00001472
Loop
objCheckedTask.GetInspector.Activate
objCheckedTask.Display
SendKeys "^c", True
dateCurrentTime = Now
Do While (Now - dateCurrentTime) < 0.00001472
Loop
objNewTask.GetInspector.Activate

dateCurrentTime = Now
Do While (Now - dateCurrentTime) < 0.00003472
Loop
'SendKeys "%J"
'SendKeys "{TAB 9}"
SendKeys "^v", True
'BlockInput False
objCheckedTask.Close olDiscard

Exit For
Else
End If
Next objCheckedTask
If foundit = 0 Then MsgBox ("Matching task not found. Please create the task manually.")

Set objOutlookApp = Nothing
Set objNewTask = Nothing
Set objCheckedTask = Nothing
Set recEmpAssignSet = Nothing

End Sub

Sub CreateOutlookTask()
'using table
Dim objOutlookApp As Outlook.Application
Dim objPriorEmail As Outlook.MailItem
Dim objOurNewTask As Outlook.TaskItem
Dim objIRAPFolder As Outlook.MAPIFolder
Dim testvar As Object

'Outlook only supports plain text in MailItem.Body
'using Word to edit/format our items
Dim objWordApp As Word.Application
Dim objEmailOutput As Word.Document
Dim objQueryOutput As Word.Document
Dim objSWQueryOutput As Word.Document
Dim objD3QueryOutput As Word.Document
Dim wrkD3Workspace As Workspace
Dim dbD3DB As Database
Dim qryD3SEIDQuery As QueryDef
Dim recD3SEIDQueryResults As Recordset
Dim recEmpAssignSet As Recordset
Dim strCurrentText As String
Dim strAssignerName As String
Dim strAssigneeSEID As String
Dim strEmailbody As String
Dim strAECategory As String
Dim strPrimaryAECategory As String
Dim lStartNumber As Long
Dim lEndNumber As Long
Dim dateCurrentTime As Date
On Error Resume Next
Set objOutlookApp = CreateObject("Outlook.Application")
If objOutlookApp.Version Like "14*" Then
Set objIRAPFolder = GetNamespace("MAPI").Folders("*IRAP")
Set objIRAPFolder = GetNamespace("MAPI").Folders("Mailbox - *IRAP")
Set objIRAPFolder = GetNamespace("mapi").Folders("IRAP@irs.gov")
Else
Set objIRAPFolder = GetNamespace("MAPI").Folders("Mailbox - *IRAP")
End If
On Error GoTo 0
'if an email isn't open in outlook, abort
If ActiveInspector Is Nothing Then
MsgBox ("You must open the Request for Adaptive Equipment email.")
Exit Sub
Else
End If
On Error GoTo a:
Set objPriorEmail = ActiveInspector.CurrentItem
'if the email isn't a request for adaptive equipment, abort
If Left(ActiveInspector.CurrentItem.Subject, 30) <> "Request for Adaptive Equipment" Then
a:
MsgBox ("You must open the Request for Adaptive Equipment email.")
Exit Sub
Else
End If

Set recEmpAssignSet = CurrentDb.OpenRecordset("SELECT * FROM [IRAP Employees] WHERE [seid] = '" & Environ("UserName") & "'")
strAssignerName = recEmpAssignSet.Fields("First Name")
recEmpAssignSet.Close
Set recEmpAssignSet = CurrentDb.OpenRecordset("SELECT * FROM [IRAP Employees] WHERE [First Name] = '" & Screen.ActiveForm.Controls("Assigned To") & "'")
strAssigneeSEID = recEmpAssignSet.Fields("SEID")
recEmpAssignSet.Close

strEmailbody = objPriorEmail.Body

On Error GoTo b:
Set objOutlookApp = CreateObject("Outlook.Application")
Set objWordApp = CreateObject("Word.Application")
Set objD3QueryOutput = objWordApp.Documents.Add

'get disability group - will be needed to determine who gets assignment
If Right(ActiveInspector.CurrentItem.Subject, 7) = "Refresh" Then
lStartNumber = InStr(1, strEmailbody, "Disability Group:")
lEndNumber = InStr(1, strEmailbody, "Organization:")
strPrimaryAECategory = Trim(Mid(strEmailbody, lStartNumber + 21, lEndNumber - lStartNumber - 23))
strAECategory = ", " & strPrimaryAECategory

Else
lStartNumber = InStr(1, strEmailbody, "Blindness:")
lEndNumber = InStr(1, strEmailbody, "HardofHearing:")
strCurrentText = Mid(strEmailbody, lStartNumber + 10, lEndNumber - lStartNumber - 10)
If strCurrentText Like "*on*" Then
strAECategory = ", Blindness"
strPrimaryAECategory = "Blindness"
Else
End If
lStartNumber = InStr(1, strEmailbody, "HardofHearing:")
lEndNumber = InStr(1, strEmailbody, "Learning:")
strCurrentText = Mid(strEmailbody, lStartNumber + 14, lEndNumber - lStartNumber - 14)
If strCurrentText Like "*on*" Then
strAECategory = strAECategory & ", Hard of Hearing"
If strPrimaryAECategory = "" Then strPrimaryAECategory = "Hard of Hearing"
Else
End If
lStartNumber = InStr(1, strEmailbody, "Learning:")
lEndNumber = InStr(1, strEmailbody, "LowVision:")
strCurrentText = Mid(strEmailbody, lStartNumber + 9, lEndNumber - lStartNumber - 9)
If strCurrentText Like "*on*" Then
strAECategory = strAECategory & ", Learning"
If strPrimaryAECategory = "" Then strPrimaryAECategory = "Learning"
Else
End If
lStartNumber = InStr(1, strEmailbody, "LowVision:")
lEndNumber = InStr(1, strEmailbody, "Mobility:")
strCurrentText = Mid(strEmailbody, lStartNumber + 10, lEndNumber - lStartNumber - 10)
If strCurrentText Like "*on*" Then
strAECategory = strAECategory & ", Low Vision"
If strPrimaryAECategory = "" Then strPrimaryAECategory = "Low Vision"
Else
End If
lStartNumber = InStr(1, strEmailbody, "Mobility:")
lEndNumber = InStr(1, strEmailbody, "Deafness:")
strCurrentText = Mid(strEmailbody, lStartNumber + 9, lEndNumber - lStartNumber - 9)
If strCurrentText Like "*on*" Then
strAECategory = strAECategory & ", Mobility"
If strPrimaryAECategory = "" Then strPrimaryAECategory = "Mobility"
Else
End If
lStartNumber = InStr(1, strEmailbody, "Deafness:")
lEndNumber = InStr(1, strEmailbody, "Organization:")
strCurrentText = Mid(strEmailbody, lStartNumber + 9, lEndNumber - lStartNumber - 9)
If strCurrentText Like "*on*" Then
strAECategory = strAECategory & ", Deafness"
If strPrimaryAECategory = "" Then strPrimaryAECategory = "Deafness"
Else
End If

End If


'we are creating up to 3 temp files in c:\temp - they get combined to create email
If objOutlookApp.Version Like "14*" Then
objPriorEmail.SaveAs Path:="c:\temp\tempmail.rtf", Type:=olRTF
Else
objPriorEmail.SaveAs Path:="c:\temp\tempmail.doc", Type:=olHTML
End If
BlockInput True
'query for all entries on this seid
'output the query as html
DoCmd.OpenQuery queryname:="Query Menu - SEID Query - GM"
'check to see if the query returned anything
If Screen.ActiveDatasheet.Recordset.RecordCount > 0 Then

'if it did, save the results to word doc
If objOutlookApp.Version Like "14*" Then
DoCmd.OutputTo objecttype:=acOutputQuery, outputformat:=acFormatRTF, outputfile:="c:\temp\tempquery.rtf"
Else
DoCmd.OutputTo objecttype:=acOutputQuery, outputformat:=acFormatHTML, outputfile:="c:\temp\tempquery.doc"
End If
DoCmd.Close acQuery, "Query Menu - SEID Query - GM"

Else
'if it didn't, make a blank word doc stating there are no orders in d4
Set objQueryOutput = objWordApp.Documents.Add
objQueryOutput.Range(Start:=0, End:=0).InsertAfter Text:=("No prior orders in D4.")
If objOutlookApp.Version Like "14*" Then
objQueryOutput.SaveAs "c:\temp\tempquery.rtf"
Else
objQueryOutput.SaveAs "c:\temp\tempquery.doc"
End If
objQueryOutput.Close savechanges:=False
DoCmd.Close acQuery, "Query Menu - SEID Query - GM"
End If
'same thing for software query
DoCmd.OpenQuery queryname:="Query Menu - Software Spreadsheet SEID or Last Name - GM"
If Screen.ActiveDatasheet.Recordset.RecordCount > 0 Then
If objOutlookApp.Version Like "14*" Then
DoCmd.OutputTo objecttype:=acOutputQuery, outputformat:=acFormatRTF, outputfile:="c:\temp\tempswqry.rtf"
Else
DoCmd.OutputTo objecttype:=acOutputQuery, outputformat:=acFormatHTML, outputfile:="c:\temp\tempswqry.doc"
End If
DoCmd.Close acQuery, "Query Menu - Software Spreadsheet SEID or Last Name - GM"
Else
Set objSWQueryOutput = objWordApp.Documents.Add
If objOutlookApp.Version Like "14*" Then
objSWQueryOutput.SaveAs "c:\temp\tempswqry.rtf"
Else
objSWQueryOutput.SaveAs "c:\temp\tempswqry.doc"
End If
objSWQueryOutput.Close savechanges:=False
DoCmd.Close acQuery, "Query Menu - Software Spreadsheet SEID or Last Name - GM"
End If
'setup for external query to D3
Set wrkD3Workspace = CreateWorkspace("", "admin", "")
Set dbD3DB = wrkD3Workspace.OpenDatabase("\\NCT0010VPSCC1\common\MITS\ACIO\StratPlan\Isocsp\teams\Adaptive Technology\DESAC 3\desac 3 database.mdb")
Set qryD3SEIDQuery = dbD3DB.QueryDefs("SEID Query for All Orders-CLINs and Serial Numbers")
'use the SEID from RAT form as the query parameter
qryD3SEIDQuery.Parameters(0).Value = Forms("RAT Input Form").Controls("SEID")
Set recD3SEIDQueryResults = qryD3SEIDQuery.OpenRecordset

If recD3SEIDQueryResults.RecordCount > 0 Then
'if we have records, create a word table to hold them
objD3QueryOutput.Tables.Add Range:=objD3QueryOutput.Range(Start:=0, End:=0), numrows:=1, numcolumns:=6

'make the table pretty
objD3QueryOutput.Tables(1).AllowAutoFit = True
With objD3QueryOutput.Tables(1)
With .Borders(wdBorderLeft)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth050pt
.Color = wdColorAutomatic
End With
With .Borders(wdBorderRight)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth050pt
.Color = wdColorAutomatic
End With
With .Borders(wdBorderTop)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth050pt
.Color = wdColorAutomatic
End With
With .Borders(wdBorderBottom)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth050pt
.Color = wdColorAutomatic
End With
With .Borders(wdBorderVertical)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth075pt
.Color = wdColorAutomatic
End With
.Borders(wdBorderDiagonalDown).LineStyle = wdLineStyleNone
.Borders(wdBorderDiagonalUp).LineStyle = wdLineStyleNone
.Borders.Shadow = False
End With
'title each section
objD3QueryOutput.Tables(1).Rows(1).Cells(1).Range.Text = "D3 Order No"
objD3QueryOutput.Tables(1).Rows(1).Cells(2).Range.Text = "Last"
objD3QueryOutput.Tables(1).Rows(1).Cells(3).Range.Text = "First"
objD3QueryOutput.Tables(1).Rows(1).Cells(4).Range.Text = "Serial"
objD3QueryOutput.Tables(1).Rows(1).Cells(5).Range.Text = "CLIN"
objD3QueryOutput.Tables(1).Rows(1).Cells(6).Range.Text = "Desc"

'loop through the records and make a row for each instance of this seid in D3
Do While Not recD3SEIDQueryResults.EOF
On Error Resume Next
objD3QueryOutput.Tables(1).Rows.Add
objD3QueryOutput.Tables(1).Rows(objD3QueryOutput.Tables(1).Rows.Count).Cells(1).Range.Text = CStr(recD3SEIDQueryResults.Fields(0))
objD3QueryOutput.Tables(1).Rows(objD3QueryOutput.Tables(1).Rows.Count).Cells(2).Range.Text = CStr(recD3SEIDQueryResults.Fields(1))
objD3QueryOutput.Tables(1).Rows(objD3QueryOutput.Tables(1).Rows.Count).Cells(3).Range.Text = CStr(recD3SEIDQueryResults.Fields(2))
objD3QueryOutput.Tables(1).Rows(objD3QueryOutput.Tables(1).Rows.Count).Cells(4).Range.Text = CStr(recD3SEIDQueryResults.Fields(3))
objD3QueryOutput.Tables(1).Rows(objD3QueryOutput.Tables(1).Rows.Count).Cells(5).Range.Text = CStr(recD3SEIDQueryResults.Fields(4))
objD3QueryOutput.Tables(1).Rows(objD3QueryOutput.Tables(1).Rows.Count).Cells(6).Range.Text = CStr(recD3SEIDQueryResults.Fields(5))

recD3SEIDQueryResults.MoveNext
On Error GoTo b:
Loop
'save the file
If objOutlookApp.Version Like "14*" Then
objD3QueryOutput.SaveAs ("c:\temp\tempd3.docx")
Else
objD3QueryOutput.SaveAs ("c:\temp\tempd3.doc")
End If
objD3QueryOutput.Close savechanges:=False
Else
'if no query results, make a word doc saying so...
objD3QueryOutput.Range(Start:=0, End:=0).InsertAfter Text:=("No prior orders in D3.")
If objOutlookApp.Version Like "14*" Then
objD3QueryOutput.SaveAs ("c:\temp\tempd3.docx")
Else
objD3QueryOutput.SaveAs ("c:\temp\tempd3.doc")
End If
objD3QueryOutput.Close savechanges:=False
End If
'copy the d4query
If objOutlookApp.Version Like "14*" Then
Set objQueryOutput = objWordApp.Documents.Open("c:\temp\tempquery.rtf")
Else
Set objQueryOutput = objWordApp.Documents.Open("c:\temp\tempquery.doc")
End If
objQueryOutput.Activate
If objQueryOutput.Tables.Count > 0 Then
objWordApp.Selection.HomeKey Unit:=wdLine
objWordApp.Selection.SplitTable
objWordApp.Selection.TypeParagraph
Else
End If

objWordApp.Selection.WholeStory
objWordApp.Selection.Copy
'paste it into the word doc with the original email from *IRAP
If objOutlookApp.Version Like "14*" Then
Set objEmailOutput = objWordApp.Documents.Open("c:\temp\tempmail.rtf")
Else
Set objEmailOutput = objWordApp.Documents.Open("c:\temp\tempmail.doc")
End If
objEmailOutput.Range(Start:=0, End:=0).InsertAfter Text:=Chr(10)
objEmailOutput.Range(Start:=0, End:=0).Paste

objQueryOutput.Close savechanges:=False
'copy in the software query
If objOutlookApp.Version Like "14*" Then
Set objSWQueryOutput = objWordApp.Documents.Open("c:\temp\tempswqry.rtf")
Else
Set objSWQueryOutput = objWordApp.Documents.Open("c:\temp\tempswqry.doc")
End If
objSWQueryOutput.Activate
If objSWQueryOutput.Tables.Count > 0 Then
objWordApp.Selection.HomeKey Unit:=wdLine
objWordApp.Selection.SplitTable
objWordApp.Selection.TypeParagraph
Else
End If

objWordApp.Selection.WholeStory
objWordApp.Selection.Copy
objEmailOutput.Range(Start:=0, End:=0).InsertAfter Text:=Chr(10)
objEmailOutput.Range(Start:=0, End:=0).Paste

objSWQueryOutput.Close savechanges:=False
'copy the d3query
If objOutlookApp.Version Like "14*" Then
objWordApp.Documents.Open ("c:\temp\tempd3.docx")
Else
objWordApp.Documents.Open ("c:\temp\tempd3.doc")
End If
objWordApp.Selection.WholeStory
objWordApp.Selection.Copy
'paste it into the word doc
objEmailOutput.Range(Start:=0, End:=0).InsertAfter Text:=Chr(10)
objEmailOutput.Range(Start:=0, End:=0).Paste

'copy the word doc - now has both queries and the email
objEmailOutput.Activate
objWordApp.Selection.WholeStory
objWordApp.Selection.Copy
'create a new task
BlockInput False
Set objOurNewTask = objIRAPFolder.Folders("*IRAP tasks").Items.Add(olTaskItem)

On Error GoTo 0
objOurNewTask.Display
objOurNewTask.GetInspector.Activate
AppActivate ("Untitled - Task")

'pause (approx 2 seconds)
dateCurrentTime = Now
Do While (Now - dateCurrentTime) < 0.00003472
Loop
If IsNull(Screen.ActiveForm.Controls("User Phone")) Then
objOurNewTask.Subject = "Order #" & Screen.ActiveForm.Controls("Order Number") & " -- " & CStr(Screen.ActiveForm.Controls("User First Name")) & " " & CStr(Screen.ActiveForm.Controls("User Last Name")) & strAECategory
Else
objOurNewTask.Subject = "Order #" & Screen.ActiveForm.Controls("Order Number") & " -- " & CStr(Screen.ActiveForm.Controls("User First Name")) & " " & CStr(Screen.ActiveForm.Controls("User Last Name")) & strAECategory & " -- " & CStr(Screen.ActiveForm.Controls("User Phone"))
End If
objOurNewTask.DueDate = CDate(Int(Now()) + 14)
objOurNewTask.startdate = CDate(Int(Now()))
objOurNewTask.ReminderSet = False
objOurNewTask.Categories = Screen.ActiveForm.Controls("Assigned To")
Select Case strPrimaryAECategory
Case "Deafness", "Deaf", "Hard of Hearing", "Blind", "Blindness", "Low Vision", "Learning Disability", "Learning"
objOurNewTask.TotalWork = 120

Case "Mobility"
objOurNewTask.TotalWork = 180

Case Else
End Select
objOurNewTask.Recipients.Add strAssigneeSEID
objOurNewTask.Assign
BlockInput True

'pause (approx 3 seconds)
dateCurrentTime = Now

objOurNewTask.GetInspector.Activate
objOurNewTask.Display
Do While (Now - dateCurrentTime) < 0.00006472
Loop
'can't set focus to the task body in Outlook easily
'so we use sendkeys to paste the word doc into our task
If objOutlookApp.Version Like "14*" Then
SendKeys "%u", True
SendKeys "{TAB}{TAB}{TAB}{TAB}{TAB}{TAB}{TAB}{TAB}", True
Else

SendKeys "{TAB}{TAB}{TAB}{TAB}{TAB}{TAB}{TAB}{TAB}{TAB}", True
End If
SendKeys Month(Now) & "/" & Day(Now) & " - Assigned to " & objOurNewTask.Categories & " by " & strAssignerName
SendKeys "{ENTER}"
SendKeys "{ENTER}"

dateCurrentTime = Now
Do While (Now - dateCurrentTime) < 0.00003472

Loop
SendKeys "^v", True
dateCurrentTime = Now
Do While (Now - dateCurrentTime) < 0.00001472
Loop
SendKeys "+{TAB} ", False
Do While (Now - dateCurrentTime) < 0.00003472
Loop

b:
'done with word/access objects
On Error Resume Next
BlockInput False
objWordApp.Quit savechanges:=wdDoNotSaveChanges
If Not dbD3DB Is Nothing Then dbD3DB.Close
If Not wrkD3Workspace Is Nothing Then wrkD3Workspace.Close


End Sub


​

</code>

 

[VBRosie]

Thanks for your feedback. I am hoping for a quick fix in Access first before going alternative route in Outlook.

 

[stumac]

Edit - forgot to add .Body

Thanks for your feedback. I am hoping for a quick fix in Access first before going alternative route in Outlook.

Fair play! it is quite a lot to convert.

Can you try replacing:

[FONT=Courier New][COLOR=#0000cd][B]strEmailbody = ActiveInspector.CurrentItem.Body[/B][/COLOR][/FONT]

with

[B][FONT=Courier New][COLOR=#0000cd]strEmailbody = ActiveExplorer.Selection.Item(1).Body[/COLOR][/FONT][/B]

 

[VBRosie]

I replaced and got the following run-time error: '-2147467259 (80004005)': Method 'body' of object'_Mailitem' failed