Thursday, August 23, 2007

Assigning categories based on the Attachments in a Message via a CDO 1.2 script

This is part 2 of a 2 part post of a few scripts to assign different colored categories to messages based on the type of attachments a message has. See the first post for information on how modify the Outlook 2007 categories’

This script handles enumerating the existing messages within a mailbox and then assigning categories (or keywords) based on the attachment types on the message. When I used this script I did every message in my mailbox which worked okay but because I was using Outlook in Cache Mode updating a lot a messages this way caused a major re-syncing or the cache (e.g. it seemed to pull down every message again that was updated with an attachment which can consume a lot of bandwidth if you have a large mailbox with large attachments). While this may be okay for some people this could cause some havoc in some networks so with this script I put a filter value so it will only update the messages that are less then 1 month old in the inbox. This could still be a considerable number of messages so you should use this script with great care and always test it first in your dev environment.

The script works by first creating a filter on the Messages in the inbox so only messages that have an attachment and are under 1 month old are included in the collection. It then loops through each message and first build a list of any existing keywords on a message. It then checks the attachment and if there is an attachment types that doesn’t have an existing keyword set on the message a new keyword is added to that message. To avoid assigning a keyword to a message with inline attachments such as people who use images in signatures etc the script checks to see if the attachment in question is a inline attachment if that’s the case it skips over this attachment. The keywords assigned to the message match the categories that where created with the first script. The categories themselves are held in a multivalued String property http://schemas.microsoft.com/mapi/string/{00020329-0000-0000-C000-000000000046}/Keywords.

This script only updates existing message if you want to set the categories on new messages you would need to look at writing an Event Sink or if your using Exchange 2007 you could use a Transport Agent or EWS Notifications application.

As I said before there is filter to stop it updating more than 1 month worth of mail in the line

attFilter.TimeFirst = DateAdd("m",-1,Now())

To run the code you need to supply the servername and mailbox name of the mailbox you want to run it against as commandline parameters eg

Cscript setkeywords.vbs.vbs servername mailboxname

I’ve put a download of the script here the script itself looks like

snServername = wscript.arguments(0)
mbMailboxName = wscript.arguments(1)

Set objSession = CreateObject("MAPI.Session")
Set catDict = CreateObject("Scripting.Dictionary")
objSession.Logon "","",false,true,true,true,snServername & vbLF & mbMailboxName
set ifInboxFolderCol = objSession.inbox.messages
set attFilter = ifInboxFolderCol.Filter
Set attFilterFiled = attFilter.Fields.Add(&h0E1B000B,true)
attFilter.TimeFirst = DateAdd("m",-1,Now())
For Each moMessageobject In ifInboxFolderCol
ceCatExists = False
catDict.RemoveAll
On Error Resume Next
ccCurrentCats = moMessageobject.Fields.item("{2903020000000000C000000000000046}Keywords").value
If Err.number = 0 Then
ceCatExists = True
For Each existingcat In ccCurrentCats
catDict.add existingcat,1
next
End If
On Error goto 0
oldcatlength = catDict.Count
Call GetCategories(moMessageobject,catDict)
If catDict.Count > oldcatlength Then
wscript.echo moMessageobject.Subject
ReDim newcats(catDict.Count-1)
catkeys = catDict.Keys
For i = 0 to catDict.Count-1
newcats(i) = catkeys(i)
Next
If ceCatExists = True then
moMessageobject.Fields.item("{2903020000000000C000000000000046}Keywords").value = newcats
Else
moMessageobject.Fields.add "Keywords", vbArray , newcats, "2903020000000000C000000000000046"
End If
moMessageobject.update
End if
next
sub GetCategories(msgObject,catDict)
For Each attachment In msgObject.Attachments
On Error Resume Next
inline = 0
fnFileName = attachment.fields(&h3704001E)
Err.clear
contentid = attachment.fields(&h3712001F)
If Err.number = 0 Then
inline = 1
Else
inline = 0
End if
Err.clear
attflags = attachment.fields(&h37140003)
If Err.number = 0 Then
If attflags = 4 Then inline = 1
End if
If Len(fnFileName) > 4 And inline = 0 Then
Select Case Right(LCase(fnFileName),4)
Case ".doc" If Not catDict.exists("Word Attachment") Then
catDict.add "Word Attachment",1
End if
Case ".ppt" If Not catDict.exists("PowerPoint Attachment") Then
catDict.add "PowerPoint Attachment",1
End if
Case ".xls" If Not catDict.exists("Excel Attachment") Then
catDict.add "Excel Attachment",1
End if
Case ".jpg" If Not catDict.exists("Image Attachment") Then
catDict.add "Image Attachment",1
End if
Case ".bmp" If Not catDict.exists("Image Attachment") Then
catDict.add "Image Attachment",1
End if
Case ".mov" If Not catDict.exists("Video Attachment") Then
catDict.add "Video Attachment",1
End if
Case ".mpg" If Not catDict.exists("Video Attachment") Then
catDict.add "Video Attachment",1
End if
Case ".wmv" If Not catDict.exists("Video Attachment") Then
catDict.add "Video Attachment",1
End if
Case ".pdf" If Not catDict.exists("PDF Attachment") Then
catDict.add "PDF Attachment",1
End if
Case ".mp3" If Not catDict.exists("Sound Attachment") Then
catDict.add "Sound Attachment",1
End if
Case ".pps" If Not catDict.exists("PowerPoint Attachment") Then
catDict.add "PowerPoint Attachment",1
End if
Case ".zip" If Not catDict.exists("Zip Attachment") Then
catDict.add "Zip Attachment",1
End if
End select

