• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

How to search a string in e-mail through Excel VBA

Status
Not open for further replies.

ThrottleWorks

Excel Ninja
Hi,

I am trying to search a string in e-mail body.
For example, I am trying to search if 'Yamaha' is present in e-mail body.

I tried 'If olItem.Body = "yamaha" Then' line but it is not working.
I need to find the string as instring. Can anyone please help me in this.

Code:
Sub Email()

    Dim olApplication  As Outlook.Application
    Dim olNameSpace    As Outlook.Namespace
    Dim olFolder        As Outlook.MAPIFolder
    Dim olItem          As Object
    Dim strDomain      As String
    Dim olProperty      As Outlook.UserProperty
   
    Set olApplication = New Outlook.Application
    Set olNameSpace = olApplication.GetNamespace("Mapi")
    Set olFolder = olNameSpace.GetDefaultFolder(olFolderInbox)
   
    For Each olItem In olFolder.Items
        If olItem.Body = "sub" Then
            Range("A1").Value = "sub"
        End If
    Next olItem
   
    Set olApplication = Nothing
    Set olNameSpace = Nothing
    Set olFolder = Nothing
    Set olProperty = Nothing

End Sub
 
Hi @Deepak Sir, hope you are doing fine. Could you please help me if you get time. I am trying below line to find string in e-mail.

"If (InStr(1, Outlook_Item.Body, KWrd9, vbTextCompare) > 0) Then"

The issue is, when there are few lines in e-mail body then this lines works.

However when there is large e-mail (genuine e-mail) the macro is not able to find the string.

For example if search 'Increase' word in an e-mail which has only 'Increase' word in it's body or very few lines, then the macro catches the string.

However when I tried this line on a comparatively large e-mail, macro does not give output.

Could you please help if possible. Good night. :)

PS - I hope you would not mind that I tagged you in this post. My apology.

Partial code as mentioned below.

Code:
For Each Outlook_Item In olFolder.Items
        'MsgBox Outlook_Item.Subject
        Set olProperty = Outlook_Item.UserProperties.Add("Yamaha", olText)
        If olProperty.Value = "" Then
            'This line is used to search Kew Word in e-mail body
            If (InStr(1, Outlook_Item.Body, KWrd9, vbTextCompare) > 0) Then
              
                KeySht.Range("C1").Value = Outlook_Item.CreationTime
                Call Format_Date
              
                If KeySht.Range("E1").Value <> "False" Then
                    Call Export_Email
                  
                    TempLr = Template.Cells(Rows.Count, 1).End(xlUp).Row + 1
                  
                    'Date
                    Template.Range("G" & TempLr).Value = Outlook_Item.CreationTime
                  
                    'Serial Number
                    Template.Range("A" & TempLr).Value = TempLr - 1
                  
                    'Key Word from E-mail body
                    Template.Range("B" & TempLr).Value = KeySht.Range("H1").Value
                  
                    'Sender
                    Template.Range("C" & TempLr).Value = Outlook_Item.SenderEmailAddress
                  
                    'Subject
                    Template.Range("D" & TempLr).Value = Outlook_Item.Subject
                  
                    'Category
                    Template.Range("E" & TempLr).Value = Outlook_Item.Categories
                  
                    'Importance
                    Template.Range("F" & TempLr).Value = Outlook_Item.Importance
                  
                    Set olProperty = Outlook_Item.UserProperties.Add("Yamaha", olText)
          
                    'MsgBox olProperty.Value
                        olProperty.Value = KeySht.Range("H1").Value
                        'MsgBox KeySht.Range("H1").Value
                        KeySht.Range("H1").Clear
                    'MsgBox olProperty.Value
                    Outlook_Item.Save
                End If
            End If
        End If
 
Hi @Deepak Sir, I have posted the code in above mentioned posts.

At present not able to upload sample file, really sorry for consuming Forum space this way. Will try to avoid it as much as possible.

Please look at the issue if you get time. :)
 
