Solved

Outlook macro to save email body data into seperate colums in excel.

Posted on 2010-09-20
32
702 Views
Last Modified: 2012-05-10
Hi,

Outlook macro to save email body data into seperate colums in excel.
I will have this data in the subject to identify "Employee departure notice:"

I need to run it on a folder or be able to add this code to all emails that arrive.
Each day new excel file should be created.

The body of the email will be as this

The person noted here is leaving the organisation on 12/11/2010.

Employee:  Paul, Andrew (IN190924) Job Title:  Software Engineer Office location:  USA
Manager:  John, Raj


I want each of these in each colum

Andrew Paul | IN190924 | Software Engineer | USA | Raj John

The excel should look as above.

regards
sharath
0
Comment
Question by:bsharath
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 17
  • 15
32 Comments
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 33717843
Is the new daily file to be the same name or can we incorporate the date into the file name?
0
 
LVL 11

Author Comment

by:bsharath
ID: 33717966
Hi Chris
We can have date as the file name

0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 33718518
Poorly phrased ... it's easier if we create a new file ... but whatever you want if you have a preference.

Chris
0
Ransomware: The New Cyber Threat & How to Stop It

This infographic explains ransomware, type of malware that blocks access to your files or your systems and holds them hostage until a ransom is paid. It also examines the different types of ransomware and explains what you can do to thwart this sinister online threat.  

 
LVL 11

Author Comment

by:bsharath
ID: 33718729

yes Chris
I want the file named as "DD-MM-YYY-Email"
each day 1 file to be created. as and when an email comes in it has to update into it.

When selected a folder and run has to save into the same dated file if already available
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 33718824
ON initial consideration whilst commonly I use the one file for both rule based processing and another for folder based in this case I suggest two scripts for efficiency to avoid overheads with repeated closure of the file and/or passing a workbook parameter.

If that's ok ... the essential processing will be the same of course

Chris
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 33721976
Q_26485542 run from a rule.

Sub Q_26485542a() to run on a folder via pickfolder

filename is declared in both Q_26485542 & Q_26485542a
as
    fn = "c:\deleteme\Q_26485542 " & Format(Now(), "dd mmm yyyy") & ".xlsx"


Chris
Sub Q_26485542(mai As MailItem)
Dim fn As String
Dim xlapp As Object
Dim wb As Object
    
    fn = "c:\deleteme\Q_26485542 " & Format(Now(), "dd mmm yyyy") & ".xlsx"
    Set xlapp = CreateObject("excel.application")
    On Error Resume Next
    Set wb = xlapp.workbooks.Open(fn)
    On Error GoTo 0
    If wb Is Nothing Then
        Set wb = xlapp.workbooks.Add
        wb.sheets(1).Range("A1") = "Employee"
        wb.sheets(1).Range("B1") = "ID"
        wb.sheets(1).Range("C1") = "Job Title"
        wb.sheets(1).Range("D1") = "Nation"
        wb.sheets(1).Range("E1") = "Manager"
        wb.saveas fn
    End If
    Q_26485542b mai, wb
    wb.Close True
    xlapp.Quit

End Sub
Sub Q_26485542a()
Dim fn As String
Dim xlapp As Object
Dim wb As Object
    
    fn = "c:\deleteme\Q_26485542 " & Format(Now(), "dd mmm yyyy") & ".xlsm"
    Set xlapp = CreateObject("excel.application")
    On Error Resume Next
    Set wb = xlapp.workbooks.Open(fn)
    On Error GoTo 0
    If wb Is Nothing Then
        Set wb = xlapp.workbooks.Add
        wb.sheets(1).Range("A1") = "Employee"
        wb.sheets(1).Range("B1") = "ID"
        wb.sheets(1).Range("C1") = "Job Title"
        wb.sheets(1).Range("D1") = "Nation"
        wb.sheets(1).Range("E1") = "Manager"
        wb.saveas fn
    End If
    For Each mai In Application.Session.PickFolder.items
        If mai.Class = olMail Then
            Q_26485542b mai, wb
        End If
    Next
    wb.Close True
    xlapp.Quit

End Sub