End if
On Error goto 0

next

End sub



Adding Categories to the Master categories list in Outlook 2007 with a CDO 1.2 script

This is a two part post that I thought I’d separate this idea came from someone who asked about how you could group messages by their attachment types. Normally this would be a pretty hard thing to achieve manly because of the way attachments are stored doesn’t lend itself well to being grouped by in a search folder or an Outlook Customize view. But this got me thinking about what if you could use the new colored category feature in Outlook 2007 instead. Eg for each attachment type you have a separate color and Label. This works out pretty cool because you go from being able to look at your email and seeing that there is an attachment eg the paper clip icon to being able to look at a message and if you see a blue category mark you know that message has got an attachment and it’s a word document if it’s a green mark you know it’s a Excel document. You can then also create Views or Search folders based on the attachment categorization you could also could create an event sink or Notification app to assign the category to new items when they arrive.

To start with this idea however I first needed to make changes to the master categories list in Outlook 2007 while doing this from Outlook 2007 is the easy method I wanted to do this programmatically instead. The master categories list is held in a hidden message (in the associated contents collection) with a message class of “IPM.Configuration.CategoryList”. On this message there is a binary Mapi property 0x7C080102 which holds the category list which in is XML format. So to modify the list you need some code that will first read this property I used CDO 1.2 so when you read the property with CDO you get back a hex string representation of the Binary property. To make use of this the Hex needs to be converted to a String which will represent the XML document. I then loaded the XML back into the XMLDom object and used the clonenode method to copy one of the existing nodes and then modified the necessary properties for the new category I wanted to add. The three important bits of information you need to set are the Name which is the keyword value you going to use for you category. An integer for the color you want the category to be and a unique GUID value. To stop duplicates there’s some code to check if the name of Guid already exists in the XML document if so it doesn’t try to add another node. To write the modified XML back to the property theres a function that coverts the XML String back to hex.

The code will only work to modify an existing category list it won’t create one from scratch. To run the code you need to supply the servername and mailbox name of the mailbox you want to run it against as commandline parameters eg

Cscript modcats.vbs servername mailboxname

I’ve put a download of the scrip here the script itself looks like

snServername = wscript.arguments(0)
mbMailboxName = wscript.arguments(1)

' Word Documents
ReDim wdattah(1)
wdattah(0) = "{DB13F464-2FAA-48F2-8D1B-ADB5ED4FD1F7}"
wdattah(1) = 22
'Excel Attachments
ReDim edattach(1)
edattach(0) = "{D549D2BB-E1BF-47DE-B713-784771F059A1}"
edattach(1) = 19
'PowerPoint Attachments
ReDim pptattach(1)
pptattach(0) = "{1E8ADCFB-AC2C-4FEF-ABB5-C5349A359CC8}"
pptattach(1) = 0
'PDF attachments
ReDim pdfattach(1)
pdfattach(0) = "{707D20D7-5EF8-47D7-B6C8-47FCB606EEB5}"
pdfattach(1) = 15
'Audio Attachments
ReDim sndattach(1)
sndattach(0) = "{B28E76F5-127B-4356-9150-D2A0B84E8DCE}"
sndattach(1) = 18
'Video
ReDim vdoattach(1)
vdoattach(0) = "{E633EC9C-9B29-4608-A4BA-CFBFA886702B}"
vdoattach(1) = 23
'Image Attachment
ReDim imgAttach(1)
imgAttach(0) = "{BB488D85-76FE-408F-9DD4-617041DBFDA6}"
imgAttach(1) = 13
'Zip Attachment
ReDim zipAttach(1)
zipAttach(0) = "{B4423425-54F1-304F-92F3-63451D3BFDB6}"
zipAttach(1) = 8

