Solved

Outlook macro to copy arrived emails body into excel files.

Posted on 2010-09-16
15
928 Views
Last Modified: 2012-05-10
Hi,

Need an outlook script to save mails with this subject "Task has been assigned to you for the Incident ID 89859"
The only change between these subjects would be the ID at the end. Remaing would be same.

When mail arrives the data within the mail would be as this

Incident Id        :  89859
Raised User       :  Vajan
Summary          :  Leaver - service request: IN - Raj, Anu (WorkflowID = 8940489)
Details                 :  Nt id and email to be disabled
System to be taken back tp stock
Date                 :  14/09/2010 16:28:31 [GMT Daylight Time (GMT+01:00)]


It has to save each mail into an excel as the attached format.After it has done it has to popup a box stating new data copied. Each day i receive from 1 email to 20. So only once i need to get the popup.

Can we schedule a time? if thats difficult. Then that part i will check manually.

regards
Sharath
Outlook-to-excel.xls
0
Comment
Question by:bsharath
  • 8
  • 7
15 Comments
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 33703550
An outlook macro to implement the code is as follows.  Easiest way to call is create a rule triggered by subject like
"Task has been assigned to you for the Incident ID "

(i.e. with specific words in the subject).

Call the script Q26477149 in such cases and then having edited the file name/location from
C:\Users\Chris\Experts Exchange\Outlook-to-excel.xls
to your own needs it should write the data out ... but from my perspective that's enough for one question assuming it works.

Chris
Sub Q26477149(mai As MailItem)

Dim dateRecd As String

Dim id As String

Dim raised As String

Dim summary As String

Dim details As String

Dim dateDue As String

Dim workflowID As String

Dim Name As String

Dim ln As Variant

Dim strTemp As String

Dim xlApp As Object

Dim rw As Long

Const xlup As Integer = -4162



    dateRecd = Format(mai.ReceivedTime, "ddd dd/mm/yyyy")

'    id = getDatabyRegEx(mai.body, "(Incident Id[ \xA0]+?:[ \xA0]+)([0-9]{1,})")

'    raised = getDatabyRegEx(mai.body, "(Raised User[ \xA0]+?:[ \xA0]+)([\w\s]{1,}[\r\n])")

'    summary = getDatabyRegEx(mai.body, "(Summary[ \xA0]+?:[ \xA0]+)(.*)[\r\n]")

    For Each ln In Split(Replace(mai.body, Chr(160), " "), vbCrLf)

        If LCase(ln) Like "incident id*" Then

            id = Trim(Split(ln, ":")(1))

        ElseIf LCase(ln) Like "raised user*" Then

            raised = Trim(Split(ln, ":")(1))

        ElseIf LCase(ln) Like "summary*" Then

            summary = Trim(Split(ln, ":")(1))

            workflowID = Replace(Trim(Split(ln, "=")(1)), ")", "")

            strTemp = Split(ln, ",")(1)

            Name = Trim(Split(strTemp, "(")(0)) & " "

            strTemp = Split(ln, ",")(0)

            Name = Name & Split(strTemp, "-")(UBound(Split(strTemp, "-")))

        ElseIf LCase(ln) Like "details*" Then

            details = Trim(Split(ln, ":")(1))

        ElseIf LCase(ln) Like "date*" Then

            dateDue = Split(Trim(Split(ln, ":")(1)), " ")(0)

        End If

    Next

    Set xlApp = CreateObject("excel.application")

    With xlApp.workbooks.Open("C:\Users\Chris\Experts Exchange\Outlook-to-excel.xls")

        rw = .sheets(1).Range("A" & .sheets(1).Rows.count).End(xlup).Row + 1

        .sheets(1).Range("A" & rw) = dateRecd

        .sheets(1).Range("B" & rw) = id

        .sheets(1).Range("C" & rw) = raised

        .sheets(1).Range("D" & rw) = summary

        .sheets(1).Range("E" & rw) = details

        .sheets(1).Range("F" & rw) = dateDue

        .sheets(1).Range("G" & rw) = workflowID

        .sheets(1).Range("H" & rw) = Name

        .Close True

    End With

    xlApp.Quit