Sub Q_26485542b(mai As MailItem, wb As Object)
Dim ln As Variant
Dim arr() As String
Dim str As String
Dim rw As Long
Static regex As Object
Const xlup As Integer = -4162
    
    If InStr(LCase(mai.body), LCase("The person noted here is leaving the organisation on")) = 0 Then Exit Sub
    If regex Is Nothing Then Set regex = CreateObject("vbscript.regexp")
    rw = wb.sheets(1).Range("A" & wb.sheets(1).Rows.count).End(xlup).Row + 1
    For Each ln In Split(Replace(mai.body, Chr(160), " "), vbCrLf)
' Employee
        If valDatabyRegEx(CStr(ln), "(Employee: *)([a-z]*)(, *)([a-z]*)( *\(.*)") Then
            With regex
                .Pattern = "(Employee: *)([a-z]*)(, *)([a-z]*)( *\(.*)"
                .Global = False
                .IgnoreCase = True
            End With
            str = regex.Replace(ln, "$4 $2")
            wb.sheets(1).Range("A" & rw) = Trim(str)
        End If
' ID
        If valDatabyRegEx(CStr(ln), "(.*\()(IN[0-9]*)(\).*)") Then
            With regex
                .Pattern = "(.*\()(IN[0-9]*)(\).*)"
                .Global = False
                .IgnoreCase = True
            End With
            str = regex.Replace(ln, "$2")
            wb.sheets(1).Range("B" & rw) = Trim(str)
        End If
' Job Title
        If valDatabyRegEx(CStr(ln), "(.*Job Title: *)([a-z -_]*)(\r\n|office location:).*") Then
            With regex
                .Pattern = "(.*Job Title: *)([a-z -_]*)(\r\n|office location:.*)"
                .Global = False
                .IgnoreCase = True
            End With
            str = regex.Replace(ln, "$2")
            wb.sheets(1).Range("C" & rw) = Trim(str)
        End If
' Nation
        If valDatabyRegEx(CStr(ln), "(.*)(office location: *)([a-z _-]*)(.*)") Then
            With regex
                .Pattern = "(.*)(office location: *)([a-z _-]*)(.*)"
                .Global = False
                .IgnoreCase = True
            End With
            str = regex.Replace(ln, "$3")
            wb.sheets(1).Range("D" & rw) = Trim(str)
        End If
' Manager
        If valDatabyRegEx(CStr(ln), "(manager: *)([a-z -_]*)(.*)") Then
            With regex
                .Pattern = "(manager: *)([a-z -_]*)(.*)"
                .Global = False
                .IgnoreCase = True
            End With
            str = regex.Replace(ln, "$2")
            arr = Split(str, ",")
            wb.sheets(1).Range("E" & rw) = Trim(arr(1)) & " " & Trim(arr(0))
        End If
    Next

End Sub

Function valDatabyRegEx(strFindin As String, strPattern As String, Optional bolMatchCase As Boolean = False) As Boolean
    
    With CreateObject("vbscript.regexp")
        .IgnoreCase = Not bolMatchCase
        .Pattern = strPattern
        valDatabyRegEx = .test(strFindin) = True
    End With
    
End Function

Open in new window

0
 
LVL 11

Author Comment

by:bsharath
ID: 33721989
Hi Chris i get this

---------------------------
Microsoft Visual Basic
---------------------------
Compile error:

ByRef argument type mismatch
---------------------------
OK   Help  
---------------------------
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 33722437
Under what circumstances and where?
0
 
LVL 11

Author Comment

by:bsharath
ID: 33722446
When i run the macro on a folder i get the error and this line is selected

 Q_26485542b mai, wb
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 33722455
Found a couple of errors in the pickfolder approach ... which I hadn't tested so apologies there.

Chris
Sub Q_26485542(mai As MailItem)
Dim fn As String
Dim xlapp As Object
Dim wb As Object
    
    fn = "c:\deleteme\Q_26485542 " & Format(Now(), "dd mmm yyyy") & ".xlsx"
    Set xlapp = CreateObject("excel.application")
    On Error Resume Next
    Set wb = xlapp.workbooks.Open(fn)
    On Error GoTo 0
    If wb Is Nothing Then
        Set wb = xlapp.workbooks.Add
        wb.sheets(1).Range("A1") = "Employee"
        wb.sheets(1).Range("B1") = "ID"
        wb.sheets(1).Range("C1") = "Job Title"
        wb.sheets(1).Range("D1") = "Nation"
        wb.sheets(1).Range("E1") = "Manager"
        wb.saveas fn
    End If
    Q_26485542b mai, wb
    wb.Close True
    xlapp.Quit