Set catDict = CreateObject("Scripting.Dictionary")
catDict.add "Word Attachment",wdattah
catDict.add "Excel Attachment",edattach
catDict.add "PowerPoint Attachment", pptattach
catDict.add "PDF Attachment", pdfattach
catDict.add "Audio Attachment", sndattach
catDict.add "Image Attachment", imgAttach
catDict.add "Video Attachment", vdoattach
catDict.add "Zip Attachment", zipAttach

set xdXmlDocument = CreateObject("Microsoft.XMLDOM")
xdXmlDocument.async="false"
Set objSession = CreateObject("MAPI.Session")
objSession.Logon "","",false,true,true,true,snServername & vbLF & mbMailboxName
Set CdoInfoStore = objSession.GetInfoStore
Set CdoFolderRoot = CdoInfoStore.RootFolder
set cdocalendar = objSession.GetDefaultFolder(CdoDefaultFolderCalendar)
For Each soStorageItem in cdocalendar.HiddenMessages
If soStorageItem.Type = "IPM.Configuration.CategoryList" Then
hexString = soStorageItem.fields(&h7C080102).Value
xdXmlDocument.loadxml(hextotext(hexString))
For Each cat In catDict
catval = catDict(cat)
If SearchforCategory("name",cat,xdXmlDocument) = True Or SearchforCategory("guid",catval(0),xdXmlDocument) Then
wscript.echo "Category Name or GUID alread Exists " & cat
Else
wscript.echo "Adding category " & cat
Call AddCategory(cat,catDict(cat),xdXmlDocument)
End if
next
nval = StrToHexStr(CStr(xdXmlDocument.xml))
soStorageItem.fields(&h7C080102).Value = nval
soStorageItem.update
End if
Next



Function hextotext(binprop)
arrnum = len(binprop)/2
redim aout(arrnum)
slen = 1
for i = 1 to arrnum
if CLng("&H" & mid(binprop,slen,2)) <> 0 then
aOut(i) = chr(CLng("&H" & mid(binprop,slen,2)))
end if
slen = slen+2
next
hextotext = join(aOUt,"")
end Function


Function StrToHexStr(strText)
Dim i, strTemp
For i = 1 To Len(strText)
strTemp = strTemp & Right("0" & Hex(Asc(Mid(strText, i, 1))), 2)
Next
StrToHexStr = Trim(strTemp)
End Function

Function SearchforCategory(elElementName,cnvalue,XMLDoc)
Set xnNodes = XMLDoc.selectNodes("//*[@" & elElementName &amp; " = '" & cnvalue & "']")
If xnNodes.length = 0 Then
SearchforCategory = False
else
SearchforCategory = True
End if

End Function

Function AddCategory(cnCategoryName,setarray,XMLDoc)
Set xnNodes = XMLDoc.selectNodes("//categories")
Set xnCatNodes = XMLDoc.selectNodes("//category")
Set objnewCat = xnCatNodes(0).cloneNode(true)
objnewCat.setAttribute "name",cnCategoryName
objnewCat.setAttribute "guid",setarray(0)
objnewCat.setAttribute "keyboardShortcut", 0
objnewCat.setAttribute "color", setarray(1)
objnewCat.setAttribute "usageCount", 0
objnewCat.setAttribute "lastTimeUsedNotes","1601-01-01T00:00:00.000"
objnewCat.setAttribute "lastTimeUsedJournal","1601-01-01T00:00:00.000"
objnewCat.setAttribute "lastTimeUsedTasks","1601-01-01T00:00:00.000"
objnewCat.setAttribute "lastTimeUsedContacts","1601-01-01T00:00:00.000"
objnewCat.setAttribute "lastTimeUsedMail","1601-01-01T00:00:00.000"
objnewCat.setAttribute "lastSessionUsed","1601-01-01T00:00:00.000"
xnNodes(0).appendChild objnewCat
End Function


Tuesday, August 14, 2007

Event ID 1029 Audit Report for failed Folder Access script

A couple of weeks back someone asked about a script to get details of a folder from the FID (folder ID) that is captured as part of a Event 1029 if your doing audit logging as described on msexchange.org. PFDavadmin does a good job of querying and presenting this information in a format that is compatible with what you can retrieve from the event logs but when you do turn up logging to this level the number of event that gets logged can be a bit overwhelming to use this method. So I thought I’d put together a few scripts that could automate this process and produce an htm report at the end showing which folders where accessed and by whom.

