Solved

Outlook macro to copy arrived emails body into excel files.

Posted on 2010-09-16
15
927 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
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comprehensive Backup Solutions for Microsoft

Acronis protects the complete Microsoft technology stack: Windows Server, Windows PC, laptop and Surface data; Microsoft business applications; Microsoft Hyper-V; Azure VMs; Microsoft Windows Server 2016; Microsoft Exchange 2016 and SQL Server 2016.

 
LVL 59

Expert Comment

by:Chris Bottomley
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comment Utility
0

Featured Post

Top 6 Sources for Identifying Threat Actor TTPs

Understanding your enemy is essential. These six sources will help you identify the most popular threat actor tactics, techniques, and procedures (TTPs).

Join & Write a Comment

Technology opened people to different means of presenting information, but PowerPoint remains to be above competition. Know why PPT still works today.
Sometimes Outlook might have problems sending a message. There may be various causes- corrupted PST, AV scanner etc. The message, instead of going to the Sent Items folder, sits in the Outbox indefinitely. To remove it you can use a free tool cal…
The view will learn how to download and install SIMTOOLS and FORMLIST into Excel, how to use SIMTOOLS to generate a Monte Carlo simulation of 30 sales calls, and how to calculate the conditional probability based on the results of the Monte Carlo …
To add imagery to an HTML email signature, you have two options available to you. You can either add a logo/image by embedding it directly into the signature or hosting it externally and linking to it. The vast majority of email clients display l…

772 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

15 Experts available now in Live!

Get 1:1 Help Now