Option Explicit
Dim strBase, strComputerName, strAttrs, strScope
Dim theServer, theSG, theConn, sg, mailDB, strUserName
Dim objRS, strMailBox, i, strUser, u, strDN
Dim person, arrAttendees, objTrans, strDNText
Dim strSubject, strOrg, strBody, arrDN
Const CdoDefaultFolderCalendar = 0
'On Error Resume Next
'------ CONFIG ------
strBase = "<LDAP://DC.domain.com>;"
strComputerName = "Exchange.comain.com"
strAttrs = "cn,sAMAccountName;"
strScope = "subtree"
u = 0
'------ END CONFIG ----
Set theServer = CreateObject("CDOEXM.ExchangeServer")
Set theSG = CreateObject("CDOEXM.StorageGroup")
Set theConn = CreateObject("ADODB.Connection")
theConn.Open "Provider=ADsDSOObject;"
theServer.DataSource.Open strComputerName
' look at all storage groups for mailboxes
' strComputerName is Exchange Server
' strMailBox is username
' strUser is cn
For Each sg In theServer.StorageGroups
WScript.Echo "Storage group " & Chr(34) & sg & Chr(34)
theSG.DataSource.open sg
i = 0
For Each mailDB In theSG.MailboxStoreDBs
i = i+1
WScript.Echo " Mailbox database " & i & ": " & mailDB & vbcrlf
Set objRS = theConn.Execute(strBase & "(&(homeMDB=" & mailDB & ")(sAMAccountName=*)(!mail=*system*));" & strAttrs & strScope)
objRS.MoveFirst
While Not objRS.EOF And ObjRS.RecordCount > 0
u = u + 1
strUser = objRS.Fields(0).Value
strMailBox = objRS.Fields(1).Value
CALL GetApptData(strComputerName,strMailBox,strUser)
strMailBox = ""
objRS.MoveNext
Wend
Next
Next
Function GetApptData(strComputerName,strMailBox,strUser)
Dim objSession, strProfileInfo, objAppointment, strAttendees, Attendee
Dim objAppointmentItems, objFolder
strProfileInfo = strComputerName & vbLf & strMailBox
Set objSession = CreateObject("MAPI.Session")
objSession.Logon "", "", False, True, 0, True, strProfileInfo
strMailBox = ""
wscript.echo strProfileInfo
Set objFolder = objSession.GetDefaultFolder(CdoDefaultFolderCalendar)
' Get all Appointment Items
Set objAppointmentItems = objFolder.Messages
' Loop through the AppointmentItems collection
For Each objAppointment In objAppointmentItems
If objAppointment.IsRecurring = True And objAppointment.Sensitivity <> 0 Then
For Each Attendee In objAppointment.Recipients
strAttendees = strAttendees & Attendee & "///" & Attendee.Address & " ; "
Next
End If
If objAppointment.IsRecurring = True And objAppointment.Sensitivity <> 0 And strAttendees <> "" Then
strAttendees = Mid(strAttendees, 1, Len(strAttendees) - 3)
' Display data for each appointment
wscript.echo "############NEW USER###################################" & vbcrlf
wscript.echo strUser & ";" & objAppointment.Subject & ";" & objAppointment.StartTime & ";" & objAppointment.EndTime & ";" & objAppointment.Organizer & vbcrlf & vbTab & strAttendees
arrAttendees = Split(strAttendees," ; ") 'Leaves Joe Smith///EX:/legacyDN
For Each person In arrAttendees 'person is Joe Smith///EX:/legacyDN
arrDN = Split(person,"///") ' arrDN(0) = Joe Smith, arrDN(1) = legacyDN
strDNText = Replace(arrDN(1),"EX:","")
strSubject = objAppointment.Subject
strOrg = objAppointment.Organizer
'strBody = objAppointment.Body
Call SearchAD(strDNText,strComputerName,person,strSubject,strOrg)
Next
End If
strAttendees = ""
Next
'Clean Up
objSession.Logoff
Set objSession = Nothing
End Function
Function GetApptData2(strComputerName,strSAM,person,strSubject,strOrg)
Dim objSession2, strProfileInfo2, objAppointment2, strAttendees2, Attendee2
Dim objAppointmentItems2, objFolder2, strSubject2, strOrg2
'On Error Resume Next
strProfileInfo2 = strComputerName & vbLf & strSAM
Set objSession2 = CreateObject("MAPI.Session")
objSession2.Logon "", "", False, True, 0, True, strProfileInfo2
strSAM = ""
Set objFolder2 = objSession2.GetDefaultFolder(CdoDefaultFolderCalendar)
' Get all Appointment Items
Set objAppointmentItems2 = objFolder2.Messages
' Loop through the AppointmentItems collection
For Each objAppointment2 In objAppointmentItems2
strSubject2 = objAppointment2.Subject
strOrg2 = objAppointment2.Organizer.Name
' Display data for each appointment
'wscript.echo "strOrg2 type: " & TypeName(strOrg2)
'wscript.echo "strSubject = " & strSubject
'wscript.echo "objAppointment2.Subject = " & strSubject2 'objAppointment2.Subject
'wscript.echo "strOrg = " & strOrg
'wscript.echo "objAppointment2.Organizer = " & strOrg2 'objAppointment2.Organizer
If strSubject = strSubject2 And strOrg = strOrg2 Then
wscript.echo vbtab & vbTab & "Attendee Data: " & person & ";" & strSubject2 & ";" & objAppointment2.StartTime & ";" & objAppointment2.EndTime & ";" & strOrg2
End If
strAttendees2 = ""
Next
'Clean Up
objSession2.Logoff
Set objSession2 = Nothing
End Function
Function SearchAD(strDNText,strComputerName,person,strSubject,strOrg)
Dim objRootDSE, strDNSDomain, objCommand, objConnection
Dim strQuery, strBase, strFilter, strAttributes
Dim objRecordSet, strAlias, strName, strSAM
' Determine DNS domain name from RootDSE object.
Set objRootDSE = GetObject("LDAP://RootDSE")
strDNSDomain = objRootDSE.Get("defaultNamingContext")
' Use ADO to search Active Directory.
Set objCommand = CreateObject("ADODB.Command")
Set objConnection = CreateObject("ADODB.Connection")
objConnection.Provider = "ADsDSOObject"
objConnection.Open "Active Directory Provider"
objCommand.ActiveConnection = objConnection
' Search for all user objects. Return Values.
strBase = "<LDAP://" & strDNSDomain & ">"
strFilter = "(&(objectCategory=person)(objectClass=user)(legacyExchangeDN=" & strDNText & "))"
strAttributes = "sAMAccountName,cn"
strQuery = strBase & ";" & strFilter & ";" & strAttributes & ";subtree"
objCommand.CommandText = strQuery
objCommand.Properties("Page Size") = 100
objCommand.Properties("Timeout") = 30
Set objRecordSet = objCommand.Execute
wscript.echo objRecordSet.RecordCount
Do Until objRecordSet.EOF
strName = objRecordSet.Fields("cn")
strSAM = objRecordSet.Fields("sAMAccountName")
CALL GetApptData2(strComputerName,strSAM,person,strSubject,strOrg)
objRecordSet.MoveNext
Loop
objConnection.Close
End Function
wscript.echo "Total User Count: " & u
