Automating Text Extraction from Outlook to Excel - excel

I'm a little out of my depth here, and definitely fumbling my way through trying to do this.
Scenario:
Emails arrive in a shared inbox every day for every new hire into the org. This is the full body of one of those emails:
The following are the new user details:
Full Name: Martha Washington
Employee ID: 123456
Department: Nursing Education and Research
Division: 17
RC: 730216
Job Title: Clin Nurse PRN Dept
Location: Medical Office Bldg West
Username: 12345678
I need to make/modify a script that will take only 3 lines out of this email body, and put them into columns in Excel. I need to get the Username value, the Job Title value, and the Location values and put them into separate columns. Then, the next email that arrives needs the same data extracted and put in a new row in Excel.
I want the Excel file to look something like this:
Username
JobTitle
Location
gwashing
President
Michigan
mwashing
Wife
New York
Any and all help is appreciated!

The Outlook object model provides the NewMailEx event of the Application class which is fired when a new message arrives in the Inbox and before client rule processing occurs. Use the Entry ID represented by the EntryIDCollection string to call the NameSpace.GetItemFromID method and process the item. This event fires once for every received item that is processed by Microsoft Outlook. The item can be one of several different item types, for example, MailItem, MeetingItem, or SharingItem. So, in the NewMailEx event you can get an instance of the incoming email where you could extract all the required information from the message body.
The Outlook object model provides three main ways for working with item bodies:
Body.
HTMLBody.
The Word editor. The WordEditor property of the Inspector class returns an instance of the Word Document which represents the message body.
See Chapter 17: Working with Item Bodies for more information.

I have something similar in my outlook application.
So this is Outlook VBA:
Sub Provtagning(msg As Outlook.MailItem)
Dim RE As Object
Dim objFolder As Outlook.MAPIFolder
Dim xExcelFile As String
Dim xExcelApp As Excel.Application
Dim wb As Excel.Workbook
xExcelFile = "Path to file"
' wait for file to be closed (if multiple mails arrive at the same time)
While IsWorkBookOpen(xExcelFile)
WasteTime (1)
Wend
DoEvents
Set xExcelApp = CreateObject("Excel.Application")
Set wb = xExcelApp.Workbooks.Open(xExcelFile)
Set RE = CreateObject("vbscript.regexp")
lrow = wb.Sheets("Sheet1").Cells(wb.Sheets("Sheet1").rows.Count, "A").End(xlUp).Row + 1
RE.Pattern = "Username:\s(\d+)"
Set allMatches = RE.Execute(msg.Body)
username = allMatches.Item(0).SubMatches.Item(0)
RE.Pattern = "Job Title:\s([a-zA-Z ]+)"
Set allMatches = RE.Execute(msg.Body)
title = allMatches.Item(0).SubMatches.Item(0)
RE.Pattern = "Location:\s([a-zA-Z ]+)"
Set allMatches = RE.Execute(msg.Body)
location = allMatches.Item(0).SubMatches.Item(0)
wb.Sheets("Sheet1").Range("A" & lrow).Value = username
wb.Sheets("Sheet1").Range("B" & lrow).Value = title
wb.Sheets("Sheet1").Range("C" & lrow).Value = location
wb.Save
wb.Close
End Sub
Sub WasteTime(Finish As Long)
Dim NowTick As Long
Dim EndTick As Long
EndTick = GetTickCount + (Finish * 1000)
Do
NowTick = GetTickCount
DoEvents
Loop Until NowTick >= EndTick
End Sub
Function IsWorkBookOpen(FileName As String)
Dim ff As Long, ErrNo As Long
On Error Resume Next
ff = FreeFile()
Open FileName For Input Lock Read As #ff
Close ff
ErrNo = Err
On Error GoTo 0
Select Case ErrNo
Case 0: IsWorkBookOpen = False
Case 70: IsWorkBookOpen = True
Case Else: Error ErrNo
End Select
End Function
You may need to adjust the regex patterns if there is something that is different.
Then just create a rule in Outlook to run this script on every email that is from SomeEmail or whatever that is the trigger.

Related

Vba vba runtime error -1802485755(94904005) [duplicate]

