' GetMailboxStatistics.vbs
'
' Retrieves all information relating to mailboxes from Exchange and links in
' relevant information from Active Directory. Only compatible with Exchange 2003 and
' must be run with permission to access WMI, Exchange configuration and AD (read only)
'
' Author: Chris Dent
' Last Modified: 30/04/2009

Option Explicit

Sub UsageText

  Dim strMessage
  strMessage = "Usage:" & VbCrLf & VbCrLf & _
    "cscript " & WScript.ScriptName & " [/o] [/s:<ExchangeServer>]" & vbCrLf & _
      vbTab & "[/a:""<Administrative Group Name>""] [/d:<DomainName>]" & vbCrLf & _
      vbTab & "[/dc:<DomainControllerName>] [/f:<FileName>]" & vbCrlf & vbCrLf & _
      "One of the following parameters must be specified: " & vbCrlf & vbCrLf & _
      "/o      Get statistics from all Exchange Servers in the organisation" & vbCrLf & _
      "        This option overrides all others" & vbCrLf & _
      "/s      Get statistics for this Exchange Server only" & vbCrLf & _
      "        This option overrides all except /o" & vbCrLf & _
      "/a      Get statistics from all Exchange Servers in the specified Administrative Group" & vbCrLf & _
      "/d      Get statistics from all Exchange Servers in the specified Domain" & vbCrLf & vbCrLf & _
      "The following parameters are optional:" & vbCrLf & vbCrlf & _
      "/dc     A Domain Controller to use for this process. Must be a Global Catalog " & vbCrLf & _
      "        for reporting that covers a Forest. The script will attempt to find a " & vbCrLf & _
      "        GC in the current site if not specified." & vbCrLf & _
      "/f      File Name for the output. Default file name is MailboxReport.csv" & vbCrLf

  WScript.Echo strMessage
  WScript.Quit
End Sub

Sub GetParameters
  Dim objArgsNamed : Set objArgsNamed = WScript.Arguments.Named

  If objArgsNamed.Count = 0 Then
    UsageText
  End If

  Dim booHasRequiredParam : booHasRequiredParam = False

  ' Arguments that may be set. These are mutually exclusive
  If objArgsNamed("s") <> "" Then
    booHasRequiredParam = True
    arrExchServers = Array(objArgsNamed("s"))
  End If
  If objArgsNamed("a") <> "" Then
    booHasRequiredParam = True
    strAdminGroup = objArgsNamed("a")
  End If
  If objArgsNamed("d") <> "" Then
    booHasRequiredParam = True 
    strDomain = objArgsNamed("d")
  End If

  ' If a DC is specified try to use it, otherwise find a global catalog to use
  If objArgsNamed("dc") <> "" Then
    strGCName = objArgsNamed("dc")
  Else
    ' Finds a GC to use
    strGCName = GetGCName
  End If

  ' Arguments that are necessary and have default values
  If objArgsNamed("f") <> "" Then
    strFileName = objArgsNamed("f")
  Else
    strFileName = "MailboxReport.csv"
  End If

  If booHasRequiredParam = False Then
    Dim strArg
    For Each strArg in objArgsNamed
      If LCase(strArg) = "o" Then
        booHasRequiredParam = True
        Exit For
      End If
    Next
  End If

  If booHasRequiredParam = False Then
    UsageText
  End If
End Sub

Function GetGCName
  ' Returns a Global Catalog from the current site if possible.
  ' Returns a Global Catalog from the current domain if not.

  Dim objADSysInfo : Set objADSysInfo = CreateObject("ADSystemInfo")
  Dim strSiteName : strSiteName = objADSysInfo.SiteName
  Dim strForestDNSName : strForestDNSName = objADSysInfo.ForestDNSName

  Dim objShell : Set objShell = CreateObject("WScript.Shell")
  Dim objExec : Dim strDNSQuery, strGCName

  strDNSQuery = "nslookup -q=srv _gc._tcp." & strSiteName & "._sites." & strForestDNSName
  strGCName = GetHostFromSrvRecord(objShell.Exec(strDNSQuery).StdOut.ReadAll)

  If strGCName = "" Then
    strDNSQuery = "nslookup -q=srv _gc._tcp." & strForestDNSName
    strGCName = GetHostFromSrvRecord(objShell.Exec(strDNSQuery).StdOut.ReadAll)
  End If

  GetGCName = strGCName
End Function