Hi Sachin,

There's loops are running many times! It's all going over my head at a glance.

Will you pls take the liberty to explain what exactly your goal is.
 
@Deepak Sir, sure, sorry for making it confusing.

1. This macro will run through excel for Outlook

2. Macro will scan e-mails only from Inbox and for today's date

3. There are 10-12 strings which we need to search in each e-mail from the inbox

4. I have manually entered a Column in Outlook, this column will take free text values.

5. If any of the string is found in an e-mail, macro will populate the string in this column.

Set olProperty = Outlook_Item.UserProperties.Add("Yamaha", olText)
olProperty.Value = Range("H1").Value

These 2 lines are used to populate strings in column and these are working correctly.

6. Macro should populate few details about e-mail in excel, such as sender, subject, time etc, not facing issues with this, working fine.

Using lines mentioned as below for this.
Template.Range("E" & TempLr).Value = Outlook_Item.Categories

7. The main problem is, macro should search the string in latest part of e-mail.
Suppose if same e-mail is replied 5 times, then the string should be searched in latest reply.

For this, I am using Call Export_Email module.
I am using below code to split e-mail.

Code:
'text_string = "Welcome:to:Excel:Trick"
    ExportSht.Range("A1").Value = Outlook_Item.Body
 
    text_string = ExportSht.Range("A1").Value
    WrdArray() = Split(text_string, "From:")
 
    For i = LBound(WrdArray) To UBound(WrdArray)
        'MsgBox WrdArray(i)
        ExportSht.Cells(1, 1 + (i + 1)).Value = WrdArray(i)
    Next i

8. At present there are 9 "For Each" in module 1.
The reason is, I am trying to search 9 different strings in e-mail.

"If (InStr(1, Outlook_Item.Body, STRING, vbTextCompare) > 0) Then"

This line search 1 string at a time, I do not know how to search the entire array of 9 strings with one line that is why "For Each Outlook_Item In olFolder.Items" is used 9 times.

I know it is not right way but used it since I do not know any other option.

Thanks for reading, please let me know if you need further details.
 
Sir, I guess you won't need any details regarding 2nd and 3rd module.

Regarding the 4th module, which exports and process e-mail.

There are 2 "For Each" loops in this module.
First loop is used if e-mail is replied multiple times.

Second loop is used if e-mail is a single instance (fresh e-mail).
 
Hi Sachin,

I am in the middle, will you pls share either screen shots of all threes sheets or xl[from somewhere else] as this will give me complete clear of what u processed earlier.
 
Hi Sachin ,

I have managed something! Check & let me know what would be optimized!

Code:
Sub get_emails()
Dim olApplication As Outlook.Application
Dim olNameSpace As Outlook.Namespace
Dim olFolder As Outlook.MAPIFolder
Dim Outlook_Item As Object, My_Outlook_Item As Object
Dim olProperty As Outlook.UserProperty
Dim ExportSht As Worksheet, Template As Worksheet, MyStringSht As Worksheet
Dim MyString As Variant, TempLr As Long, mailtime As Double
Dim strSubject As String, isfind As Boolean, strv As Variant

With ThisWorkbook
Set Template = .Worksheets("Template")
Set MyStringSht = .Worksheets("Key_Words")
Set ExportSht = .Worksheets("Email_Export")
End With

With MyStringSht
    MyString = (Sheets("Key_Words").Range("B2:B10"))
    TempLr = .Cells(.Rows.Count, 1).End(xlUp).Row
    Set MyStringRng = .Range("B2:B" & TempLr)
End With

Template.UsedRange.Offset(1).ClearContents

Set olApplication = New Outlook.Application
Set olNameSpace = olApplication.GetNamespace("Mapi")
Set olFolder = olNameSpace.PickFolder 'olNameSpace.getdefaultfolder(olFolderInbox)