This question already has answers here:
MailItem.GetInspector.WordEditor in Office 2016 generates Application-defined or object defined error
(4 answers)
Closed 3 months ago.
i have a strange problem, vba return me the error vba runtime error -1802485755(94904005) and i searched on internet and i found nothing, so i am tring to ask here if someone can help me
here is the code
Private Sub CommandButton3_Click()
Dim str As New Classe1
Dim ricerca As String
Dim dmi As outlook.MailItem
Dim UTCdate As Date, UTCdate2 As Date
Dim out As outlook.Application
Dim DATA1 As Date
Dim DATA2 As Date
Dim errorN As Long
On Error GoTo FormatoErrato:
DATA1 = DateAdd("h", 1, Res.DataStart.Value)
DATA2 = DateAdd("h", 23, Res.DataEnd.Value)
On Error GoTo 0
Set out = New outlook.Application
Set dmi = out.CreateItem(olMailItem)
UTCdate = dmi.PropertyAccessor.LocalTimeToUTC(DATA1)
UTCdate2 = dmi.PropertyAccessor.LocalTimeToUTC(DATA2)
ricerca = "#SQL=""urn:schemas:httpmail:subject"" LIKE '%sometext%'" & _
" AND ""urn:schemas:httpmail:datereceived"" <= '" & UTCdate2 & "'" & _
" AND ""urn:schemas:httpmail:datereceived"" >= '" & UTCdate & "'"
str.prova (ricerca)
FormatoErrato:
errorN = Err.Number
If errorN = 13 Then
MsgBox "invalid format", vbCritical
End If
End Sub
this code (in a class module) is on a userform button where you set two dates and then the following code search the emails that strike the requirments
Sub prova(val As String)
Res.Mezzi.Clear
Dim fol As outlook.Folder
Dim arr, arr2
Dim ricerca As String, txt As String
Dim n As Long, s As Long, tot As Long, l As Long
Dim mi As outlook.MailItem
Dim i As Object
Dim doc As Word.Document
Set fol = 'outlook folder path'
s = 0
n = 1
ReDim Preserve arr2(0 To s)
For Each i In fol.Items.Restrict(val)
If i.Class = olMail Then
Set mi = i
Set doc = mi.GetInspector.WordEditor
If doc.Tables.Count > 0 Then
For tot = 1 To doc.Tables.Count
arr2(s) = Application.WorksheetFunction.Clean(doc.Tables(tot).Cell(2, 2).Range.Text)
s = s + 1
ReDim Preserve arr2(0 To s)
Next tot
End If
End If
Next i
For s = 0 To UBound(arr2)
If IsEmpty(arr2(s)) = False And arr2(s) <> "" Then
Res.Mezzi.AddItem arr2(s)
End If
Next s
End Sub
the email that i'm looking for has a table, one or more in it so i used getinspector.wordeditor to check if the table exist and then take the data that i need from it.
the sub works fine if the difference between the dates is just few days if i put a week give that error
coudl you help me to solve the problem or work around it?
thanks in advance
I didn't find any information which Office version is installed on the system. So, if you have a pretty old version of MS Office installed the following case makes sense - the WordEditor property is only valid if the IsWordMail method returns True and the EditorType property is olEditorWord.
The most-likely possible reason for such errors at runtime is security settings when dealing with the Outlook object model. The message body is a protected property in the Outlook object model which can generate errors when Outlook is automated from an external application. You can find the list of protected properties described on the Protected Properties and Methods page.
So, the Object Model Guard warns users and prompts users for confirmation when untrusted applications attempt to use the object model to obtain email address information, store data outside of Outlook, execute certain actions, and send email messages. If, for any reason, the warning is not appropriate or can't be displayed, the Outlook object model may generate errors when accessing protected properties.
In your scenario you can:
Use a low-level API which doesn't trigger security issues in the Outlook object model - Extended MAPI or any other third-party wrapper around that API.
Create a COM add-in which has access to the trusted Application object and which doesn't trigger security issues.
Install any AV with the latest updates.
Use group policy settings to setup security settings to not trigger security issues.
after many trials i think i solved
to avoid to raise the error i should close the inspector.
in this way:
If i.Class = olMail Then
Set mi = i
Set insp = mi.GetInspector
Set doc = insp.WordEditor
If doc.Tables.Count > 0 Then
For tot = 1 To doc.Tables.Count
arr2(s) = Application.WorksheetFunction.Clean(doc.Tables(tot).Cell(2, 2).Range.Text)
s = s + 1
ReDim Preserve arr2(0 To s)
Next tot
End If
End If
insp.Close olSave
now all seems to work fine even with range of 10 days of emails

