Macro to parse emails and get information into excel, thanks Ben.

Here’s the rule/macro I’m using to capture the SN Catalog Tasks to Excel. The code for the macro is below and that needs to be added to Outlook first. There are some security settings that need to be changed before Outlook will run the code, so that may be of concern (an alternative would be a VBScript file that would access the mailbox for you allowing you to keep code out of Outlook). Tools -> Macro -> Visual Basic Editor (or Alt+F11) will get you to the VBA code editor.

After the code is in place, a normal rule in Outlook can run the modules with the “run a script” action. Here’s how I have my rule set:

The spreadsheet I use is attached. It will probably give you a macro warning because it also has a function (UserSSO()) to lookup a login in Active Directory. It’s set to multi-user mode so Outlook can continue writing to it if it’s open, but the new records seem to show up until it’s been closed and reopened.

There are a couple references to be setup (in the code editor: Tools -> References…)  before this code will run

Microsoft ActiveX Data Objects… is needed to write to Excel with an SQL statement.

Active DS Type Library is needed to look up the agent’s login in Active Directory based on the name provided in the ticket.

Public Sub LogRequest(MailMessage As Outlook.MailItem)

'Public Sub LogRequest() '(MailMessage As Outlook.MailItem)

    Dim LogPath As String

    Dim ConnectionString As String

    Dim InsertCommand As String

    Dim olConnection As ADODB.Connection

    LogPath = "C:\Users\a698060\Documents\Current Projects\CatalogTasks.xlsb"

    ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=""" & LogPath & """;Extended Properties=""Excel 12.0 Xml;HDR=YES"";"

    Set olConnection = New ADODB.Connection

    'olConnection.Execute "select * from [Sheet1$]"

    If InStr(1, MailMessage.Subject, "has been assigned to you") > 5 Then Exit Sub

    Dim MessageBody As String

    Dim ReceivedDT As String

    Dim TaskID As String

    Dim RequestID As String

    Dim AssociateName As String

    Dim AccessType As String

    Dim UserType As String

    Dim DBName As String

    Dim ServerName As String

    Dim SecurityAccess As String

    Dim SelectInd As String

    Dim UpdateInd As String

    Dim InsertInd As String

    Dim DeleteInd As String

    Dim Notes As String

    Dim AssociateSSO As String

    Dim Hyperlink As String

    Dim HyperlinkTmp As String

    MessageBody = MailMessage.Body

    'MsgBox MessageBody

    'Notes = "Catalog Task TASK110993 has been assigned to group SQL DBA"

    'ReceivedDT = "2015-07-22"

    'MsgBox Mid(MessageBody, InStr(1, MessageBody, "Click here to view"), 1000)

    'Dim testEntry As String

    'testEntry = "Parent Number: RITM171796" & vbCrLf & _

    '    "Parent Item: SQL" & vbCrLf & _

    '    "Task Description: Provision SQL Database Access" & vbCrLf & _

    '    "Requested For: Puthiyedath, Sudheesh " & vbCrLf & _

    '    "Assignment group: SQL DBA" & vbCrLf & _

    '    "Request options selected:" & vbCrLf & _

    '    "     Who do you wish to request an access change for? = Puthiyedath, Sudheesh " & vbCrLf & _

    '    "     Cannot find user = false" & vbCrLf & _

    '    "     Enter new user's name = " & vbCrLf & _

    '    "     Who is this user's manager? = " & vbCrLf & _

    '    "     Approver = Coquyt, Jeff " & vbCrLf & _

    '    "     User location = Onshore: Inside the United States or territory/possession of United States" & vbCrLf & _

    '    "     Access type = Add" & vbCrLf & _

    '    "     User Type = Service Account" & vbCrLf & _

    '    "     Database Name = eFileODSReporting" & vbCrLf & _

    '    "     Database Location (server name) = tstodssql01.hrbinc.hrblock.net:1433" & vbCrLf & _

    '    "     Security Access Needed = Windows Authentication (Active Directory)" & vbCrLf & _

    '    "     Select (Read) = true" & vbCrLf & _

    '    "     Update = false" & vbCrLf & _

    '    "     Insert = false" & vbCrLf & _

    '    "     Delete = false" & vbCrLf & _

    '    "     null = " & vbCrLf & _

    '    "     Additional information (include items like specific tables needed or other special requests) = Please give access to Database for the account ecoInstall" & vbCrLf