Instead of searching the Exchange store for each different event to find the related Folder what I did was come up with a script that would first query every folder in every mailbox in a mail store and then build and XML file that could then be queried by another script when it came time to produce a report. The report script when it runs uses WMI to query the event log for any 1029 events that happened in the time period you specify it then finds the related folder information by using the FID retrieved from the data section of the event log and then produces a HTML report of this information

The script to build the XML file that contains the FID information works similar to PFdavadmin in that it uses the admin virtual root. The advantage here is you can run the script with an account that has delegated Exchange admin rights and it will be able to access every mailbox. One difference is that instead of using the ptagFID : 0x67480014 I used the http://schemas.microsoft.com/exchange/permanenturl property and parsed the FID from this as per http://support.microsoft.com/kb/320749/en-us

By default the script uses http if your server is set to require https on the virtual admin root then you need to change the following line

falias = "http://" & servername & "/exadmin/admin/" & dpDefaultpolicy & "/mbx/"

to

falias = "https://" & servername & "/exadmin/admin/" & dpDefaultpolicy & "/mbx/"

The fiddb.vbs script which is the script that builds the XML file needs to be run with 1 command line parameter which is the name of the server you want to report against. An example commandline is

Cscript fiddb.vbs yourservername

The ElogFidReport first does a conversion of the current time to UTC to be able to query the event log for any 1029 events logged in the time period you specify as a command line parameter. It then queries the eventlog of the server you specify as another commandline parameter and goes though each of the 1029 events and first parsers the email address of the requestor and exchangelegdn of the mailbox being accessed. It then searches Active directory for this legDN value to find the mailbox in question so the DisplayName can be used to make the report more readable. The FID information is retrieved from the data section of the event log and converted from a Byte array into the FID format that is used in the XML file. A search is then done on the XML for that FID and finally a report is built. To make the report a little more readable the results are grouped by Mailbox and sorted by access date.

To run the EventLog report script you need to pass in two commandline parameters the first is the servername of the server you want to report against and the second is how many hours you want to look back in the logs. So to do a report of the last 4 hours you would use something like

Cscript ElogFidReport.vbs youservername 4

All the reports and XML files are stored in the c:\temp directory if this folder doesn’t exist or you want to change it to something else you need to search and configure the variables in both scripts that use this directory.

I’ve put a download of both script here the script itself looks like.

Servername = wscript.arguments(0)
csCurrentdbFileName = "c:\temp\fiddb.xml"