Word remains in the background despite the "Active" function VBA

I need to make barcode label sheets for items. For this I use Excel with VBA and a "user form" to help the user in entering the number and information of bar codes. Once I have all my information for my barcodes, I transfer its information to a Word in which I format it to make printable labels.
My system works fine, although a bit long when there are a large number of labels to transfer, but once word and excel have been closed once when I want to restart the transfers, Word no longer comes to the fore , which makes me completely miss the transfer. I am using the tab key which is the main source of the problem.
I have tried performing the same actions as the tab key with other commands like "next" so that it is no longer a problem. However this does not work entirely because the tab key allows at the end of a page to continue the layouts on a new page which the "next" function does not do.
So my questions are: How can I force Word to come to the fore? Can we replace the tab key with another parameter that allows me to do the same thing?
I provide you below the code of my loop performing the transfer.
Dim appwd As Word.Application
Dim oDoc As Object
Dim Code As String, SKU As String, Name As String, Size As String
Dim DerLign As Byte
With Sheets("Reference")
DerLign = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
End With
On Error Resume Next
Set appwd = GetObject(, "Word.Application")
If Err Then
Set appwd = New Word.Application
End If
On Error GoTo 0
With appwd
If .Documents.Count = 0 Then
.Documents.Add
End If
Set oDoc = .MailingLabel.CreateNewDocument("3474")
.Visible = True
.Activate
' Colle les données dans Word
For i = 8 To DerLign
Code = ThisWorkbook.Worksheets("Reference").Range("B" & i)
SKU = ThisWorkbook.Worksheets("Reference").Range("C" & i)
Name = ThisWorkbook.Worksheets("Reference").Range("D" & i)
Size = ThisWorkbook.Worksheets("Reference").Range("E" & i)
appwd.Selection.ParagraphFormat.Alignment = 1
appwd.Selection.TypeParagraph
appwd.Selection.TypeText Text:=SKU
appwd.Selection.TypeParagraph
appwd.Selection.Font.Name = "Code EAN13"
appwd.Selection.Font.Size = 40
appwd.Selection.TypeText Text:=Code
appwd.Selection.Font.Name = "Calibri"
appwd.Selection.Font.Size = 11
appwd.Selection.TypeParagraph
appwd.Selection.TypeText Text:=Name + " " + Size
SendKeys "{TAB}", False
Next i
End With
End Sub
Regards

Retrieving Outlook email data using Excel VBA

I am trying to grab the following details from the sent items folder with subject "Index Coverage".
Sent by
Sent to
Subject
Sent on (date)
email body
I am using formulas in the sheet with code in the ThisOutlookSession module
Index: =TRIM(MID(G2,SEARCH("Code",G2)+(8+LEN("Code")),20))
Our client: =LEFT(I2,FIND("on",I2)-1)
End client: =LEFT(K2,FIND(".",K2)-1)
Const strFilePath As String = "C:\Users\Public\Documents\Excel\OutlookMailItemsDB.xlsx"
Const strSubjectLineStartWith As String = ""
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
Dim varArray As Variant
Dim strSub As String
Dim strBody As String
Dim strArray() As String
Dim lngLoop As Long
Dim objItem As Object
Dim lngMailCounter As Long
Dim objMItem As MailItem
strArray = Split(EntryIDCollection, ",")
For lngMailCounter = LBound(strArray) To UBound(strArray)
Set objItem = Session.GetItemFromID(strArray(lngMailCounter))
If TypeName(objItem) = "MailItem" And InStr(1, objItem.Subject, strSubjectLineStartWith) And InStr(1, objItem.Body, "") Then
Set objMItem = objItem
With CreateObject("Excel.Application").workbooks.Open(strFilePath)
With .sheets(1)
With .cells(.rows.Count, 1).End(-4162)(2).resize(1, 7)
.Value = Array(objMItem.SenderEmailAddress, objMItem.To, objMItem.CC, objMItem.BCC, objMItem.Subject, objMItem.ReceivedTime, objMItem.Body)
End With
End With
.Close 1
End With
Set objItem = Nothing
End If
Next lngMailCounter
If Not IsEmpty(strArray) Then
Erase strArray
End If
End Sub
I am able to grab:
sent by
subject
sent on
Body
Index
Our client
End client
I am not able to grab the recipient contact details.
Also the Excel sheet placed on the desktop needs to be saved and closed on its own so that next time it doesn't throw an error that Excel is not closed.
Also it should consider the sent items folder with the following subject line: "Index Coverage".
Also to grab the details for Index, Our client and End client I am using Excel formulas. Is it possible to achieve this via VBA?
First of all, creating a new Excel instance in the NewMailEx event handler each time a new email is received is not really a good idea. I'd suggest keeping a reference when the add-in works (like a singleton) to prevent any additional workload when receiving a new item.
Try to use the Recipients property of the MailItem class instead of using the To, Cc or Bcc fields. The Recipients collection returns a Recipients collection that represents all the recipients for the Outlook item. Use Recipients(index) where index is the name or index number, to return a single Recipient object. The name can be a string representing the display name, the alias, or the full SMTP email address of the recipient.
Finally, to process items added to the sent items folder you need to handle ItemAdd event which is fired when one or more items are added to the specified collection.
Public WithEvents myOlItems As Outlook.Items
Public Sub Initialize_handler()
Set myOlItems = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderSentItems).Items
End Sub
Private Sub myOlItems_ItemAdd(ByVal Item As Object)
' your code for processing the Item object goes there
End Sub

