Solved

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

Posted on 2010-09-20
32
696 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
  • 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
 
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
How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

 
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

Do You Know the 4 Main Threat Actor Types?

Do you know the main threat actor types? Most attackers fall into one of four categories, each with their own favored tactics, techniques, and procedures.

Join & Write a Comment

Not sure what the best email signature size is? Are you worried about email signature image size? Follow this best practice guide.
This article descibes how to create a connection between Excel and SAP and how to move data from Excel to SAP or the other way around.
This video shows where to find templates, what they are used for, and how to create and save a custom template using Microsoft Word.
Learn how to make your own table of contents in Microsoft Word using paragraph styles and the automatic table of contents tool. We'll be using the paragraph styles in Word’s Home toolbar to help you create a table of contents. Type out your initial …

758 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

Need Help in Real-Time?

Connect with top rated Experts

21 Experts available now in Live!

Get 1:1 Help Now