Function GetHostFromSrvRecord(strResponse)
  ' Extracts the Host Name from service records returned from NSLookup

  Dim arrResponse : arrResponse = Split(strResponse, vbCrlf)
  Dim strGCName, strLine
  Dim objShell : Set objShell = CreateObject("WScript.Shell")

  For Each strLine in arrResponse
    If InStr(strLine, "svr hostname") > 0 Then
      Dim strHostName : strHostName = Trim(Split(strLine, "=")(1))
      If objShell.Run("ping -n 1 " & strHostName, 0, True) = 0 Then
        strGCName = strHostName
        Exit For
      End If
    End If
  Next

  GetHostFromSrvRecord = strGCName
End Function

Function DirectorySearcher(strLdapPath, strLdapFilter, strPropertiesToLoad, strScope, strKey)
  ' Returns a dictionary object containing search results. Key is object distinguished name.

  Dim objConnection : Set objConnection = CreateObject("ADODB.Connection")
  objConnection.Provider = "ADsDSOObject"
  objConnection.Open "Active Directory Provider"

  On Error Resume Next : Err.Clear
  Dim objRecordSet : Set objRecordSet = objConnection.Execute("<" & strLdapPath & ">;" & _
    strLdapFilter & ";" & strPropertiesToLoad & ";" & strScope)
  If Err.Number <> 0 Then
    WScript.Echo "ERROR: Failed to connect to specified DC"
    WScript.Quit
  End If
  On Error Goto 0

  Dim arrPropertiesToLoad : arrPropertiesToLoad = Split(strPropertiesToLoad, ",")

  Dim objSearchResults : Set objSearchResults = CreateObject("Scripting.Dictionary")
  objSearchResults.CompareMode = VbTextCompare

  Dim strValues()
  Do Until objRecordSet.EOF
    Dim strProperty, strValue : Dim i : i = 0
    For Each strProperty in arrPropertiesToLoad
      If IsNull(objRecordSet.Fields(strProperty)) Then
        strValue = ""
      Else
        strValue = objRecordSet.Fields(strProperty).Value
        If IsArray(strValue) Then
          strValue = Join(strValue)
        End If
      End If
      ReDim Preserve arrValues(i)
      arrValues(i) = strValue : i = i + 1
    Next

    If Not objSearchResults.Exists(objRecordSet.Fields(strKey).Value) Then
      objSearchResults.Add objRecordSet.Fields(strKey).Value, arrValues
    End If

    objRecordSet.MoveNext
  Loop

  Set DirectorySearcher = objSearchResults
End Function

Function GetExchangeServers(strAdminGroup, strDomain, strGCName)
  ' Returns an array containing the DnsHostName of each Exchange Server

  Dim objRootDSE : Set objRootDSE = GetObject("LDAP://RootDSE")
  Dim strLdapPath, strLdapFilter

  strLdapPath = "LDAP://" & strGCName & "/CN=Microsoft Exchange,CN=Services," & _
    objRootDSE.Get("configurationNamingContext")

  Dim objExchFromConfig : Dim strExchServer

  If strAdminGroup <> "" Then

    ' Get all Administrative Group Names

    strLdapFilter = "(&(objectCategory=msExchAdminGroup)(|(name=" & strAdminGroup & ")" & _
      "(displayName=" & strAdminGroup & ")))"

    Dim objAdminGroups : Set objAdminGroups = DirectorySearcher(strLdapPath, _
      strLdapFilter, "distinguishedName,name,displayName", "subtree", "distinguishedName")

    ' Get Exchange Servers within the specified Administrative Group(s)

    Set objExchFromConfig = CreateObject("Scripting.Dictionary")
    Dim strAdminGroupDN
    For Each strAdminGroupDN in objAdminGroups
      Dim objTemp : Set objTemp = DirectorySearcher("LDAP://" & strGCName & "/" & _
        strAdminGroupDN, "(objectCategory=msExchExchangeServer)", "name", "subtree", "name")

      For Each strExchServer in objTemp
        objExchFromConfig.Add strExchServer, objTemp(strExchServer)
      Next
    Next

  Else

    ' Get all Exchange Servers in the organisation

    strLdapPath = "LDAP://" & strGCName & "/CN=Microsoft Exchange,CN=Services," & _
      objRootDSE.Get("configurationNamingContext")

    Set objExchFromConfig = DirectorySearcher(strLdapPath, _
      "(objectCategory=msExchExchangeServer)", "name", "subtree", "name")

  End If

  ' Construct an LdapFilter that will only return Exchange Servers

  strLdapFilter = "(&(objectCategory=computer)(servicePrincipalName=exchangeMDB/*))"

  If strDomain <> "" Then
    On Error Resume Next : Err.Clear
    Set objRootDSE = GetObject("LDAP://" & strDomain & "/RootDSE")
    If Err.Number <> 0 Then
      WScript.Echo "ERROR: Failed to connect to specified domain"
      WScript.Quit
    End If
    On Error Goto 0
    strLdapPath = "LDAP://" & strGCName & "/" & objRootDSE.Get("defaultNamingContext")
  Else
    strLdapPath = "GC://" & strGCName
  End If

  Dim objExchFromDir : Set objExchFromDir = DirectorySearcher(strLdapPath, _
    strLdapFilter, "name,dNSHostName", "subtree", "name")

  ' Build a list of Exchange Servers with DNS Host Name values

  Dim arrExchServers() : Dim i : i = 0
  For Each strExchServer in objExchFromDir
    If objExchFromConfig.Exists(strExchServer) Then
      ReDim Preserve arrExchServers(i)
      arrExchServers(i) = objExchFromDir(strExchServer)(1) : i = i + 1
    End If
  Next

  GetExchangeServers = arrExchServers
