Exracting VIN number from outlook mail based on specific condition to extract only 17 digit aplphanumeric characters

[sammv]

Dear Excel Gutu

Below VBA code is looking at a an outlook folder and pasting contents of email in excel workbook

Below is output of code in Excel

Challenge I am having is - the VIN number (always 17 digit alphanumeric) should be extracted from body of email and be pasted in the "VIN" column

My code is doing it but it has few issues

1. It is parsing non VIN too (eg "hi" which it should not)
2 It is not picking it based on 17 characters but it is based on me hard coding based on my search criteria specifying "VIN" (please see code)
3. It is not removing the semi colons (see example 3) -- I need that to be removed and VIN to be clean only alphanumeric

What do I change in my code below to correct these issues? I also need it to be altered such that it checks for 17 characters and not by VIN as that requires manual intervention

Please help. I need to have this delivered by tonight so your prompt assistance would be greatly appreciated,

Thanks in advance.

Sam

Sub GetFromOutlook()
Dim OutlookApp As Outlook.Application
Dim OutlookNamespace As Namespace
Dim Folder As MAPIFolder
Dim OutlookMail As Variant
Dim strBody As String
Dim strFind As String
Dim strColA, strColB, strColC, strColD, strColE As String
Dim xlSheet As Object
Dim itm As Object
Dim i As Integer
Dim sFilterStart As String
Dim sFilterEnd As String
Dim sExtract As String
Dim aExtract() As String
Dim aExtractItems() As String
Set OutlookApp = New Outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
Set Folder = OutlookNamespace.GetDefaultFolder(olFolderInbox).Folders("AJ")
i = 1
Worksheets("Import").Range("A4:E250").ClearContents
For Each OutlookMail In Folder.Items
If OutlookMail.ReceivedTime >= Range("From_date").Value Then
Range("email_subject").Offset(i, 0).Value = OutlookMail.Subject
Range("email_Subject").Offset(i, 0).Columns.AutoFit
Range("email_Subject").Offset(i, 0).VerticalAlignment = xlTop
Range("eMail_date").Offset(i, 0).Value = OutlookMail.ReceivedTime
Range("email_date").Offset(i, 0).Columns.AutoFit
Range("email_date").Offset(i, 0).VerticalAlignment = xlTop
Range("eMail_sender").Offset(i, 0).Value = OutlookMail.SenderName
Range("email_sender").Offset(i, 0).Columns.AutoFit
Range("email_sender").Offset(i, 0).VerticalAlignment = xlTop
Range("eMail_text").Offset(i, 0).Value = OutlookMail.Body
Range("email_text").Offset(i, 0).Columns.AutoFit
Range("email_text").Offset(i, 0).VerticalAlignment = xlTop
strBody = OutlookMail.Body
strFind = "VIN"
strColA = Mid(strBody, InStr(1, strBody, strFind, 1) + Len(strFind))
strColA = Left(strColA, InStr(strColA, vbLf) - 1)
Range("VIN").Offset(i, 0).Value = strColA
'Cells.wrapText = True
i = i + 1
End If
Next OutlookMail

On Error Resume Next
'Find the next empty line of the worksheet
rCount = xlSheet.Range("A" & xlSheet.Rows.Count).End(-4162).Row
'needed for Exchange 2016. Remove if causing blank lines.
rCount = rCount + 1
i = 1
'For Each OutlookMail In Folder.Items
'If OutlookMail.ReceivedTime >= Range("From_date").Value Then
'strBody = OutlookMail.Body
'strFind = "VIN"
'strColA = Mid(strBody, InStr(1, strBody, strFind, 1) + Len(strFind))
'strColA = Left(strColA, InStr(strColA, vbLf) - 1)
'strFind = "Foreman Name and Number: "
'strColB = Mid(strBody, InStr(1, strBody, strFind, 1) + Len(strFind))
'strColB = Left(strColB, InStr(strColB, vbLf) - 1)
'strFind = "GF Name and Number: "
'strColC = Mid(strBody, InStr(1, strBody, strFind, 1) + Len(strFind))
'strColC = Left(strColC, InStr(strColC, vbLf) - 1)
'strFind = "Location Address: "
'strColD = Mid(strBody, InStr(1, strBody, strFind, 1) + Len(strFind))
'strColD = Left(strColD, InStr(strColD, vbLf) - 1)
'strColE = OutlookMail.ReceivedTime
'Range("VIN").Offset(i, 0).Value = strColA
'Range("Foreman").Offset(i, 0).Value = strColB
'Range("General_Foreman").Offset(i, 0).Value = strColC
'Range("Location_Address").Offset(i, 0).Value = strColD
'Range("Email_Received_Time").Offset(i, 0).Value = strColE
'i = i + 1
'End If
'Next OutlookMail
Set Folder = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing
End Sub
Sub EnableWrapText()

