I found a better way to get the reference to the BlackBerry calendar data. Here is an updated version of the script that should also run a bit faster as well as catching more of the appointments' RefIDs:
Code:
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' DumpMailboxItemData.vbs '
' Version 1.2 '
' '
' Outputs tab-delimited text based on information in a user's Exchange mailbox '
' Intended for use with user accounts which are also set up on a Blackberry '
' Enterprise Server. '
' '
' '
' Ben Lincoln, 2007-08-09 '
' http://www.thelostworlds.net/ '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Option Explicit
' Custom field names to read from the mailbox items.
' Two arrays are necessary in order to keep one human-readable
Dim gArrFieldsToRead, gArrFieldsToReadNames
' A hashtable of top-level folder names that should not be processed
Dim gObjFolderExcludeHash
Set gObjFolderExcludeHash = CreateObject("Scripting.Dictionary")
' Name of the root-level BlackBerry information folder in the user's mailbox
Const gStrBlackBerryRootFolder = "BlackBerryHandheldInfo"
' Name of the BlackBerry subfolder which contains the calendar sync data
Const gStrBlackBerryCalSyncFolder = "BlackBerryCalSyncState"
' Hex codes for the fields in the BlackBerry calendar sync items
' Calendar item message ID
Const gIntBBCalSyncCalID = &H62050102
' BlackBerry Ref ID copy 1
Const gIntBBCalSyncRefID1 = &H62030003
' BlackBerry Ref ID copy 2
Const gIntBBCalSyncRefID2 = &H62040003
' Hex codes for the fields in the Exchange calendar items
' The field number of PR_CHANGE_KEY
Const gIntChangeKeyFieldNumber = &H65E20102
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''' Begin script customization options '''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Add or remove entries in this array to alter the collection of data from custom fields
' Example: "PR_RIM_MSG_REF_ID"
gArrFieldsToRead = Array("PR_RIM_MSG_REF_ID", "PR_RIM_MSG_FOLDER_ID")
' As of BES 4.1.2, RIM is incorrectly using ANSI field names rather than Unicode
' on systems that support Unicode.
' If they mend their ways, change this constant to be False rather than True.
Const gCastFieldNamesANSIToUnicode = True
' Add or remove .Add lines below to exclude top-level folders from processing by name
' Example: gObjFolderExcludeHash.Add "Calendar", "Calendar"
' gObjFolderExcludeHash.Add "Calendar", "Calendar"
gObjFolderExcludeHash.Add "Contacts", "Contacts"
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''' End script customization options ''''''''''''''
'''''''''''''' Do not modify below this line for normal maintenance ''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Get arguments from command line
If WScript.Arguments.Count <> 2 Then
WScript.Echo "Missing one or more arguments."
WScript.Echo "Usage: cscript -nologo DumpMailboxItemData.vbs28 [SERVER] [MAILBOX]"
WScript.Echo "Example: cscript -nologo DumpMailboxItemData.vbs mailserver01 blincoln"
WScript.Quit 1
End If
Main WScript.Arguments(0), WScript.Arguments(1)
'''''''''''
Function Main(strExchangeServer, strMailboxName)
Dim intFieldNum
gArrFieldsToReadNames = gArrFieldsToRead
' If necessary, cast ANSI field names to Unicode
If gCastFieldNamesANSIToUnicode = True Then
For intFieldNum = 0 To UBound(gArrFieldsToRead)
gArrFieldsToRead(intFieldNum) = CastANSIStringToUnicodeString(gArrFieldsToRead(intFieldNum))
Next
End If
Dim strProfileInfo
Dim objMAPISession
Dim objInfoStore
Dim objFolders
Dim objFolder
Dim objMapHash
strProfileInfo = strExchangeServer & vbLf & strMailboxName
Set objMAPISession = CreateObject("mapi.session")
objMAPISession.Logon "", "", False, True, 0, True, strProfileInfo
Set objInfoStore = objMAPISession.InfoStores.Item(2)
Set objFolders = objInfoStore.Rootfolder.Folders
On Error Resume Next
Set objMapHash = GetBlackBerryMappings(objMAPISession)
If Err.Number <> 0 Then
Set objMapHash = CreateObject("Scripting.Dictionary")
WScript.Echo "WARNING: Unable to obtain the BlackBerry Calendar sync data for this mailbox."
Err.Clear
End If
On Error GoTo 0
' Used to keep track of where the script is when processing folder names for display
Dim strGlobalFolder
strGlobalFolder = ""
' Column headers
Dim strHeaders
strHeaders = "Folder" & vbTab & "Sender" & vbTab & "Recipient" & vbTab & _
"Subject" & vbTab & "Sent" & vbTab & "Received" & vbTab & "Calendar RefID(s)" & vbTab
For intFieldNum = 0 To UBound(gArrFieldsToReadNames)
strHeaders = strHeaders & gArrFieldsToReadNames(intFieldNum) & vbTab
Next
WScript.Echo strHeaders
For Each objFolder In objFolders
If Not gObjFolderExcludeHash.Exists(objFolder.Name) Then
ProcessFolder objFolder, strGlobalFolder, objMapHash
End If
Next
objMAPISession.Logoff
End Function
Function GetBlackBerryMappings(objMAPISession)
Dim objRoot
Dim objBBRootFolder
Dim objBBCalSyncFolder
Dim objMapHash
Dim objMessages
Dim objMessage
Dim strInternetID
Dim strRefID
Dim strRefID1
Dim strRefID2
Dim strExistingRefIDs
Dim boolUseRefID1
Dim boolUseRefID2
Set objRoot = objMAPISession.GetFolder("")
Set objBBRootFolder = objRoot.Folders.Item(gStrBlackBerryRootFolder)
Set objBBCalSyncFolder = objBBRootFolder.Folders.Item(gStrBlackBerryCalSyncFolder)
Set objMapHash = CreateObject("Scripting.Dictionary")
Set objMessages = objBBCalSyncFolder.Messages
For Each objMessage In objMessages
strInternetID = GetMessageFieldValue(objMessage, gIntBBCalSyncCalID) & ""
If strInternetID <> "[NULL]" Then
strRefID1 = GetMessageFieldValue(objMessage, gIntBBCalSyncRefID1) & ""
strRefID2 = GetMessageFieldValue(objMessage, gIntBBCalSyncRefID2) & ""
boolUseRefID1 = True
boolUseRefID2 = True
If strRefID1 = "[NULL]" Then
boolUseRefID1 = False
End If
If strRefID2 = "[NULL]" Then
boolUseRefID2 = False
End If
If strRefID1 = strRefID2 Then
boolUseRefID2 = False
End If
strRefID = ""
If boolUseRefID1 = True Then
If boolUseRefID2 = True Then
strRefID = strRefID1 & ", " & strRefID2
Else
strRefID = strRefID1
End If
Else
If boolUseRefID2 = True Then
strRefID = strRefID2
End If
End If
If strRefID <> "" Then
' Now that the RefID(s) have been obtained, add or update the entry in the hashtable
' For the internet message ID
If objMapHash.Exists(strInternetID) Then
strExistingRefIDs = objMapHash(strInternetID)
strExistingRefIDs = strExistingRefIDs & ", " & strRefID
objMapHash(strInternetID) = strExistingRefIDs
Else
objMapHash.Add strInternetID, strRefID
End If
End If
End If
Next
Set GetBlackBerryMappings = objMapHash
End Function
Function GetMessageFieldValue(objMessage, fieldNameOrNumber)
Dim fieldValue
On Error Resume Next
fieldValue = objMessage.Fields.Item(fieldNameOrNumber).Value
If Err.Number <> 0 Then
fieldValue = "[NULL]"
Err.Clear
End If
On Error GoTo 0
GetMessageFieldValue = fieldValue
End Function
Function ProcessFolder(objFolder, strGlobalFolder, objMapHash)
Dim objSubFolder
Dim objMessages
Dim objMessage
Dim objField
Dim strMessageSender
Dim strMessageRecipient
Dim strMessageSubject
Dim strMessageTimeSent
Dim strMessageTimeReceived
Dim strMessageCalendarRefID
Dim arrInternetID
Dim strLine
Dim strCurrentFolder
strCurrentFolder = strGlobalFolder & "\" & objFolder.Name
For Each objSubFolder In objFolder.Folders
ProcessFolder objSubFolder, strCurrentFolder, objMapHash
Next
Set objMessages = objFolder.Messages
For Each objMessage In objMessages
' Get standard message properties if they exist, otherwise set to nothing
On Error Resume Next
strMessageSender = objMessage.Sender
If Err.Number <> 0 Then
strMessageSender = "[NULL]"
Err.Clear
End If
strMessageRecipient = objMessage.Recipient
If Err.Number <> 0 Then
strMessageRecipient = "[NULL]"
Err.Clear
End If
strMessageSubject = objMessage.Subject
If Err.Number <> 0 Then
strMessageSubject = "[NULL]"
Err.Clear
End If
strMessageTimeSent = objMessage.TimeSent
If Err.Number <> 0 Then
strMessageTimeSent = "[NULL]"
Err.Clear
End If
strMessageTimeReceived = objMessage.TimeReceived
If Err.Number <> 0 Then
strMessageTimeReceived = "[NULL]"
Err.Clear
End If
On Error GoTo 0
strMessageCalendarRefID = GetMessageFieldValue(objMessage, gIntChangeKeyFieldNumber) & ""
If strMessageCalendarRefID <> "[NULL]" Then
If objMapHash.Exists(strMessageCalendarRefID) Then
strMessageCalendarRefID = objMapHash(strMessageCalendarRefID)
Else
strMessageCalendarRefID = "[Not Found]"
End If
End If
' Remove tabs and CF/LF from the subject if they managed to get in it
strMessageSubject = Replace(strMessageSubject, vbTab, " ")
strMessageSubject = Replace(strMessageSubject, vbCrLF, " ")
strLine = strCurrentFolder & vbTab & strMessageSender & vbTab & strMessageRecipient & _
vbTab & strMessageSubject & vbTab & strMessageTimeSent & vbTab & _
strMessageTimeReceived & vbTab & strMessageCalendarRefID & vbTab
' Get custom fields
Dim strFieldName
Dim strFieldValue
For Each strFieldName in gArrFieldsToRead
strFieldValue = GetMessageFieldValue(objMessage, strFieldName)
If Len(Trim(strFieldValue)) = 0 Then
strFieldValue = "[NULL]"
End If
strLine = strLine & strFieldValue & vbTab
Next
WScript.Echo strLine
Next
End Function
Function CastANSIStringToUnicodeString(strANSIString)
Dim strInString
Dim strSubString
Dim strOutString
Dim intCharCount
Dim intUnicodeCharCount
Dim intANSIPosition
Dim intUnicodePosition
Dim intLeftChar
Dim intRightChar
Dim intCastChar
strInString = strANSIString
intCharCount = Len(strInString)
' Pad out the string to an even number if necessary
If intCharCount Mod 2 = 1 Then
strInString = strInString & Chr(0)
intCharCount = Len(strInString)
End If
intUnicodeCharCount = (intCharCount / 2) - 1
For intANSIPosition = 0 to intUnicodeCharCount
strSubString = Left(strInString, 2)
If Len(strInString) > 2 Then
strInString = Right(strInString, Len(strInString) - 2)
End If
' comment out the next line if by some coincidence this script is running on a big-endian system
strSubString = StrReverse(strSubString)
intLeftChar = Asc(Left(strSubString, 1))
intRightChar = Asc(Right(strSubString, 1))
' bitshift the left char left by 8, then add it to the right char
intLeftChar = intLeftChar * 256
intCastChar = intLeftChar + intRightChar
strOutString = strOutString & ChrW(intCastChar)
Next
CastANSIStringToUnicodeString = strOutString
End Function