View Single Post
Old 08-09-2007, 02:24 PM   #13 (permalink)
blincoln
Thumbs Must Hurt
 
Join Date: Jul 2007
Location: city11 -inspectral
Model: 8100
PIN: N/A
Carrier: Cingular
Posts: 79
Post Thanks: 0
Thanked 0 Times in 0 Posts
Default

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
__________________
Legacy of Kain: The Lost Worlds
http://www.thelostworlds.net/

Last edited by blincoln : 08-09-2007 at 04:06 PM. Reason: Correct version number / datestamp / remove debugging code
Offline   Reply With Quote