?
Solved

Outlook macro to copy arrived emails body into excel files.

Posted on 2010-09-16
15
Medium Priority
?
946 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
Free Backup Tool for VMware and Hyper-V

Restore full virtual machine or individual guest files from 19 common file systems directly from the backup file. Schedule VM backups with PowerShell scripts. Set desired time, lean back and let the script to notify you via email upon completion.  

 
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
 
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 2000 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

Get your Conversational Ransomware Defense e‑book

This e-book gives you an insight into the ransomware threat and reviews the fundamentals of top-notch ransomware preparedness and recovery. To help you protect yourself and your organization. The initial infection may be inevitable, so the best protection is to be fully prepared.

Question has a verified solution.

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

I came across an unsolved Outlook issue and here is my solution.
If Skype for Business came with your office 2016 or office 365 installation, you may find that it's almost impossible to either disable or remove it. The application will often launch with each start of Windows, even when explicitly configured not t…
In this video you will find out how to export Office 365 mailboxes using the built in eDiscovery tool. Bear in mind that although this method might be useful in some cases, using PST files as Office 365 backup is troublesome in a long run (more on t…
Enter Foreign and Special Characters Enter characters you can't find on a keyboard using its ASCII code ... and learn how to make a handy reference for yourself using Excel ~ Use these codes in any Windows application! ... whether it is a Micr…
Suggested Courses

578 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