Copy to Excel 2013 creating extra strings

I have a piece of code that runs in outlook. The code runs through the body of email and copies specific words into Excel cells.
The code works just fine in Office 2010, but when i use the code in Office 2013 the words has extra strings copied to excel cells.
Private Sub deffolder_Click()
Unload Me
Dim olapp As Outlook.Application
Dim oAccount As Outlook.Account
Dim fqdn() As String, host() As String, server() As String, y As Long
Dim si() As String, ar() As String, ur() As String, emoc As String
Dim xlapp As Object ' Excel.Application
Dim xlwkb As Object ' Excel.Workbook
Dim folder As Outlook.MAPIFolder, ns As Outlook.NameSpace, tempfol
Dim item As Object
ReDim Preserve ar(n)
ReDim Preserve ur(n)
Dim trigger As String
n = 0
X = 0
Set ns = GetNamespace("MAPI")
For Each oAccount In Application.Session.Accounts
If oAccount = "example#email.com" Then
Set folder = oAccount.DeliveryStore.GetDefaultFolder(olFolderInbox)
start:
If folder.Items.Count > 0 Then
MsgBox "Copying Servers from emails..", vbInformation, "Info"
Set xlapp = CreateObject("Excel.Application") ' New Excel.Application
Set xlwkb = xlapp.Workbooks.Add
For Each item In folder.Items
'Set Sender = item.Sender
If item.Subject Like "test" And item.Sender Like "Tested*" Then
fqdn() = Split(Replace(item.body, "VM IP", "VM Name: "), "VM Name: ")
fqdn(1) = Replace(fqdn(1), vbNewLine, vbNullString)
X = X + 1
'Writing Values in Excel Sheet for Servers from Cloud Emails
xlapp.Cells(X, "A") = fqdn(1)
xlapp.Cells.wraptext = False
End If
End if
End if
Next
The cell value in excel has "expected output" and "*" and "tabspace" included. Any Suggestions/ideas?
By using fqdn(1) = Replace(fqdn(1), "*", vbNullString), i'm able to replace the "astriex" but unable to replace the "tab space" using same method. And in the first place what has caused issue in "office 2013", I wonder!
Did you have a chance to look at the HTML markup of Outlook messages? Are there any difference?
Anyway, you use the Split function to remove additional whitespace, if any. Or just use the Word object model instead.
The Outlook object model provides three main ways for working with item bodies:
Body - a string representing the clear-text body of the Outlook item.
HTMLBody - a string representing the HTML body of the specified item.
Word editor - the Microsoft Word Document Object Model of the message being displayed. The WordEditor property of the Inspector class returns an instance of the Document class from the Word object model which you can use to set up the message body.
You can read more about all these ways in the Chapter 17: Working with Item Bodies. It us up to you which way is to choose to deal with the message body.

Exporting Outlook Email information to Excel Workbook