End Sub
Sub Q_26485542a()
Dim fn As String
Dim mai As Object
Dim xlapp As Object
Dim wb As Object
    
    fn = "c:\deleteme\Q_26485542 " & Format(Now(), "dd mmm yyyy") & ".xlsx"
    Set xlapp = CreateObject("excel.application")
    On Error Resume Next
    Set wb = xlapp.workbooks.Open(fn)
    On Error GoTo 0
    If wb Is Nothing Then
        Set wb = xlapp.workbooks.Add
        wb.sheets(1).Range("A1") = "Employee"
        wb.sheets(1).Range("B1") = "ID"
        wb.sheets(1).Range("C1") = "Job Title"
        wb.sheets(1).Range("D1") = "Nation"
        wb.sheets(1).Range("E1") = "Manager"
        wb.saveas fn
    End If
    For Each mai In Application.Session.PickFolder.items
        If mai.Class = olMail Then
            Q_26485542b mai, wb
        End If
    Next
    wb.Close True
    xlapp.Quit

End Sub

Sub Q_26485542b(mai As MailItem, wb As Object)
Dim ln As Variant
Dim arr() As String
Dim str As String
Dim rw As Long
Static regex As Object
Const xlup As Integer = -4162
    
    If InStr(LCase(mai.body), LCase("The person noted here is leaving the organisation on")) = 0 Then Exit Sub
    If regex Is Nothing Then Set regex = CreateObject("vbscript.regexp")
    rw = wb.sheets(1).Range("A" & wb.sheets(1).Rows.count).End(xlup).Row + 1
    For Each ln In Split(Replace(mai.body, Chr(160), " "), vbCrLf)
' Employee
        If valDatabyRegEx(CStr(ln), "(Employee: *)([a-z]*)(, *)([a-z]*)( *\(.*)") Then
            With regex
                .Pattern = "(Employee: *)([a-z]*)(, *)([a-z]*)( *\(.*)"
                .Global = False
                .IgnoreCase = True
            End With
            str = regex.Replace(ln, "$4 $2")
            wb.sheets(1).Range("A" & rw) = Trim(str)
        End If
' ID
        If valDatabyRegEx(CStr(ln), "(.*\()(IN[0-9]*)(\).*)") Then
            With regex
                .Pattern = "(.*\()(IN[0-9]*)(\).*)"
                .Global = False
                .IgnoreCase = True
            End With
            str = regex.Replace(ln, "$2")
            wb.sheets(1).Range("B" & rw) = Trim(str)
        End If
' Job Title
        If valDatabyRegEx(CStr(ln), "(.*Job Title: *)([a-z -_]*)(\r\n|office location:).*") Then
            With regex
                .Pattern = "(.*Job Title: *)([a-z -_]*)(\r\n|office location:.*)"
                .Global = False
                .IgnoreCase = True
            End With
            str = regex.Replace(ln, "$2")
            wb.sheets(1).Range("C" & rw) = Trim(str)
        End If
' Nation
        If valDatabyRegEx(CStr(ln), "(.*)(office location: *)([a-z _-]*)(.*)") Then
            With regex
                .Pattern = "(.*)(office location: *)([a-z _-]*)(.*)"
                .Global = False
                .IgnoreCase = True
            End With
            str = regex.Replace(ln, "$3")
            wb.sheets(1).Range("D" & rw) = Trim(str)
        End If
' Manager
        If valDatabyRegEx(CStr(ln), "(manager: *)([a-z -_]*)(.*)") Then
            With regex
                .Pattern = "(manager: *)([a-z -_]*)(.*)"
                .Global = False
                .IgnoreCase = True
            End With
            str = regex.Replace(ln, "$2")
            arr = Split(str, ",")
            wb.sheets(1).Range("E" & rw) = Trim(arr(1)) & " " & Trim(arr(0))
        End If
    Next

End Sub

Function valDatabyRegEx(strFindin As String, strPattern As String, Optional bolMatchCase As Boolean = False) As Boolean
    
    With CreateObject("vbscript.regexp")
        .IgnoreCase = Not bolMatchCase
        .Pattern = strPattern
        valDatabyRegEx = .test(strFindin) = True
    End With
    
