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.
And, the code (update LogPath to be the location of your spreadsheet):
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
|