End Sub

Open in new window

0
 
LVL 11

Author Comment

by:bsharath
ID: 33703677
Thanks Chris works perfect. one q here
How can i run this on a folder which has mails already in them
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 33703961
Something for example like the following which assumes you have selected the folder first.

Chris
Sub catchup()

Dim itm As Object



    For Each itm In Application.ActiveExplorer.CurrentFolder.items

        If itm.Class = olMail Then Q26477149 itm

    Next

End Sub

Open in new window

0
 
LVL 11

Author Comment

by:bsharath
ID: 33704076
I get subscript out of range
When debug goes here
            details = Trim(Split(ln, ":")(1))

This folder will have other emails also
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 33704121
I would imagine the email does not follow the standards set out in your original question ... i.e. no :

The catchup script as supplied ensures only emails are passed to the sub so that's a non issue hopefully.

Chris
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 33704144
The following amendment skips a line if the colon is missing.

Chris
Sub Q26477149(mai As MailItem)

Dim dateRecd As String

Dim id As String

Dim raised As String

Dim summary As String

Dim details As String

Dim dateDue As String

Dim workflowID As String

Dim Name As String

Dim ln As Variant

Dim strTemp As String

Dim xlApp As Object

Dim rw As Long

Const xlup As Integer = -4162



    dateRecd = Format(mai.ReceivedTime, "ddd dd/mm/yyyy")

'    id = getDatabyRegEx(mai.body, "(Incident Id[ \xA0]+?:[ \xA0]+)([0-9]{1,})")

'    raised = getDatabyRegEx(mai.body, "(Raised User[ \xA0]+?:[ \xA0]+)([\w\s]{1,}[\r\n])")

'    summary = getDatabyRegEx(mai.body, "(Summary[ \xA0]+?:[ \xA0]+)(.*)[\r\n]")

    For Each ln In Split(Replace(mai.body, Chr(160), " "), vbCrLf)

        If InStr(ln, ":") > 0 Then

            If LCase(ln) Like "incident id*" Then

                id = Trim(Split(ln, ":")(1))

            ElseIf LCase(ln) Like "raised user*" Then

                raised = Trim(Split(ln, ":")(1))

            ElseIf LCase(ln) Like "summary*" Then

                summary = Trim(Split(ln, ":")(1))

                workflowID = Replace(Trim(Split(ln, "=")(1)), ")", "")

                strTemp = Split(ln, ",")(1)

                Name = Trim(Split(strTemp, "(")(0)) & " "

                strTemp = Split(ln, ",")(0)

                Name = Name & Split(strTemp, "-")(UBound(Split(strTemp, "-")))

            ElseIf LCase(ln) Like "details*" Then

                details = Trim(Split(ln, ":")(1))

            ElseIf LCase(ln) Like "date*" Then

                dateDue = Split(Trim(Split(ln, ":")(1)), " ")(0)

            End If

        End If

    Next

    Set xlApp = CreateObject("excel.application")

    With xlApp.workbooks.Open("C:\Users\Chris\Experts Exchange\Outlook-to-excel.xls")

        rw = .sheets(1).Range("A" & .sheets(1).Rows.count).End(xlup).Row + 1

        .sheets(1).Range("A" & rw) = dateRecd

        .sheets(1).Range("B" & rw) = id

        .sheets(1).Range("C" & rw) = raised

        .sheets(1).Range("D" & rw) = summary

        .sheets(1).Range("E" & rw) = details

        .sheets(1).Range("F" & rw) = dateDue

        .sheets(1).Range("G" & rw) = workflowID

        .sheets(1).Range("H" & rw) = Name

        .Close True

    End With

    xlApp.Quit

End Sub

Open in new window

0
 
LVL 11

Author Comment

by:bsharath
ID: 33707225
Chris if any one of the fields are missing in the email. Can we skip them and go to next.
Skip i mean just the field and not the email
0
Complete VMware vSphere® ESX(i) & Hyper-V Backup