End Function

Open in new window

0
 
LVL 11

Author Comment

by:bsharath
ID: 33722469
When i run the 2nd time i get subscript out of range
When debug goes here
            wb.Sheets(1).Range("E" & rw) = Trim(arr(1)) & " " & Trim(arr(0))
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 33722605
And what does the relevant email show ... it looks as though the names are not seperated by a comma

Chris
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 33722616
The following adaption checks for the comma, if not found trys a space seperator and if still not found simply returns whatever is or is not there ... hopefully

Chris
Sub Q_26485542(mai As MailItem)
Dim fn As String
Dim xlapp As Object
Dim wb As Object
    
    fn = "c:\deleteme\Q_26485542 " & Format(Now(), "dd mmm yyyy") & ".xlsx"
    Set xlapp = CreateObject("excel.application")
    On Error Resume Next
    Set wb = xlapp.workbooks.Open(fn)
    On Error GoTo 0
    If wb Is Nothing Then
        Set wb = xlapp.workbooks.Add
        wb.sheets(1).Range("A1") = "Employee"
        wb.sheets(1).Range("B1") = "ID"
        wb.sheets(1).Range("C1") = "Job Title"
        wb.sheets(1).Range("D1") = "Nation"
        wb.sheets(1).Range("E1") = "Manager"
        wb.saveas fn
    End If
    Q_26485542b mai, wb
    wb.Close True
    xlapp.Quit

End Sub
Sub Q_26485542a()
Dim fn As String
Dim mai As Object
Dim xlapp As Object
Dim wb As Object
    
    fn = "c:\deleteme\Q_26485542 " & Format(Now(), "dd mmm yyyy") & ".xlsx"
    Set xlapp = CreateObject("excel.application")
    On Error Resume Next
    Set wb = xlapp.workbooks.Open(fn)
    On Error GoTo 0
    If wb Is Nothing Then
        Set wb = xlapp.workbooks.Add
        wb.sheets(1).Range("A1") = "Employee"
        wb.sheets(1).Range("B1") = "ID"
        wb.sheets(1).Range("C1") = "Job Title"
        wb.sheets(1).Range("D1") = "Nation"
        wb.sheets(1).Range("E1") = "Manager"
        wb.saveas fn
    End If
    For Each mai In Application.Session.PickFolder.items
        If mai.Class = olMail Then
            Q_26485542b mai, wb
        End If
    Next
    wb.Close True
    xlapp.Quit

End Sub

Sub Q_26485542b(mai As MailItem, wb As Object)
Dim ln As Variant
Dim arr() As String
Dim str As String
Dim rw As Long
Static regex As Object
Const xlup As Integer = -4162
    
    If InStr(LCase(mai.body), LCase("The person noted here is leaving the organisation on")) = 0 Then Exit Sub
    If regex Is Nothing Then Set regex = CreateObject("vbscript.regexp")
    rw = wb.sheets(1).Range("A" & wb.sheets(1).Rows.count).End(xlup).Row + 1
    For Each ln In Split(Replace(mai.body, Chr(160), " "), vbCrLf)
' Employee
        If valDatabyRegEx(CStr(ln), "(Employee: *)([a-z]*)(, *)([a-z]*)( *\(.*)") Then
            With regex
                .Pattern = "(Employee: *)([a-z]*)(, *)([a-z]*)( *\(.*)"
                .Global = False
                .IgnoreCase = True
            End With
            str = regex.Replace(ln, "$4 $2")
            wb.sheets(1).Range("A" & rw) = Trim(str)
        End If
' ID
        If valDatabyRegEx(CStr(ln), "(.*\()(IN[0-9]*)(\).*)") Then
            With regex
                .Pattern = "(.*\()(IN[0-9]*)(\).*)"
                .Global = False
                .IgnoreCase = True
            End With
            str = regex.Replace(ln, "$2")
            wb.sheets(1).Range("B" & rw) = Trim(str)
        End If
' Job Title
        If valDatabyRegEx(CStr(ln), "(.*Job Title: *)([a-z -_]*)(\r\n|office location:).*") Then
            With regex
                .Pattern = "(.*Job Title: *)([a-z -_]*)(\r\n|office location:.*)"
                .Global = False
                .IgnoreCase = True
            End With
            str = regex.Replace(ln, "$2")
            wb.sheets(1).Range("C" & rw) = Trim(str)
        End If
