Outlook macro to copy arrived emails body into excel files.

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
LVL 11
bsharathAsked:
Who is Participating?
 
Chris BottomleySoftware Quality Lead EngineerCommented:
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
 
Chris BottomleySoftware Quality Lead EngineerCommented:
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
 
bsharathAuthor Commented:
Thanks Chris works perfect. one q here
How can i run this on a folder which has mails already in them
0
Ultimate Tool Kit for Technology Solution Provider

Broken down into practical pointers and step-by-step instructions, the IT Service Excellence Tool Kit delivers expert advice for technology solution providers. Get your free copy now.

 
Chris BottomleySoftware Quality Lead EngineerCommented:
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
 
bsharathAuthor Commented:
I get subscript out of range
When debug goes here
            details = Trim(Split(ln, ":")(1))

This folder will have other emails also
0
 
Chris BottomleySoftware Quality Lead EngineerCommented:
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
 
Chris BottomleySoftware Quality Lead EngineerCommented:
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
 
bsharathAuthor Commented:
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
 
Chris BottomleySoftware Quality Lead EngineerCommented:
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
 
bsharathAuthor Commented:
Why i asked is i get subscript out of range
When debug goes here
                workflowID = Replace(Trim(Split(ln, "=")(1)), ")", "")
0
 
Chris BottomleySoftware Quality Lead EngineerCommented:
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
 
bsharathAuthor Commented:
I get subscript out of range in this line

                strTemp = Split(ln, ",")(1)
0
 
bsharathAuthor Commented:
Chris no errors works fine now.
Only issue is the name in colum "H" and "G" workflow data is missing for all.
0
 
Chris BottomleySoftware Quality Lead EngineerCommented:
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
 
bsharathAuthor Commented:
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.