Cells.wrapText = True
End Sub

 

[sammv]

to clarify, after the file is completed (excel file) it requires o be exported to a outlook sub folder (not from one folder to another folder on the computer_ Which I think is what your code is doing

Sorry, I did not clarify this earlier. So to summarize, once the file is complete, it needs to be exported to an outlook folder (basically reverse of what we did with the import code above), ..I was wondering what code I could write and if there is one to do that. Hope it is more clear now.

Please advise. Thanks in advance

 

[sammv]

1. To clarify, I want the final file to be sent/imported to an Outlook folder after it is worked on and complete.
2. Ideally it should be sent to this folder with detail like " From, to and other fields that make up outlook body test to the right Outlook sub folder. It should be an outlook email
3. I don't want it to move from one folder to another folder on my pc ( I think that is what your code is doing)

Sorry, I was not clear before.

Thanks

 

[Anthony47]

Well, for sure I misunderstood your request...
So you wish that the file be sent via email to someone.
There are plenty of example of macro that send the activeworkbook, here on the forum. Or if you wish you may visit the reference site (in my opinion) for these tasks: Mail from Excel and make/mail PDF files (Windows)
If you set the subject with peculiar keywords you will give the receiving person a hook for an outlook rule that move the mail to a specific folder.

Bye

 

[sammv]

Hi Anthony

I dont need it as an excel file but more a csv and the csv needs to be imported to a specific folder in outlook which I don't know how to do

I did look at below code on site you recommended It is sending out the email but not the attachment (or my active workbook) It is only sending the test

Name of my activesheet is "Import", so I replaced the "FulName" in code below to that (although the active workbook is what I think I need and should be enough) . I did this while the workbook was open and ran the code. Please advise why the attachment is not being exported and what I should be doing.

.Attachments.Add ActiveWorkbook.FullName​

Example 1

​

The following subroutine sends the last saved version of the active workbook in an e-mail message. Change the mail address and subject in the macro before you run it.

​

Sub Mail_workbook_Outlook_1()
'Working in Excel 2000-2016
'This example send the last saved version of the Activeworkbook
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim OutApp As Object
Dim OutMail As Object

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

On Error Resume Next
With OutMail
.to = "ron@debruin.nl"
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.Body = "Hi there"
.Attachments.Add ActiveWorkbook.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Send 'or use .Display
End With
On Error GoTo 0

Set OutMail = Nothing
Set OutApp = Nothing
End Sub

 

[Anthony47]

.Attachments.Add ActiveWorkbook.FullName

"FullName" is a property of the workbook, and returns the Drive+Path+Name of the referred workbook (the "active" one, in that line); so you have to leave the line unchanched.

This is an Excel Macro (not an Outlook one, to avoid confusion), and to work needs that the file has already been saved

Ron dB will forgive me for suggesting that you add this line in this position, only for testing:

On Error GoTo 0
Application.Wait (Now + TimeValue("0:00:04"))     '<<< ADD THIS LINE HERE
Set OutMail = Nothing

In my understanding an Outlook folder is intended to contain emails; I don't know how putting a file in it

Bye

 

[sammv]

thanks Andrew that worked like magic I now see the attachment

So what does this code do? and what does the Application.wait and now + Timevalue mean can you please explain

VBA Code:

​

On Error GoTo 0
Application.Wait (Now + TimeValue("0:00:04")) '<<< ADD THIS LINE HERE
Set OutMail = Nothing

​

1. Also this helps for me to understand why it is there but there is no drive or path only the worksheet I am already in and it is open and saved so how would it find the drive or path ? Is that the path where the workbook I am working off is saved?

"FullName" is a property of the workbook, and returns the Drive+Path+Name of the referred workbook (the "active" one, in that line); so you have to leave the line unchanched.
​

2. The issue with this is while this will export it as an excel macro file which is good, but ideally it needs to be saved as an outlook email and move to respective folder. Is there any way of doing it? Meaning it has to be a csv or pst file and it should just be an import into the respective outlook folder after the work on the excel file is complete? Any guidance would be great

We are very close but it is not fulfilling the business need fully. Thanks again for your prompt and very useful inputs. I really appreciate that and just need guidance on this final part

 

[sammv]

Hi Anthony.

I had one more question. Currently, while program is pulling info on VIN, it is also pulling other info in the body which it should not, when there is no VIN I body
Below is sample of code that pulls this info

1. What can I alter here to sop it from pulling info other than VIN
2. Also, what can I add in this code to pull other variants of VIN like, serial no or VIN : or other that will also be pulled programitally

Currently, it is pulling only VIN and Vehicle identification as that is programmed in. Please advise

Thanks
Sa

strBody = OutlookMail.Body
strFind = "VIN"
strColA = Mid(strBody, InStr(1, strBody, strFind, 1) + Len(strFind))
strColA = Left(strColA, InStr(strColA, vbLf) - 1)
Range("VIN").Offset(i, 0).Value = Right(strColA, 18)
Cells.wrapText = False
i = i + 1
strBody = OutlookMail.Body
strFind = "Vehicle Identification Number: "
strColA = Mid(strBody, InStr(1, strBody, strFind, 1) + Len(strFind))
strColA = Left(strColA, InStr(strColA, vbLf) - 1)
Range("VIN").Offset(i, 0).Value = Right(strColA, 18)

 

[sammv]

also instead of above way to search VIN, is there a more intelligent way where I can search for a 17 digit alphanumeric character in the body of email, then it would work with any variant im guessing in throery and we dont have to program all variants. Just a thought which I felt would make the code more efficient

Thanks in advance, but these are my last questions on this ask.
Sam

 

[Anthony47]

I heve been happily offline for few days…
I am afraid that you want to extract information from an email that don't have a designed structure but are free text (remember the rubbish in - rubbish out rule).
If you are in time, you should collect the information using a well defined structure, for example a data collection form. If the process you are talking about is important for your Company you should develop, maybe with the help of a Consultant (btw, I don't belong to that category), a customized form to distribute and collect via email.

You are asking for "a more intelligent method" for searching the VIN… In the situation you are, I think you are asking to extract all words 17 characters long; this can be done, but who then select the right one to be saved?

In message #17 I seem you tried to tackle two ways for searching the "keyword", that every user type its own way.
Rather than having two blocks of code, I would suggest that you "prework" the email body; for example

strBody = OutlookMail.body
'Check for synonymous:
strBody = Replace(strBody, "Vehicle Identification Number:", "VIN:", , , vbTextCompare)
strBody = Replace(strBody, "Vehicle Id. Number:", "VIN:", , , vbTextCompare)
strBody = Replace(strBody, "Vehicle Id Number:", "VIN:", , , vbTextCompare)
'
' other similar lines for additional synonymous
'
'Continue extracting:
strFind = "VIN"
strColA = Mid(strBody, InStr(1, strBody, strFind, 1) + Len(strFind))

As you can see, possible synonymous are replaced by a standard definition before the data extraction continue

In message #16 you asked about the added instruction, Application.Wait
That line simply wait for 4 seconds before the mail object be deleted and the macro terminated; these 4 seconds give enough time (likely) to outlook to instantiate the whole process.

If you want it as a csv file, then look at this RdB's code: Mail one sheet
It is intended to send a single worksheet; the trick is that you will modify the code so that, rather than saving it in Excel format you save in csv format.

To do that, in RdB's code search for the block that starts with

    'Determine the Excel version and file extension/format
    With Destwb

Replace all the block with:

FileFormatNum = 62
FileExtStr = ".csv"

Hope you find some useful ideas

Bye