' Nation
        If valDatabyRegEx(CStr(ln), "(.*)(office location: *)([a-z _-]*)(.*)") Then
            With regex
                .Pattern = "(.*)(office location: *)([a-z _-]*)(.*)"
                .Global = False
                .IgnoreCase = True
            End With
            str = regex.Replace(ln, "$3")
            wb.sheets(1).Range("D" & rw) = Trim(str)
        End If
' Manager
        If valDatabyRegEx(CStr(ln), "(manager: *)([a-z -_]*)(.*)") Then
            With regex
                .Pattern = "(manager: *)([a-z -_]*)(.*)"
                .Global = False
                .IgnoreCase = True
            End With
            str = regex.Replace(ln, "$2")
            arr = Split(str, ",")
            If UBound(arr) = 1 Then
                arr = Split(str, " ")
                If UBound(arr) = 1 Then
                    wb.sheets(1).Range("E" & rw) = Trim(str)
                Else
                    wb.sheets(1).Range("E" & rw) = Trim(arr(1)) & " " & Trim(arr(0))
                End If
            Else
                wb.sheets(1).Range("E" & rw) = Trim(arr(1)) & " " & Trim(arr(0))
            End If
        End If
    Next

End Sub

Function valDatabyRegEx(strFindin As String, strPattern As String, Optional bolMatchCase As Boolean = False) As Boolean
    
    With CreateObject("vbscript.regexp")
        .IgnoreCase = Not bolMatchCase
        .Pattern = strPattern
        valDatabyRegEx = .test(strFindin) = True
    End With
    
End Function

Open in new window

0
 
LVL 11

Author Comment

by:bsharath
ID: 33722953
Chris i still get subscript out of range
when debug goes here
                wb.Sheets(1).Range("E" & rw) = Trim(arr(1)) & " " & Trim(arr(0))
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 33722977
And to try and fix it I still need ... what does the relevant email show ... it looks as though the names are not seperated by a comma

Chris
0
 
LVL 11

Author Comment

by:bsharath
ID: 33723008
Chris how can i find which email
I emailed you 2 emails that will look as
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 33723027
When the code breaks type in the immediate window:

mai.getinspector.activate

Should open up the specific email

Chris
0
 
LVL 11

Author Comment

by:bsharath
ID: 33723051
I have this in the body

The person noted here is leaving the organisation on 30/09/2010.

Employee:  Kur, Amar (IN1898949) Job Title:  
Office location:  
Manager:  

and subject as this
Employee departure notice: IN - Kur, Amar (WorkflowID=77877876)
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 33723063
Ah so manager, office location AND job title are completely blank!

Let me rething this change.

Chris
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 33723080
On a quick check it's only the name that causes the problem so try this

Chris
Sub Q_26485542(mai As MailItem)
Dim fn As String
Dim xlapp As Object
Dim wb As Object
    
    fn = "c:\deleteme\Q_26485542 " & Format(Now(), "dd mmm yyyy") & ".xlsx"
    Set xlapp = CreateObject("excel.application")
    On Error Resume Next
    Set wb = xlapp.workbooks.Open(fn)
    On Error GoTo 0
    If wb Is Nothing Then
        Set wb = xlapp.workbooks.Add
        wb.sheets(1).Range("A1") = "Employee"
        wb.sheets(1).Range("B1") = "ID"
        wb.sheets(1).Range("C1") = "Job Title"
        wb.sheets(1).Range("D1") = "Nation"
        wb.sheets(1).Range("E1") = "Manager"
        wb.saveas fn
    End If
    Q_26485542b mai, wb
    wb.Close True
    xlapp.Quit

End Sub
Sub Q_26485542a()
Dim fn As String
Dim mai As Object
Dim xlapp As Object
Dim wb As Object
    
    fn = "c:\deleteme\Q_26485542 " & Format(Now(), "dd mmm yyyy") & ".xlsx"
    Set xlapp = CreateObject("excel.application")
    On Error Resume Next
    Set wb = xlapp.workbooks.Open(fn)
    On Error GoTo 0
    If wb Is Nothing Then
        Set wb = xlapp.workbooks.Add
        wb.sheets(1).Range("A1") = "Employee"
        wb.sheets(1).Range("B1") = "ID"
        wb.sheets(1).Range("C1") = "Job Title"
        wb.sheets(1).Range("D1") = "Nation"
        wb.sheets(1).Range("E1") = "Manager"
        wb.saveas fn
    End If
    For Each mai In Application.Session.PickFolder.items
        If mai.Class = olMail Then
            Q_26485542b mai, wb
        End If
    Next
    wb.Close True
    xlapp.Quit

