' 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