With olFolder
    For Each My_Outlook_Item In .items
    'check it was processed or of today
    If InStr(strSubject, re_fw(My_Outlook_Item.Subject)) > 0 Or Not Day(My_Outlook_Item.CreationTime) = Day(Date) Then GoTo N
        'Check which mail is latest : Of Today, Data hasn't processed
        For i = 1 To .items.Count
            If Not InStr(strSubject, re_fw(.items(i).Subject)) > 0 And _
                re_fw(.items(i).Subject) = re_fw(My_Outlook_Item.Subject) And _
                    Day(.items(i).CreationTime) = Day(Date) Then
                        If .items(i).CreationTime > mailtime Then
                            Set Outlook_Item = .items(i)
                            mailtime = .items(i).CreationTime
                        End If
            End If
        Next
        If Outlook_Item Is Nothing Or Not mailtime > 0 Then GoTo N
        strSubject = strSubject & Outlook_Item.Subject
        'Find each string in this mail
        For Each strv In MyString
            If InStr(Outlook_Item.body, strv) Then isfind = True
        Next
        If Not isfind = True Then GoTo N
    
    With Template
        [A1:G1] = Array("SN", "key", "Sender", "sub", "cat", "imp", "Date")
        TempLr = .Cells(Rows.Count, 1).End(xlUp).Row + 1
        .Range("G" & TempLr).Value = Outlook_Item.CreationTime
        .Range("A" & TempLr).Value = TempLr - 1
        .Range("B" & TempLr).Value = strv '.Range("H1").Value
        .Range("C" & TempLr).Value = Mid(Outlook_Item.SenderEmailAddress, InStrRev(Outlook_Item.SenderEmailAddress, "=") + 1)
        .Range("D" & TempLr).Value = re_fw(Outlook_Item.Subject)
        .Range("E" & TempLr).Value = Outlook_Item.Categories
        .Range("F" & TempLr).Value = Outlook_Item.Importance
    End With
N:
    Set Outlook_Item = Nothing: mailtime = 0: isfind = False
    Next
End With
MsgBox "Done", vbInformation
End Sub

Private Function re_fw(strsub As String) As String
    re_fw = Replace(Replace(strsub, "FW: ", ""), "RE: ", "")
End Function
 
Hi @Deepak sir, thanks a lot fir the help.
Actually can't thank you enough. I will run the code and will share results tomorrow. Have a nice weekend Sir.
 
Hi Sir. Sorry for late reply. Facing some issues with my license copy of ms office at home. Will run the code asap. Good night.
 
Hi @Deepak Sir, really sorry for late reply.

I am facing some issues while running the code.
I guess macro is not picking key word. I tried running this code in dummy e-mail .

All the fields are populated correctly except, key word.

I checked
Code:
For Each strv In MyString
            If InStr(Outlook_Item.Body, strv) Then isfind = True
        Next
this line,

By the time macros reaches
Code:
.Range("B" & TempLr).Value = strv
this line, strv is 'empty'.

Could you please help if you get time. Have a nice week ahead. :)
 
Hi,

thanks for the wishes.

Is the below range having the said data which needs to find in the email.

Code:
MyString = (Sheets("Key_Words").Range("B2:B10"))

& simply change it to .Range("B2:B10") [That's only for beauty.]
 
Change this..

Code:
        For Each strv In MyString
            If CStr(strv) <> "" And InStr(Outlook_Item.body, strv) Then isfind = True: kwrd = CStr(strv)
        Next
        If Not isfind Then GoTo N
   
        .Range("B" & TempLr).Value = kwrd '.Range("H1").Value

add

dim kwrd As String
 
Hi @Deepak Sir, thanks a lot for your valuable time and help.

The macro is picking single e-mails perfectly, however in case of multiple time replied e-mail, I guess macro is not picking latest key word.

Sorry to disturb you on this, I will try to edit your code, thought should share the results with you before proceeding further (on my own).
 
Sachin,

There another loop inside the main to get latest email in conversation & it should to do its job perfectly.

I will also check the same soon.
 
Status
Not open for further replies.
Back
Top