End Sub

Sub Q_26485542b(mai As MailItem, wb As Object)
Dim ln As Variant
Dim arr() As String
Dim str As String
Dim rw As Long
Static regex As Object
Const xlup As Integer = -4162
    
    If InStr(LCase(mai.body), LCase("The person noted here is leaving the organisation on")) = 0 Then Exit Sub
    If regex Is Nothing Then Set regex = CreateObject("vbscript.regexp")
    rw = wb.sheets(1).Range("A" & wb.sheets(1).Rows.count).End(xlup).Row + 1
    For Each ln In Split(Replace(mai.body, Chr(160), " "), vbCrLf)
' Employee
        If valDatabyRegEx(CStr(ln), "(Employee: *)([a-z]*)(, *)([a-z]*)( *\(.*)") Then
            With regex
                .Pattern = "(Employee: *)([a-z]*)(, *)([a-z]*)( *\(.*)"
                .Global = False
                .IgnoreCase = True
            End With
            str = regex.Replace(ln, "$4 $2")
            wb.sheets(1).Range("A" & rw) = Trim(str)
        End If
' ID
        If valDatabyRegEx(CStr(ln), "(.*\()(IN[0-9]*)(\).*)") Then
            With regex
                .Pattern = "(.*\()(IN[0-9]*)(\).*)"
                .Global = False
                .IgnoreCase = True
            End With
            str = regex.Replace(ln, "$2")
            wb.sheets(1).Range("B" & rw) = Trim(str)
        End If
' Job Title
        If valDatabyRegEx(CStr(ln), "(.*Job Title: *)([a-z -_]*)(\r\n|office location:).*") Then
            With regex
                .Pattern = "(.*Job Title: *)([a-z -_]*)(\r\n|office location:.*)"
                .Global = False
                .IgnoreCase = True
            End With
            str = regex.Replace(ln, "$2")
            wb.sheets(1).Range("C" & rw) = Trim(str)
        End If
' Nation
        If valDatabyRegEx(CStr(ln), "(.*)(office location: *)([a-z _-]*)(.*)") Then
            With regex
                .Pattern = "(.*)(office location: *)([a-z _-]*)(.*)"
                .Global = False
                .IgnoreCase = True
            End With
            str = regex.Replace(ln, "$3")
            wb.sheets(1).Range("D" & rw) = Trim(str)
        End If
' Manager
        If valDatabyRegEx(CStr(ln), "(manager: *)([a-z -_]*)(.*)") Then
            With regex
                .Pattern = "(manager: *)([a-z -_]*)(.*)"
                .Global = False
                .IgnoreCase = True
            End With
            str = regex.Replace(ln, "$2")
            arr = Split(str, ",")
            If Abs(UBound(arr)) = 1 Then
                arr = Split(str, " ")
                If Abs(UBound(arr)) = 1 Then
                    wb.sheets(1).Range("E" & rw) = Trim(str)
                Else
                    wb.sheets(1).Range("E" & rw) = Trim(arr(1)) & " " & Trim(arr(0))
                End If
            Else
                wb.sheets(1).Range("E" & rw) = Trim(arr(1)) & " " & Trim(arr(0))
            End If
        End If
    Next

End Sub

Function valDatabyRegEx(strFindin As String, strPattern As String, Optional bolMatchCase As Boolean = False) As Boolean
    
    With CreateObject("vbscript.regexp")
        .IgnoreCase = Not bolMatchCase
        .Pattern = strPattern
        valDatabyRegEx = .test(strFindin) = True
    End With
    
End Function

Open in new window

0
 
LVL 11

Author Comment

by:bsharath
ID: 33723289
Thanks all fine
2 issues
1. If a file is already available with same date it does not get updated into it rather asks to save in new file.
2. I have this in the body "The person noted here is leaving the organisation on 10/09/2010."

i want the date into a colum and the email received date as well
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 33723345
1. HAve you got the file open?

