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

 

[Anthony47]

I think what you see is due to the well known rule "Rubbish in - Rubbish out" (this is the polite version…)
I mean that you wish to extract an exact string from an email text that everybody is free to write in his own way; no doubt that in a way or the other you will get some trouble…

My best suggestion is replacing this portion of your code

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

With this:

strBody = OutlookMail.body
strFind = "VIN"
vinPos = InStr(1, strBody, strFind, 0)     '0 for Case sensitive, 1 for "case insensitive"
If vinPos > 0 Then
    strColA = Replace(Mid(strBody, vinPos + Len(strFind)), ":", "", , , vbTextCompare)
    strColA = Left(strColA, InStr(strColA, vbLf) - 1)
    Range("VIN").Offset(I, 0).Value = Trim(strColA)
Else
    Range("VIN").Offset(I, 0).Value = "### Not Found"
End If

With this modification we will search "VIN" (uppercase) in the email text, if not found (as in email from Sam) the field will be compiled with "### Not Found"
Also, the colon is removed from the output; but no additional check is done on the length of the returned string

Bye

 

[sammv]

I think what you see is due to the well known rule "Rubbish in - Rubbish out" (this is the polite version…)
I mean that you wish to extract an exact string from an email text that everybody is free to write in his own way; no doubt that in a way or the other you will get some trouble…

My best suggestion is replacing this portion of your code

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

With this:

strBody = OutlookMail.body
strFind = "VIN"
vinPos = InStr(1, strBody, strFind, 0)     '0 for Case sensitive, 1 for "case insensitive"
If vinPos > 0 Then
    strColA = Replace(Mid(strBody, vinPos + Len(strFind)), ":", "", , , vbTextCompare)
    strColA = Left(strColA, InStr(strColA, vbLf) - 1)
    Range("VIN").Offset(I, 0).Value = Trim(strColA)
Else
    Range("VIN").Offset(I, 0).Value = "### Not Found"
End If

With this modification we will search "VIN" (uppercase) in the email text, if not found (as in email from Sam) the field will be compiled with "### Not Found"
Also, the colon is removed from the output; but no additional check is done on the length of the returned string

Bye

Thanks Anthony for that feedback.
I am having one more challenge in my code. I now need to pull this from the main outlook inbox and not the folder "AJ" as listed in below code
When I change the name in the folder to the inbox name it is giving me "Object Not found" error.
What should I change in my below code to ensure it is pulling from my inbox and not the folder?
For test purposes I used the folder "AJ" in my inbox but now I a testing with live data which is in a different inbox in my outlook (different from my main inbox)
Your prompt help is much appreciated as I need to submit it today. Thanks in advance. Sam

Set OutlookApp = New Outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
Set Folder = OutlookNamespace.GetDefaultFolder(olFolderInbox).Folders("AJ") ​

 

[Anthony47]

Well, I have some knowledge of Excel, Outlook and their vba, but I am not a sorcer...
You should al least give me the tree of your email folders and tell us which one is the one to target.

Edit: a picture should be enough

Bye

 

[sammv]

Well, I have some knowledge of Excel, Outlook and their vba, but I am not a sorcer...
You should al least give me the tree of your email folders and tell us which one is the one to target.

Edit: a picture should be enough

Bye

 

[sammv]

I am trying to get to the NCI NCF Customer Service Inbox but its taking me to my personal inbox. Please advise what to change in my code. I suspect it is something I have to change in the folder part of the code or the namespace? Hope the picture helps. Thanks in advance

 

[Anthony47]

Not sure, I was expecting to see an account name at the root of the folders tree...
Try

Set OutlookNamespace = Application.GetNamespace("MAPI")
'Set Folder = OutlookNamespace.GetDefaultFolder(olFolderInbox).Folders("AJ")
Set Folder = Application.GetNamespace("MAPI").Folders("NCI NCF Customer Service").Folders("Inbox")

If this fails and you are in a hurry, maybe the fastest way is moving the emails to the folder you used for test

Bye

 

[sammv]

Thanks Anhthony. I had to tweak the code a bit based on your above logic but it did really help

Appreciate your prompt responses to get this working given my deadline.

I still have some minor challenges but that is a WIP model so at least I can work on deploying this for now while I work on those. I will keep you posted on those once I get this current model to work. Thanks again, sam

 

[sammv]

Actually thought I could get a head start and get your take on the final step in this project I need to do

1. Once the data is pulled from Outlook folder (which we completed above), some fields need to be appended to it (this will be done via SQL)
2. Once the file is populated with those fields, it needs to be moved to a specific sub folder under the Customer Service folder
3. Is there a VBA or macro I can write for this and if so how ? Any guidance or code example would be appreciated

The only way I know now is to export it as a CSV and the import it in outlook, but that would be all manual (not via code). I am looking if this can be done via code. Please advise your thoughts
Thanks in advance
Sam

 

[Anthony47]

I cannot tell you anything about step #1 that involve Sql

Step #2 can be done via macro, but you cannot move a file (the workbook) from one folder to another while the same file is open, you should do that via a macro hosted in a separate workbook
Or, and this is my suggestion, you create A COPY of your workbook just before closing it.
This could be done using the following snippet:

Sub AllHasBeenDoneOnThisFile()
Dim csFullName As String, CSPath As String
'
'
'
' ... other code ...
'
'
CSPath = "D:\THEIR\FOLDER\AND\SUBFOLDER"      '<<< Customer Service Path
csFullName = CSPath & "\CONSOLIDATED_" & ThisWorkbook.Name      '***See note
ThisWorkbook.Save
ThisWorkbook.SaveCopyAs csFullName
ThisWorkbook.Close , False
End Sub

I assume this is the final handling of the workbook, so we save the file, save the copy to the Customer Service path and close the file.

***: I assumed that the file passed to CS has the same name of our workbook plus a prefix; if you go with another logic please keep in mind that a "path separator" (\, in Windows) has to be inserted after CSPath and before the name

The only way I know now is to export it as a CSV and the import it in outlook, but that would be all manual (not via code)

I didn't understand what this refers to

Bye