Capture your entire system, including the host, with patented disk imaging integrated with VMware VADP / Microsoft VSS and RCT. RTOs is as low as 15 seconds with Acronis Active Restore™. You can enjoy unlimited P2V/V2V migrations from any source (even from a different hypervisor)

 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 33707306
That's how it's coded already:

    For Each ln In Split(Replace(mai.body, Chr(160), " "), vbCrLf)
        If InStr(ln, ":") > 0 Then
            If LCase(ln) Like "incident id*" Then
'etc
            End If
        End If
    Next

ie for each email, check if the line contains a colon and if it doesn't then skip the line and check the next line in the same email ... the implementation uses the colon from the original specification to differentiate between data and label.

Chris
0
 
LVL 11

Author Comment

by:bsharath
ID: 33707371
Why i asked is i get subscript out of range
When debug goes here
                workflowID = Replace(Trim(Split(ln, "=")(1)), ")", "")
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 33707449
Try this then ... it adds additional checks for the other data formatting.

Chris
Sub Q26477149(mai As MailItem)

Dim dateRecd As String

Dim id As String

Dim raised As String

Dim summary As String

Dim details As String

Dim dateDue As String

Dim workflowID As String

Dim Name As String

Dim ln As Variant

Dim strTemp As String

Dim xlApp As Object

Dim rw As Long

Const xlup As Integer = -4162



    dateRecd = Format(mai.ReceivedTime, "ddd dd/mm/yyyy")

    For Each ln In Split(Replace(mai.body, Chr(160), " "), vbCrLf)

        If InStr(ln, ":") > 0 Then

            If LCase(ln) Like "incident id*" Then

                id = Trim(Split(ln, ":")(1))

            ElseIf LCase(ln) Like "raised user*" Then

                raised = Trim(Split(ln, ":")(1))

            ElseIf LCase(ln) Like "summary*" Then

                summary = Trim(Split(ln, ":")(1))

                if instr(strtemp, "=") > 0 then

                    workflowID = Replace(Trim(Split(ln, "=")(1)), ")", "")

                end if

                strTemp = Split(ln, ",")(1)

                if instr(strtemp, "(") > 0 then

                    Name = Trim(Split(strTemp, "(")(0)) & " "

                end if

                strTemp = Split(ln, ",")(0)

                if instr(strtemp, "=") > 0 then

                    Name = Name & Split(strTemp, "-")(UBound(Split(strTemp, "-")))

                end if

            ElseIf LCase(ln) Like "details*" Then

                details = Trim(Split(ln, ":")(1))

            ElseIf LCase(ln) Like "date*" Then

                dateDue = Split(Trim(Split(ln, ":")(1)), " ")(0)

            End If

        End If

    Next

    Set xlApp = CreateObject("excel.application")

    With xlApp.workbooks.Open("C:\Users\Chris\Experts Exchange\Outlook-to-excel.xls")

        rw = .sheets(1).Range("A" & .sheets(1).Rows.count).End(xlup).Row + 1

        .sheets(1).Range("A" & rw) = dateRecd

        .sheets(1).Range("B" & rw) = id

        .sheets(1).Range("C" & rw) = raised

        .sheets(1).Range("D" & rw) = summary

        .sheets(1).Range("E" & rw) = details

        .sheets(1).Range("F" & rw) = dateDue

        .sheets(1).Range("G" & rw) = workflowID

        .sheets(1).Range("H" & rw) = Name

        .Close True

    End With

    xlApp.Quit

End Sub

Open in new window

0
 
LVL 11

Author Comment

by:bsharath
ID: 33707468
I get subscript out of range in this line

                strTemp = Split(ln, ",")(1)
0
 
LVL 59

Accepted Solution

by:
Chris Bottomley earned 500 total points
ID: 33707578
Oops.  Further refined

Chris
Sub Q26477149(mai As MailItem)

Dim dateRecd As String

Dim id As String

Dim raised As String

Dim summary As String

Dim details As String

Dim dateDue As String

Dim workflowID As String

Dim Name As String