2. Already chedcking for this so what's the problem

3. Which data into a column, and adding a date can do - received date?

Chris
0
 
LVL 11

Author Comment

by:bsharath
ID: 33725031
1. When i ran the macro 2nd time it asked me to save the file as "Copy of Q_26485542 21 Sep 2010"

2. In this line i have the date we need to get the date also.

3. Received date in a colum and another colum the date in this line. "The person noted here is leaving the organisation on 10/09/2010."
0
 
LVL 59

Accepted Solution

by:
Chris Bottomley earned 500 total points
ID: 33725902
1. Therefore you must have a copy of the file open.  Try closing all instances of excel and then checking in the task manager for an instance of excel.exe.

2. Date addendum - try the following

Chris
Sub Q_26485542(mai As MailItem)
Dim fn As String
Dim xlapp As Object
Dim wb As Object
    
    fn = "c:\deleteme\Q_26485542 " & Format(Now(), "dd mmm yyyy") & ".xlsx"
    Set xlapp = CreateObject("excel.application")
    On Error Resume Next
    Set wb = xlapp.workbooks.Open(fn)
    On Error GoTo 0
    If wb Is Nothing Then
        Set wb = xlapp.workbooks.Add
        wb.sheets(1).Range("A1") = "Employee"
        wb.sheets(1).Range("B1") = "ID"
        wb.sheets(1).Range("C1") = "Job Title"
        wb.sheets(1).Range("D1") = "Nation"
        wb.sheets(1).Range("E1") = "Manager"
        wb.sheets(1).Range("F1") = "Leaving Date"
        wb.saveas fn
    End If
    Q_26485542b mai, wb
    wb.Close True
    xlapp.Quit

End Sub
Sub Q_26485542a()
Dim fn As String
Dim mai As Object
Dim xlapp As Object
Dim wb As Object
    
    fn = "c:\deleteme\Q_26485542 " & Format(Now(), "dd mmm yyyy") & ".xlsx"
    Set xlapp = CreateObject("excel.application")
    On Error Resume Next
    Set wb = xlapp.workbooks.Open(fn)
    On Error GoTo 0
    If wb Is Nothing Then
        Set wb = xlapp.workbooks.Add
        wb.sheets(1).Range("A1") = "Employee"
        wb.sheets(1).Range("B1") = "ID"
        wb.sheets(1).Range("C1") = "Job Title"
        wb.sheets(1).Range("D1") = "Nation"
        wb.sheets(1).Range("E1") = "Manager"
        wb.sheets(1).Range("F1") = "Leaving Date"
        wb.saveas fn
    End If
    For Each mai In Application.Session.PickFolder.items
        If mai.Class = olMail Then
            Q_26485542b mai, wb
        End If
    Next
    wb.Close True
    xlapp.Quit

End Sub

Sub Q_26485542b(mai As MailItem, wb As Object)
Dim ln As Variant
Dim arr() As String
Dim str As String
Dim rw As Long
Static regex As Object
Const xlup As Integer = -4162
    
    If InStr(LCase(mai.body), LCase("The person noted here is leaving the organisation on")) = 0 Then Exit Sub
    If regex Is Nothing Then Set regex = CreateObject("vbscript.regexp")
    rw = wb.sheets(1).Range("A" & wb.sheets(1).Rows.count).End(xlup).Row + 1
    For Each ln In Split(Replace(mai.body, Chr(160), " "), vbCrLf)
' Employee
        If valDatabyRegEx(CStr(ln), "(Employee: *)([a-z]*)(, *)([a-z]*)( *\(.*)") Then
            With regex
                .Pattern = "(Employee: *)([a-z]*)(, *)([a-z]*)( *\(.*)"
                .Global = False
                .IgnoreCase = True
            End With
            str = regex.Replace(ln, "$4 $2")
            wb.sheets(1).Range("A" & rw) = Trim(str)
        End If
' ID
        If valDatabyRegEx(CStr(ln), "(.*\()(IN[0-9]*)(\).*)") Then
            With regex
                .Pattern = "(.*\()(IN[0-9]*)(\).*)"
                .Global = False
                .IgnoreCase = True
            End With
            str = regex.Replace(ln, "$2")
            wb.sheets(1).Range("B" & rw) = Trim(str)
        End If