'''-----------------------Find the keys from the mail message

    ReceivedDT = MailMessage.ReceivedTime

    TaskID = Mid(MailMessage.Subject, 14, 10)

    RequestID = FindKey(MessageBody, "Parent Number", ":")

    AssociateName = FindKey(MessageBody, "Who do you wish to request", "=")

    AccessType = FindKey(MessageBody, "Access type", "=")

    UserType = FindKey(MessageBody, "User Type", "=")

    DBName = FindKey(MessageBody, "Database Name", "=")

    ServerName = FindKey(MessageBody, "Database Location", "=")

    SecurityAccess = FindKey(MessageBody, "Security Access Needed", "=")

    SelectInd = FindKey(MessageBody, "Select", "=")

    UpdateInd = FindKey(MessageBody, "Update", "=")

    InsertInd = FindKey(MessageBody, "Insert", "=")

    DeleteInd = FindKey(MessageBody, "Delete", "=")

    Notes = FindKey(MessageBody, "Additional information", "=")

    '''-----------------------Special code to find the hyperlink

    HyperlinkTmp = FindKey(MessageBody, "Click here to view", ":")

    'Hyperlink = ""

    Dim CurChar As Integer

    Dim InLink As Integer

    Dim CurCharStr As String

    Hyperlink = ""

    InLink = 0

    'MsgBox HyperlinkTmp

    For CurChar = 1 To Len(HyperlinkTmp)

        CurCharStr = Mid(HyperlinkTmp, CurChar, 1)

        If Mid(HyperlinkTmp, CurChar, 1) = """" Then

            If InLink = 0 Then

                InLink = 1

            ElseIf InLink = 1 Then

                Exit For

            End If

        ElseIf InLink = 1 Then

            Hyperlink = Hyperlink & Mid(HyperlinkTmp, CurChar, 1)

        End If

    Next CurChar

'''-----------------------Pad single quotes for inserting into the spreadsheet

    ReceivedDT = Replace(ReceivedDT, "'", "''")

    TaskID = Replace(TaskID, "'", "''")

    RequestID = Replace(RequestID, "'", "''")

    AssociateName = Replace(AssociateName, "'", "''")

    AccessType = Replace(AccessType, "'", "''")

    UserType = Replace(UserType, "'", "''")

    DBName = Replace(DBName, "'", "''")

    ServerName = Replace(ServerName, "'", "''")

    SecurityAccess = Replace(SecurityAccess, "'", "''")

    SelectInd = Replace(SelectInd, "'", "''")

    UpdateInd = Replace(UpdateInd, "'", "''")

    InsertInd = Replace(InsertInd, "'", "''")

    DeleteInd = Replace(DeleteInd, "'", "''")

    Notes = Replace(Notes, "'", "''")

    AssociateSSO = UserSSO(AssociateName)

    InsertCommand = "insert into [Sheet1$] (Received, Task, Parent, Server, DB, AssociateName, AssociateSSO, AccessType, UserType, SecurityAccess, [Select], [Update], [Insert], [Delete], Notes, [Hyperlink])" & vbCrLf & _

    "values('" & ReceivedDT & "', '" & TaskID & "', '" & RequestID & "', '" & ServerName & "', '" & _

        DBName & "', '" & AssociateName & "', '" & AssociateSSO & "', '" & AccessType & "', '" & UserType & "', '" & _

        SecurityAccess & "', '" & SelectInd & "', '" & UpdateInd & "', '" & InsertInd & "', '" & _

        DeleteInd & "', '" & Notes & "', '" & Hyperlink & "')"

    'InsertCommand = "insert into [Sheet1$] (Received, Task, Parent, Server, DB, AssociateName)" & vbCrLf & _

'"values('2015-05-01', 'TASK110993', 'RITM171796', 'tstodssql01.hrbinc.hrblock.net:1433', 'eFileODSReporting', 'Puthiyedath, Sudheesh')"

    'MsgBox InsertCommand

    olConnection.Open ConnectionString

    olConnection.Execute InsertCommand

    olConnection.Close

End Sub

Function FindKey(FindIn As String, FindThis As String, AssignmentInd As String) As String

    Dim KeyStart As Integer

    Dim KeyEnd As Integer

    FindIn = Replace(FindIn, vbCrLf, "<<")

    KeyStart = InStr(1, FindIn, FindThis) + Len(FindThis)

    KeyStart = InStr(KeyStart, FindIn, AssignmentInd) + Len(AssignmentInd) + 1

    KeyEnd = InStr(KeyStart, FindIn, "<<")

    FindKey = Trim(Mid(FindIn, KeyStart, KeyEnd - KeyStart))

End Function

Public Function UserSSO(LoginName As String) As String

    'SOURCE: Interwebs. Same code seen several places, but adapted

    'to fit this need.

    'PURPOSE: Display information that is available in

    'the Active Directory about a given user

    'PARAMETER: LoginName = Users name according to Active Directory

    'RETURNS: SSO associated with the LoginName provided

    'REQUIRES: Windows 2000 ADSI, LDAP Provider

    'Proper Security Credentials.

    'EXAMPLE: msgbox UserInfo("Reese, Benjamin")

    Dim conn As New ADODB.Connection

    Dim rs As ADODB.Recordset

    Dim oRoot As IADs

    Dim oDomain As IADs

    Dim sBase As String

    Dim sFilter As String

    Dim sDomain As String

    Dim sAttribs As String

    Dim sDepth As String

    Dim sQuery As String

    Dim sAns As String

    Dim user As IADsUser

    On Error GoTo ErrHandler:

    'Get user Using LDAP/ADO.  There is an easier way

    'to bind to a user object using the WinNT provider,

    'but this way is a better for educational purposes

    Set oRoot = GetObject("LDAP://rootDSE")

    'work in the default domain

    sDomain = oRoot.Get("defaultNamingContext")

    Set oDomain = GetObject("LDAP://" & sDomain)

    sBase = "<" & oDomain.ADsPath & ">"

    'Only get user name requested

    sFilter = "(&(objectCategory=person)(objectClass=user)(Name=" _

      & LoginName & "))"

    sAttribs = "adsPath"

    sDepth = "subTree"

    sQuery = sBase & ";" & sFilter & ";" & sAttribs & ";" & sDepth

    conn.Open _

      "Data Source=Active Directory Provider;Provider=ADsDSOObject"

    Set rs = conn.Execute(sQuery)

    If Not rs.EOF Then

        Set user = GetObject(rs("adsPath"))

        With user

        'if the attribute is not stored in AD,

        'an error will occur.  Therefore, this

        'will return data only from populated attributes

        On Error Resume Next

        sAns = .sAMAccountName

        End With

    End If

    UserSSO = sAns

ErrHandler:

    On Error Resume Next

    If Not rs Is Nothing Then

        If rs.State <> 0 Then rs.Close

        Set rs = Nothing

    End If

    If Not conn Is Nothing Then

        If conn.State <> 0 Then conn.Close

        Set conn = Nothing

    End If

    Set oRoot = Nothing

    Set oDomain = Nothing