Dim ln As Variant

Dim strTemp As String

Dim xlApp As Object

Dim rw As Long

Const xlup As Integer = -4162



    If InStr(mai.body, vbCrLf) = 0 Then Exit Sub

    dateRecd = Format(mai.ReceivedTime, "ddd dd/mm/yyyy")

    For Each ln In Split(Replace(mai.body, Chr(160), " "), vbCrLf)

        If InStr(ln, ":") > 0 Then

            If LCase(ln) Like "incident id*" Then

                id = Trim(Split(ln, ":")(1))

            ElseIf LCase(ln) Like "raised user*" Then

                raised = Trim(Split(ln, ":")(1))

            ElseIf LCase(ln) Like "summary*" Then

                summary = Trim(Split(ln, ":")(1))

                If InStr(strTemp, "=") > 0 Then

                    workflowID = Replace(Trim(Split(ln, "=")(1)), ")", "")

                End If

                If InStr(strTemp, "(") > 0 And InStr(strTemp, ",") > 0 Then

                    strTemp = Split(ln, ",")(1)

                    Name = Trim(Split(strTemp, "(")(0)) & " "

                End If

                If InStr(strTemp, "=") > 0 And InStr(strTemp, ",") > 0 Then

                    strTemp = Split(ln, ",")(0)

                    Name = Name & Split(strTemp, "-")(UBound(Split(strTemp, "-")))

                End If

            ElseIf LCase(ln) Like "details*" Then

                details = Trim(Split(ln, ":")(1))

            ElseIf LCase(ln) Like "date*" Then

                dateDue = Split(Trim(Split(ln, ":")(1)), " ")(0)

            End If

        End If

    Next

    Set xlApp = CreateObject("excel.application")

    With xlApp.workbooks.Open("C:\Users\Chris\Experts Exchange\Outlook-to-excel.xls")

        rw = .sheets(1).Range("A" & .sheets(1).Rows.count).End(xlup).Row + 1

        .sheets(1).Range("A" & rw) = dateRecd

        .sheets(1).Range("B" & rw) = id

        .sheets(1).Range("C" & rw) = raised

        .sheets(1).Range("D" & rw) = summary

        .sheets(1).Range("E" & rw) = details

        .sheets(1).Range("F" & rw) = dateDue

        .sheets(1).Range("G" & rw) = workflowID

        .sheets(1).Range("H" & rw) = Name

        .Close True

    End With

    xlApp.Quit

End Sub

Open in new window

0
 
LVL 11

Author Comment

by:bsharath
ID: 33707900
Chris no errors works fine now.
Only issue is the name in colum "H" and "G" workflow data is missing for all.
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 33707971
Name and workflow are highly dependant on data formatting ... if it works ok for the original sample and not the others then I suggest the solution is good and that you need it adapting for resilience.

If you were to ask a new question for that then you will need to supply a range of text samples and required outcomes for the name/workflow id so that a potential regular expression based solution can be used to analyse for the data.

Aspects I suspect you need to address in such a data sample are multiple names i.e. first names fred john and lastnames Smith Jones ... i.e. Smith Jones, Fred John

Chris
0
 
LVL 11

Author Comment

by:bsharath
ID: 33710299
0

Featured Post

Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

Question has a verified solution.

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

As with any other System Center product, the installation for the Authoring Tool can be quite a pain sometimes. This article serves to help you avoid making these mistakes and hopefully save you a ton of time on troubleshooting :)  Step 1: Make sur…
Follow this checklist to learn more about the 15 things you should never include in an email signature from personal quotes, animated gifs and out-of-date marketing content.
Excel styles will make formatting consistent and let you apply and change formatting faster. In this tutorial, you'll learn how to use Excel's built-in styles, how to modify styles, and how to create your own. You'll also learn how to use your custo…
Access reports are powerful and flexible. Learn how to create a query and then a grouped report using the wizard. Modify the report design after the wizard is done to make it look better. There will be another video to explain how to put the final p…

867 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

12 Experts available now in Live!

Get 1:1 Help Now