' Job Title
        If valDatabyRegEx(CStr(ln), "(.*Job Title: *)([a-z -_]*)(\r\n|office location:).*") Then
            With regex
                .Pattern = "(.*Job Title: *)([a-z -_]*)(\r\n|office location:.*)"
                .Global = False
                .IgnoreCase = True
            End With
            str = regex.Replace(ln, "$2")
            wb.sheets(1).Range("C" & rw) = Trim(str)
        End If
' Nation
        If valDatabyRegEx(CStr(ln), "(.*)(office location: *)([a-z _-]*)(.*)") Then
            With regex
                .Pattern = "(.*)(office location: *)([a-z _-]*)(.*)"
                .Global = False
                .IgnoreCase = True
            End With
            str = regex.Replace(ln, "$3")
            wb.sheets(1).Range("D" & rw) = Trim(str)
        End If
' Manager
        If valDatabyRegEx(CStr(ln), "(manager: *)([a-z -_]*)(.*)") Then
            With regex
                .Pattern = "(manager: *)([a-z -_]*)(.*)"
                .Global = False
                .IgnoreCase = True
            End With
            str = regex.Replace(ln, "$2")
            arr = Split(str, ",")
            If Abs(UBound(arr)) = 1 Then
                arr = Split(str, " ")
                If Abs(UBound(arr)) = 1 Then
                    wb.sheets(1).Range("E" & rw) = Trim(str)
                Else
                    wb.sheets(1).Range("E" & rw) = Trim(arr(1)) & " " & Trim(arr(0))
                End If
            Else
                wb.sheets(1).Range("E" & rw) = Trim(arr(1)) & " " & Trim(arr(0))
            End If
        End If
' Leaving Date
        If valDatabyRegEx(CStr(ln), "(The person noted here is leaving the organisation on )([0-9]{1,2}/[0-9]{1,2}/[0-9]{1,4})(.*)") Then
            With regex
                .Pattern = "(The person noted here is leaving the organisation on )([0-9]{1,2}/[0-9]{1,2}/[0-9]{1,4})(.*)"
                .Global = False
                .IgnoreCase = True
            End With
            str = regex.Replace(ln, "$2")
            wb.sheets(1).Range("F" & rw) = Trim(str)
        End If
    Next

End Sub

Function valDatabyRegEx(strFindin As String, strPattern As String, Optional bolMatchCase As Boolean = False) As Boolean
    
    With CreateObject("vbscript.regexp")
        .IgnoreCase = Not bolMatchCase
        .Pattern = strPattern
        valDatabyRegEx = .test(strFindin) = True
    End With
    
End Function

Open in new window

0
 
LVL 11

Author Comment

by:bsharath
ID: 33727460
Thanks Chris works perfect
0
 
LVL 11

Author Comment

by:bsharath
ID: 33727659
Chris when i need to create a rule to run on mail arrival. I cannot see the macro
is there anything i need to change
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 33727759
Should be:

Q_26485542

Chris
0
 
LVL 11

Author Comment

by:bsharath
ID: 33727783
but i dont get them shown in the rule when i click the script to create one
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 33728302
As I say Q_26485542 is it ... you should have the parameter mai as mailitem therein.  I have double checked it shows for me ... you do have it in a normal code module .... and only one copy - try searching for the string ... but the a and b affixes are of course different subs.

Chris
0
 
LVL 11

Author Comment

by:bsharath
ID: 33731157
Thanks Chris i had duplicate codes in 2 modules. Now it works
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 33731914
THanks, and I do appreciate your coming back to say it's resolved.

Chris
0
 
LVL 11

Author Comment

by:bsharath
ID: 33745968
0

Featured Post

Technology Partners: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

How to resolve IMCEAEX NDRs in Exchange or Exchange Online related to invalid X500 addresses.
I was prompted to write this article after the recent World-Wide Ransomware outbreak. For years now, System Administrators around the world have used the excuse of "Waiting a Bit" before applying Security Patch Updates. This type of reasoning to me …
Learn how to create and modify your own paragraph styles in Microsoft Word. This can be helpful when wanting to make consistently referenced styles throughout a document or template.
A short tutorial showing how to set up an email signature in Outlook on the Web (previously known as OWA). For free email signatures designs, visit https://www.mail-signatures.com/articles/signature-templates/?sts=6651 If you want to manage em…

726 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question