I receive an automated email message (in Outlook) every time a room is reserved in a scheduling system but then have to go over and mirror that reservation in another system (which necessitates checking each reservation for specific information and searching through the inbox). I am trying to determine if there is a way to pull the information from the message section (I have found some code that pulls the date received, and subject line as well as read status, but cannot determine how to pull the message body information that I need)
The code that I am running is courtesy of Jie Jenn:
Sub ListOutlookEmailInfoinExcel()
Dim olNS As Outlook.NameSpace
Dim olTaskFolder As Outlook.MAPIFolder
Dim olTask As Outlook.TaskItem
Dim olItems As Outlook.Items
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim x As Long
Dim arrHeaders As Variant
Set olNS = GetNamespace("MAPI")
Set olTaskFolder = olNS.GetDefaultFolder(olFolderInbox)
Set olItems = olTaskFolder.Items
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
Set xlWB = xlApp.Workbooks.Add
On Error Resume Next
x = 2
arrHeaders = Array("Date Created", "Date Recieved", "Subject", "Unread?")
xlWB.Worksheets(1).Range("A1").Resize(1, UBound(arrHeaders)).Value = ""
Do
With xlWB.Worksheets(1)
If Not (olItems(x).Subjects = "" And olItems(x).CreationTime = "") Then
.Range("A1").Resize(1, UBound(arrHeaders) + 1) = arrHeaders
.Cells(x, 1).Value = olItems(x).CreationTime
.Cells(x, 2).Value = olItems(x).ReceivedTime
.Cells(x, 3).Value = olItems(x).Subject
.Cells(x, 4).Value = olItems(x).UnRead
x = x + 1
End If
End With
Loop Until x >= olItems.Count + 1
Set olNS = Nothing
Set olTaskFolder = Nothing
Set olItems = Nothing
Set xlApp = Nothing
Set xlWB = Nothing
End Sub
With the above code, I get a readout of the Subject line, the date created/received and whether or not it has been read. I am trying to see if I can, in addition, get some of the unique string data within the message itself. The format of the emails that I receive is as follows:
Message-ID: sample info
User: test
Content1: test
Content2: test
Content3: test
Please submit a service request if you are receiving this message in error.
-Notice of NEW Room Request
Sponsored By: My_example#Test.com
Event Type: Meeting
Event Title: Test
Date of Reservation: 2015-12-02
Room: 150
From: 13:00
To: 14:00
The information will vary with each request, but I was wondering if anyone had any idea on how to capture the unique strings that will come through so that I can keep a log of the requests that is much faster than the current manual entry and double-checks?
As requested in follow up, the following code splits the message body into individual lines of information. A couple of notes: I copied your message exactly from your post, then searched for "Notice of NEW Room Request". Needless to say, this string should always start the block of information that you need. If it varies, then we have to account for the type of messages that may come through. Also, you may have to test how your message body breaks up individual lines. When I copied and pasted your message into Excel, each line break was 2 line feeds (Chr(10) in VBA). In some cases, it may be only one line feed. Or it can be a Carriage Return (Chr(13)), or even both.
Without further ado, see the code below and let us know of questions.
Sub SplitBody()
Dim sBody As String
Dim sBodyLines() As String
sBody = Range("A1").Value
sBodyLines() = Split(Mid(sBody, InStr(sBody, "Notice of NEW Room Request"), Len(sBody)), Chr(10) & Chr(10))
For i = LBound(sBodyLines) To UBound(sBodyLines)
MsgBox (sBodyLines(i))
Next i
End Sub
Below is an example connecting to an Outlook session, navigating to the default Inbox, then looping through items and adding unread emails to the spreadsheet. See if you can modify the code to your needs, and post back if specific help is needed.
Sub LinkToOutlook()
Dim olApp As Object
Dim olNS As Object
Dim olFolderInbox As Object
Dim rOutput As Range
Set olApp = CreateObject("Outlook.Application")
Set olNS = olApp.getNamespace("MAPI")
Set olFolderInbox = olNS.GetDefaultFolder(6) 'Gets the default inbox folder
Set rOutput = Sheet1.Range("A1")
For Each itm In olFolderInbox.items
If itm.unread = True Then 'check if it has already been read
rOutput.Value = itm.body
Set rOutput = rOutput.Offset(1)
End If
Next itm
End Sub
Alternatively, you can write code in Outlook directly that looks for new mail arrival, and from there, you can test if it meets your criteria, and if it does, it can write to Excel. Here's a link to get you started. Post back for added help.
Using VBA to read new Outlook Email?

Resources