' This file contains basic routines that acquire information about the
' the Exchange organization (its name and its default SMTP address)
' as well as the computer that the script is being run upon (its Windows
' domain and the computer name)
Dim strNetBIOSDomain ' the NetBIOS domain this program is running in
Dim strNetBIOSComputer ' the NetBIOS name of the computer this program is running on
Dim strConfigNC ' the configuration naming context of this domain
Dim strDomainNC ' the domain naming context of this domain
Dim strOrgDN ' the distinguished name of the Exchange organization
Dim strDefaultDomain ' the default SMTP domain for the Exchange organization
Dim strDefault, strContainer, strGUID, strOABName, strAALName
Dim objDefault, objContainer, objNew
Dim arrGUID, arrAAL, strLEDN
'
' GetSystemInfo
' Purpose:
' Determine the necessary system variables to be
' able to make queries from Active Directory. Also,
' initialize ADO/ADSI global variables, and get
' Exchange organization information.
'
' Inputs:
' None
'
' Outputs:
' Causes many global variables to be initialized
'
' Requires:
' None
'
Function GetSystemInfo
Dim objSystemInfo, objWSHNetwork
Call InitializeAD
' get the NetBIOS domain name
Set objSystemInfo = CreateObject ("ADSystemInfo")
strNetBIOSDomain = objSystemInfo.DomainShortName
dp "strNetBIOSDomain: " & strNetBIOSDomain
Set objSystemInfo = Nothing
' get the NetBIOS computer name
Set objWSHNetwork = CreateObject ("WScript.Network")
strNetBIOSComputer = objWSHNetwork.ComputerName
dp "strNetBIOSComputer: " & strNetBIOSComputer
Set objWSHNetwork = Nothing
Call InitializeADSI
If GetOrganizationInformation Then
Call ClearSystemInfo
GetSystemInfo = True
Exit Function
End If
Call GetDefaultSMTPDomain
GetSystemInfo = False
End Function
'
' ClearSystemInfo
' Purpose:
' Does the necessary cleanup to exit the program.
'
' Inputs:
' None
'
' Outputs:
' None
'
' Requires:
' None
'
Sub ClearSystemInfo
Call DoneWithADSI
End Sub
'
' InitializeAD
' Purpose:
' Obtain the naming context strings for the current Active
' Directory domain.
'
' Inputs:
' None
'
' Outputs:
' None
'
' Requires:
' None
'
Sub InitializeAD
Dim objRootDSE
' Get the forest root directory services entry object
Set objRootDSE = GetObject ("LDAP://RootDSE")
' Exchange information is stored in the Configuration tree of the forest root
strConfigNC = objRootDSE.Get ("configurationNamingContext")
' this gives us the DN to the forest root
strDomainNC = objRootDSE.Get ("defaultNamingContext")
dp "Configuration Naming Context: " & strConfigNC
dp "Domain Naming Context: " & strDomainNC
Set objRootDSE = Nothing
End Sub
'
' GetOrganizationInformation
' Purpose:
' Set the global variable strOrgDN which contains the
' distinguished name of the Exchange organization, which
' is based in the configuration container.
'
' Inputs:
' None
'
' Outputs:
' Sets the global strOrgDN variable
'
' Requires:
' strConfigNC from InitializeAD
' All the ADO routines
'
Function GetOrganizationInformation
Dim strQuery
GetOrganizationInformation = False
' Build a query to find the Exchange organization.
strQuery = "<LDAP://CN=Microsoft Exchange,CN=Services," & strConfigNC & ">;" & _
"(objectCategory=msExchOrganizationContainer);" & _
"name,distinguishedName;" & _
"onelevel"
strOrgDN = ""
Call DoLDAPQuery (strQuery, Rs)
' If there are any results, there will only be one result. There
' may only be one Exchange organization per Active Directory forest.
e "Exchange Organization Name: " & Rs.Fields ("name")
dp "Organization DN: " & Rs.Fields ("distinguishedName")
strOrgDN = Rs.Fields ("distinguishedName")
Call FinishLDAPQuery (rs)
If Len (strOrgDN) = 0 Then
e "Cannot find Exchange organization information"
GetOrganizationInformation = True
End If
End Function
'
' GetDefaultSMTPDomain
' Purpose:
' Obtain the default SMTP domain for the Exchange organization.
' This is normally the same as the forest root domain (until
' changed by an Exchange administrator).
'
' Inputs:
' None
'
' Outputs:
' Set the global strDefaultDomain
'
' Requires:
' strOrgDN from GetOrganizationInformation
'
Sub GetDefaultSMTPDomain
Dim strAddress ' string
Dim strAddresses ' collection of addresses
Dim objPolicy ' reference to Default Recipient Policy
strDefaultDomain = ""
Set objPolicy = GetObject ("LDAP://CN=Default Policy,CN=Recipient Policies," & strOrgDN)
strAddresses = objPolicy.Get ("gatewayProxy")
' strAddresses contains all the addresses specified on the
' E-Mail Addresses tab of the default recipient policy
For Each strAddress in strAddresses
If Left (strAddress, 5) = "SMTP:" Then
strDefaultDomain = Right (strAddress, Len (strAddress) - 6) ' strip SMTP:@
End If
dp "Email address suffix: " & strAddress
Next
' Report our results
e "Default SMTP address for organization: " & strDefaultDomain
Set strAddresses = Nothing
Set objPolicy = Nothing
End Sub
'Now we create the OAL
'______________________
Function CreateOAL (strDomain, strName)
CreateOAL = True
' On Error Resume Next
Err.Clear
strContainer = "CN=Offline Address Lists,CN=Address Lists Container," & strOrgDN
' this is ANY OAL that has reasonable defaults
strDefault = "CN=Bla Bla Primary School" & strContainer
Set objDefault = GetObject ("LDAP://" & strDefault)
If Err Then
ErrorReport
e "Couldn't GetObject: " & strDefault
CreateOAL = True
Exit Function
End If
Set objContainer = GetObject ("LDAP://" & strContainer)
If Err Then
ErrorReport
e "Couldn't GetObject: " & strContainer
Set objDefault = Nothing
CreateOAL = True
Exit Function
End If
strGUID = CreateGUID (32)
Call ConvertHexStringToByteArray (strGUID, arrGUID)
strAALName = "CN=Addresses - " & strName & _
",CN=All Global Address Lists,CN=Address Lists Container," & strOrgDN
arrAAL = Array (strAALName)
' use objNew as a temporary to verify AAL exists
Set objNew = GetObject ("LDAP://" & strAALName)
If Err Then
' oops!
ErrorReport
e "Couldn't GetObject: " & strAALName
Set objContainer = Nothing
Set objDefault = Nothing
CreateOAL = True
Exit Function
End If
Set objNew = Nothing
strOABName = "Offline Address List - " & strName
strLEDN = "/O=" & strOrg & "/CN=addrlists/CN=oabs/CN=" & strOABName
Set objNew = objContainer.Create ("msExchOAB", "CN=" & strOABName)
If Err Then
ErrorReport
e "Couldn't Create: " & strOABName
Set objCOntainer = Nothing
Set objDefault = Nothing
CreateOAL = True
Exit Function
End If
' derived or calculated values
objNew.siteFolderGUID = arrGUID
objNew.offlineABContainers = arrAAL
objNew.legacyExchangeDN = strLEDN
' copied values - most are simple, some aren't
' all unique to OAB's
objNew.doOABVersion = objDefault.doOABVersion
objNew.msExchOABFolder = objDefault.msExchOABFolder
objNew.offlineABSchedule = objDefault.offlineABSchedule
objNew.offlineABServer = objDefault.offlineABServer
objNew.offlineABStyle = objDefault.offlineABStyle
objNew.siteFolderServer = objDefault.siteFolderServer
' copied values - generic
objNew.showInAdvancedViewOnly = objDefault.showInAdvancedViewOnly
objNew.systemFlags = objDefault.systemFlags
If 1 Then
wscript.echo "siteFolderGUID = " & OctetToHexStr (objNew.SiteFolderGUID)
wscript.echo "offlineABContainers = " & objNew.offlineABContainers (0)
wscript.echo "legacyExchangeDN = " & objNew.legacyExchangeDN
wscript.echo "doOABVersion = " & objNew.doOABVersion
wscript.echo "msExchOABFolder = " & octetToHexStr (objNew.msExchOABFolder)
wscript.echo "offlineABSchedule = " & octetToHexStr (objNew.offlineABSchedule)
wscript.echo "offlineABServer = " & objNew.offlineABServer
wscript.echo "offlineABStyle = " & objNew.offlineABStyle
wscript.echo "siteFOlderServer = " & objNew.siteFolderServer
wscript.echo "showInAdvancedViewOnly = " & objNew.ShowInAdvancedViewOnly
wscript.echo "systemFlags = " & objNew.SystemFlags
End If
objNew.SetInfo
If Err Then
ErrorReport
e "Couldn't SetInfo"
Set objNew = Nothing
Set objCOntainer = Nothing
Set objDefault = Nothing
CreateOAL = True
Exit Function
End If
Set objNew = Nothing
Set objDefault = Nothing
Set objContainer = Nothing
wscript.echo "Created new OAB: " & strName
End Function
Function OctetToHexStr (arrbytOctet)
' Function to convert OctetString (byte array) to Hex string.
' Code from Richard Mueller, a MS MVP in Scripting and ADSI
Dim k
OctetToHexStr = ""
For k = 1 To Lenb (arrbytOctet)
OctetToHexStr = OctetToHexStr _
& Right("0" & Hex(Ascb(Midb(arrbytOctet, k, 1))), 2)
Next
End Function
Sub ConvertHexStringToByteArray (ByVal strHexString, ByRef pByteArray)
Dim fso, stream, temp, ts, n
' This is an elegant way to convert a hex string to a Byte
' array. Typename(pByteArray) will return Byte(). pByteArray
' should be a null variant upon entry. strHexString should be
' an ASCII string containing nothing but hex characters, e.g.,
' FD70C1BC2206240B828F7AE31FEB55BE
' Code from Michael Harris, a MS MVP in Scripting
Set fso = CreateObject ("scripting.filesystemobject")
Set stream = CreateObject ("adodb.stream")
temp = fso.gettempname ()
Set ts = fso.createtextfile (temp)
For n = 1 To (Len (strHexString) - 1) step 2
ts.write Chr ("&h" & Mid (strHexString, n, 2))
Next
ts.close
stream.type = 1
stream.open
stream.loadfromfile temp
pByteArray = stream.read
stream.close
fso.deletefile temp
Set stream = Nothing
Set fso = Nothing
End Sub
Function CreateGUID (tmpLength)
Randomize Timer
Dim tmpCounter,tmpGUID
Const strValid = "0123456789ABCDEF"
For tmpCounter = 1 To tmpLength
tmpGUID = tmpGUID & Mid (strValid, Int (Rnd (1) * Len (strValid)) + 1, 1)
Next
CreateGUID = tmpGUID
End Function