End Function

Function GetMailboxesFromWMI(arrExchServers)
  Const WBEM_RETURN_IMMEDIATELY = &h10
  Const WBEM_FORWARD_ONLY = &h20

  Dim objMailboxes : Set objMailboxes = CreateObject("Scripting.Dictionary")
  objMailboxes.CompareMode = VbTextCompare

  Dim strExchServer
  For Each strExchServer in arrExchServers

    On Error Resume Next : Err.Clear
    Dim objWMI : Set objWMI = GetObject("winmgmts:\\" & strExchServer & "\root\MicrosoftExchangeV2")

    If Err.Number <> 0 Then
      WScript.Echo "WARNING: Failed to connect to Exchange Server " & strExchServer
    Else
      On Error Goto 0
      Dim colMailboxes : Set colMailboxes = objWMI.ExecQuery("SELECT * FROM Exchange_Mailbox", _
        "WQL", WBEM_RETURN_IMMEDIATELY + WBEM_FORWARD_ONLY)

      Dim objMailbox
      For Each objMailbox in colMailboxes
        If Not objMailboxes.Exists(objMailbox.LegacyDN) Then
          objMailboxes.Add objMailbox.LegacyDN, objMailbox
        End If
      Next
    End If
    Set objWMI = Nothing
    On Error Goto 0
  Next

  Set GetMailboxesFromWMI = objMailboxes
End Function

Function GetMailboxesFromAD(strDomain, strGCName)

  Dim strLdapPath
  If strDomain <> "" Then
    Dim objRootDSE : Set objRootDSE = GetObject("LDAP://" & strDomain & "/RootDSE")
    strLdapPath = "LDAP://" & strGCName & "/" & objRootDSE.Get("defaultNamingContext")
  Else
    strLdapPath = "GC://" & strGCName
  End If

  Dim strLdapFilter : strLdapFilter = "(&(objectClass=user)(objectCategory=person)(legacyExchangeDN=*))"

  Dim strPropertiesToLoad : strPropertiesToLoad = "name,distinguishedName," & _
    "legacyExchangeDN,mail,mDBOverHardQuotaLimit,mDBOverQuotaLimit," & _
    "mDBStorageQuota,mDBUseDefaults,userAccountControl"

  Dim objMailboxes : Set objMailboxes = DirectorySearcher(strLdapPath, _
    strLdapFilter, strPropertiesToLoad, "subtree", "legacyExchangeDN")

  Set GetMailboxesFromAD = objMailboxes
End Function

