Kaseya Community

Outlook Macro/Script for Event Log Alert E-mail Sorting

This question is not answered

Here I have an Outlook macro/script that is like a rule which can potentially create a directory for each Event ID (after checking if one exists first of course), then put the appropriate e-mail in that directory. However, the script is currently set for "Search for email subjects that contain either an M or Z project number (M007439, Z6312)", as opposed to what we want, the, search for "Event 10001" for example.




' File projects in their own subfolders
' Written by Bryce Pepper (bpepper@kcsouthern.com)
' Searches subject for a M or Z project number (must be between 4-6 digits)
' and files them in a project subfolder (created if one does not exist)
' added support for P & R projects 2009-03-03 B.Pepper
' added support for # to make Bill Z. happy 2009-03-04 B.Pepper

Dim WithEvents objInboxItems As Outlook.Items
Dim objDestinationFolder As Outlook.MAPIFolder

Sub Application_Startup()
Dim objNameSpace As Outlook.NameSpace
Dim objInboxFolder As Outlook.MAPIFolder

Set objNameSpace = Application.Session
Set objInboxFolder = objNameSpace.GetDefaultFolder(olFolderInbox)
Set objInboxItems = objInboxFolder.Items
Set objDestinationFolder = objInboxFolder.Parent.Folders("Projects")
End Sub

' Run this code to stop your rule.
Sub StopRule()
Set objInboxItems = Nothing
End Sub

' This code is the actual rule.
Private Sub objInboxItems_ItemAdd(ByVal Item As Object)
Dim objProjectFolder As Outlook.MAPIFolder
Dim folderName As String

Set objRegEx = CreateObject("VBScript.RegExp")
objRegEx.Global = False
' Search for email subjects that contain either an M or Z project number (M007439, Z6312)
 objRegEx.Pattern = "([M,Z,P,R,#]\d{4,6})"

Set colMatches = objRegEx.Execute(Item.Subject)
If colMatches.Count > 0 Then
For Each myMatch In colMatches
If Left$(myMatch.Value, 1) = "#" Then
folderName = "M" & Right$("00" & Mid$(myMatch.Value, 2), 6)
folderName = Left$(myMatch.Value, 1) & Right$("00" & Mid$(myMatch.Value, 2), 6)
End If

If FolderExists(objDestinationFolder, folderName) Then
Set objProjectFolder = objDestinationFolder.Folders(folderName)
Set objProjectFolder = objDestinationFolder.Folders.Add(folderName)
End If
Item.Move objProjectFolder
End If

Set objProjectFolder = Nothing
End Sub

Function FolderExists(parentFolder As MAPIFolder, folderName As String)

Set objRegEx = CreateObject("VBScript.RegExp")
objRegEx.Global = False
objRegEx.Pattern = "(" & folderName & ".*)"

For Each F In parentFolder.Folders
Set colMatches = objRegEx.Execute(F.Name)
If colMatches.Count > 0 Then
FolderExists = True
folderName = colMatches(0).Value
Exit Function
End If

FolderExists = False
End Function




Any ideas?


All Replies
  • Just change the RegEx pattern to look for what you want it to match. There's a tutorial on using RegEx here:


    You'll also want to modify the code that names the folders.

  • Nah I don't understand chinese. I'll ask on another forum then.