Set fso = CreateObject("Scripting.FileSystemObject")
set wfile = fso.opentextfile(csCurrentdbFileName,2,true)
wfile.writeline("<?xml version=""1.0""?>")
wfile.writeline("<SnappedFIDS SnapDate=""" & WeekdayName(weekday(now),3) & ", "
& day(now()) & " " & Monthname(month(now()),3) & " " & year(now()) & " " &
formatdatetime(now(),4) & ":00" & """>")

set req = createobject("microsoft.xmlhttp")
set com = createobject("ADODB.Command")
set conn = createobject("ADODB.Connection")
Set iAdRootDSE = GetObject("LDAP://RootDSE")
strNameingContext = iAdRootDSE.Get("configurationNamingContext")
strDefaultNamingContext = iAdRootDSE.Get("defaultNamingContext")
Conn.Provider = "ADsDSOObject"
Conn.Open "ADs Provider"
polQuery = "<LDAP://" & strNameingContext & ">;(&(objectCategory=msExchRecipientPolicy)(cn=Default
Policy));distinguishedName,gatewayProxy;subtree"
svcQuery = "<LDAP://" & strNameingContext & ">;(&(objectCategory=msExchExchangeServer)(cn="
& Servername & "));cn,name,legacyExchangeDN;subtree"
Com.ActiveConnection = Conn
Com.CommandText = polQuery
Set plRs = Com.Execute
while not plRs.eof
for each adrobj in plrs.fields("gatewayProxy").value
if instr(adrobj,"SMTP:") then dpDefaultpolicy =
right(adrobj,(len(adrobj)-instr(adrobj,"@")))
next
plrs.movenext
wend
wscript.echo dpDefaultpolicy
Com.CommandText = svcQuery
Set Rs = Com.Execute
while not rs.eof
GALQueryFilter = "(&(&(&(& (mailnickname=*)(!msExchHideFromAddressLists=TRUE)(|
(&(objectCategory=person)(objectClass=user)(msExchHomeServerName=" &
rs.fields("legacyExchangeDN") & ")) )))))"
strQuery = "<LDAP://" & strDefaultNamingContext & ">;" & GALQueryFilter & ";displayname,mail,distinguishedName,mailnickname,proxyaddresses;subtree"
com.Properties("Page Size") = 100
Com.CommandText = strQuery
Set Rs1 = Com.Execute
while not Rs1.eof
falias = "http://" & servername & "/exadmin/admin/" & dpDefaultpolicy & "/mbx/"
wfile.writeline("<Mailbox displayName=""" & rs1.fields("mail").value & """>")
for each paddress in rs1.fields("proxyaddresses").value
if instr(paddress,"SMTP:") then falias = falias & replace(paddress,"SMTP:","") &
"/non_ipm_subtree/"
Next
Call GetRootFolder(falias)
call RecurseFolder(falias)
wfile.writeline("</Mailbox>")
rs1.movenext
wend
rs.movenext
wend
rs.close
set conn = nothing
set com = nothing
wfile.writeline("</SnappedFIDS>")

Public Sub GetRootFolder(sUrl)

xmlreqtxt = "<?xml version='1.0'?><a:propfind xmlns:a='DAV:' xmlns:e='http://schemas.microsoft.com/exchange/'><a:prop><e:permanenturl/></a:prop></a:propfind>"
req.open "PROPFIND", sUrl, false , "", ""
req.setRequestHeader "Content-Type", "text/xml; charset=""UTF-8"""
req.setRequestHeader "Depth", "0"
req.setRequestHeader "Translate", "f"
req.send xmlreqtxt
set oResponseDoc = req.responseXML
set oNodeList = oResponseDoc.getElementsByTagName("d:permanenturl")
For i = 0 To (oNodeList.length -1)
set oNode = oNodeList.nextNode
wfile.writeline("<Folder Name=""NON_IPM_SUBTREE/Root"" Path=""Root"" fid=""1"&
Mid(oNode.text,InStr(Len(oNode.text)-8,oNode.text,"-"),10) & """></Folder>")
Next

End sub


Public Sub RecurseFolder(sUrl)

req.open "SEARCH", sUrl, False, "", ""
sQuery = "<?xml version=""1.0""?>"
sQuery = sQuery & "<g:searchrequest xmlns:g=""DAV:"">"
sQuery = sQuery & "<g:sql>SELECT ""DAV:displayname"",
""http://schemas.microsoft.com/"
sQuery = sQuery & "mapi/proptag/x6707001E"",
""http://schemas.microsoft.com/exchange/permanenturl"", ""DAV:hassubs"" FROM
SCOPE "
sQuery = sQuery & "('SHALLOW TRAVERSAL OF """ & sUrl & """') "
sQuery = sQuery & "WHERE ""DAV:isfolder"" = true and NOT
""http://schemas.microsoft.com/mapi/proptag/x36010003"" = 3"
sQuery = sQuery & "</g:sql>"
sQuery = sQuery & "</g:searchrequest>"
req.setRequestHeader "Content-Type", "text/xml"
req.setRequestHeader "Translate", "f"
req.setRequestHeader "Depth", "0"
req.setRequestHeader "Content-Length", "" & Len(sQuery)
req.send sQuery
Set oXMLDoc = req.responseXML
Set oXMLDavDisplayName = oXMLDoc.getElementsByTagName("a:displayname")
Set oXMLHREFNodes = oXMLDoc.getElementsByTagName("a:href")
Set oXMLHasSubsNodes = oXMLDoc.getElementsByTagName("a:hassubs")
Set oXMLFIDNodes = oXMLDoc.getElementsByTagName("e:permanenturl")
Set oXMLPathNodes = oXMLDoc.getElementsByTagName("d:x6707001E")
For i = 0 to oXMLHREFNodes.length - 1
wscript.echo oXMLHREFNodes.Item(i).nodeTypedValue
wscript.echo oXMLDavDisplayName(i).nodeTypedValue & " " &
oXMLPathNodes(i).nodeTypedValue
if oXMLPathNodes(i).nodeTypedValue = "/" then
strDispName = "root"
else
strDispName = oXMLDavDisplayName(i).nodeTypedValue
end if
wscript.echo
Mid(oXMLFIDNodes(i).text,InStr(Len(oXMLFIDNodes(i).text)-8,oXMLFIDNodes(i).text,"-"),10)
wfile.writeline("<Folder Name=""" & escape(strDispName) & """ Path=""" &
escape(oXMLPathNodes(i).nodeTypedValue) & """ fid=""1"&
Mid(oXMLFIDNodes(i).text,InStr(Len(oXMLFIDNodes(i).text)-8,oXMLFIDNodes(i).text,"-"),10)
& """></Folder>")
If oXMLHasSubsNodes.Item(i).nodeTypedValue = True Then
call RecurseFolder(oXMLHREFNodes.Item(i).nodeTypedValue)
End If
Next
End Sub