Sub WriteResults(objMailboxesFromWMI, objMailboxesFromAD, strFileName)

  Const ADS_UF_ACCOUNTDISABLE = 2

  Dim objFSO : Set objFSO = CreateObject("Scripting.FileSystemObject")
  On Error Resume Next : Err.Clear
  Dim objFile : Set objFile = objFSO.OpenTextFile(strFileName, 2, True, 0)
  If Err.Number <> 0 Then
    WScript.Echo "The File Name specified appears to be invalid."
    WScript.Quit
  End If

  ' Add the header line to the CSV File

  objFile.WriteLine "Name,DN,mail,AccountStatus,UseDefaultQuotas,Warn,ProhibitSend," & _
    "ProhibitSendAndReceive,Size,TotalItems,MailboxStatus,AssocContentCount," & _
    "DeletedMessageSize,LastLoggedOnUser,LastLogon,LastLogoff,DateDeleted,MailboxDisplayName," & _
    "MailboxGuid,ServerName,StorageGroup,Store,legacyExchangeDN"

  Dim strLegacyDN, strLine
  For Each strLegacyDN in objMailboxesFromWMI

    If objMailboxesFromAD.Exists(strLegacyDN) Then

      Dim strAccountStatus : strAccountStatus = "Enabled"
      If objMailboxesFromAD(strLegacyDN)(8) And ADS_UF_ACCOUNTDISABLE Then
        strAccountStatus = "Disabled"
      End If

      strLine = """" & objMailboxesFromAD(strLegacyDN)(0) & """,""" & _
        objMailboxesFromAD(strLegacyDN)(1) & """," & _
        objMailboxesFromAD(strLegacyDN)(3) & "," & _
        strAccountStatus & "," & _
        objMailboxesFromAD(strLegacyDN)(7) & "," & _
        ConvertKbToMb(objMailboxesFromAD(strLegacyDN)(6)) & "," & _
        ConvertKbToMb(objMailboxesFromAD(strLegacyDN)(5)) & "," & _
        ConvertKbToMb(objMailboxesFromAD(strLegacyDN)(4)) & ","
    Else
      strLine = ",,,,,,,,"
    End If

    strLine = strLine & ConvertKbToMb(objMailboxesFromWMI(strLegacyDN).Size) & "," & _
      objMailboxesFromWMI(strLegacyDN).TotalItems & "," & _
      ConvertStatusToName(objMailboxesFromWMI(strLegacyDN).StorageLimitInfo) & "," & _
      objMailboxesFromWMI(strLegacyDN).AssocContentCount & "," & _
      ConvertKbToMb(objMailboxesFromWMI(strLegacyDN).DeletedMessageSizeExtended) & "," & _
      objMailboxesFromWMI(strLegacyDN).LastLoggedOnUserAccount & "," & _
      ConvertToDate(objMailboxesFromWMI(strLegacyDN).LastLogonTime) & "," & _
      ConvertToDate(objMailboxesFromWMI(strLegacyDN).LastLogoffTime) &" ," & _
      ConvertToDate(objMailboxesFromWMI(strLegacyDN).DateDiscoveredAbsentInDs) & "," & _
      objMailboxesFromWMI(strLegacyDN).MailboxDisplayName & "," & _
      objMailboxesFromWMI(strLegacyDN).MailboxGuid & "," & _
      objMailboxesFromWMI(strLegacyDN).ServerName & ",""" & _
      objMailboxesFromWMI(strLegacyDN).StorageGroupName & """,""" & _
      objMailboxesFromWMI(strLegacyDN).StoreName & """," & _
      strLegacyDN

    objFile.WriteLine strLine
  Next
End Sub

Function ConvertKbToMb(dblValue)
  If Trim(dblValue) = "" Or IsNull(dblValue) Then
    ConvertKbToMb = ""
  Else
    ConvertKbToMb = Round(dblValue / 1024, 2)
  End If
End Function

Function ConvertToDate(strDate)
  ' (Slightly) modified function from the MS Scripting guys WMIDateStringToDate

  If Trim(strDate) = "" Or IsNull(strDate) Then
    ConvertToDate = ""
  Else
    ConvertToDate = CDate(Mid(strDate, 7, 2) & "/" & _
      Mid(strDate, 5, 2) & "/" & Left(strDate, 4) & " " & _
      Mid(strDate, 9, 2) & ":" & Mid(strDate, 11, 2) & ":" & Mid(strDate, 13, 2))
  End If
End Function

Function ConvertStatusToName(intStatus)
  Select Case intStatus
    Case 1  : ConvertStatusToName = "BelowLimit"
    Case 2  : ConvertStatusToName = "IssueWarning"
    Case 4  : ConvertStatusToName = "ProhibitSend"
    Case 8  : ConvertStatusToName = "NoChecking"
    Case 16 : ConvertStatusToName = "MailboxDisabled"
  End Select
End Function

'
' Main Code
'

Dim strAdminGroup, strDomain, strGCName, strFileName
Dim arrExchServers

GetParameters

If Not IsArray(arrExchServers) Then
  arrExchServers = GetExchangeServers(strAdminGroup, strDomain, strGCName)
End If

' Retrieve Mailbox information

Dim objMailboxesFromWMI : Set objMailboxesFromWMI = GetMailboxesFromWMI(arrExchServers)
If objMailboxesFromWMI.Count = 0 Then
  WScript.Echo "ERROR: Failed to find any mailboxes on Exchange Server(s)"
  WScript.Quit
End If

Dim objMailboxesFromAD  : Set objMailboxesFromAD  = GetMailboxesFromAD(strDomain, strGCName)

WriteResults objMailboxesFromWMI, objMailboxesFromAD, strFileName

WScript.Echo "Script Complete. Output written to " & strFileName