<DataSourceModuleType ID="AD_Replication_Monitoring.DataSource" Accessibility="Internal" RunAs="AD!Microsoft.Windows.Server.AD.ActionAccountProfile" Batching="false">
<Configuration>
<xsd:element name="IntervalSeconds" type="xsd:int"/>
<xsd:element name="TargetComputerFQDNName" type="xsd:string"/>
<xsd:element name="TargetComputerName" type="xsd:string"/>
<xsd:element name="TargetFQDN" type="xsd:string"/>
<xsd:element name="LogSuccessEvent" type="xsd:boolean"/>
<xsd:element name="ObjectUpdateThreshold" type="xsd:string"/>
<xsd:element name="IntersiteExpectedMaxLatency" type="xsd:string"/>
<xsd:element name="IntrasiteExpectedMaxLatency" type="xsd:string"/>
<xsd:element name="ChangeInjectionFrequency" type="xsd:string"/>
<xsd:element name="MonitorDomainNC" type="xsd:string"/>
<xsd:element name="MonitorConfigNC" type="xsd:string"/>
<xsd:element name="MonitorApplicationPartitions" type="xsd:string"/>
<xsd:element name="FirstReplicationPeriod" type="xsd:string"/>
<xsd:element name="ManagementGroupName" type="xsd:string"/>
<xsd:element name="TimeoutSeconds" type="xsd:int"/>
</Configuration>
<OverrideableParameters>
<OverrideableParameter ID="IntervalSeconds" Selector="$Config/IntervalSeconds$" ParameterType="int"/>
<OverrideableParameter ID="LogSuccessEvent" Selector="$Config/LogSuccessEvent$" ParameterType="string"/>
<OverrideableParameter ID="ObjectUpdateThreshold" Selector="$Config/ObjectUpdateThreshold$" ParameterType="string"/>
<OverrideableParameter ID="IntersiteExpectedMaxLatency" Selector="$Config/IntersiteExpectedMaxLatency$" ParameterType="string"/>
<OverrideableParameter ID="IntrasiteExpectedMaxLatency" Selector="$Config/IntrasiteExpectedMaxLatency$" ParameterType="string"/>
<OverrideableParameter ID="MonitorDomainNC" Selector="$Config/MonitorDomainNC$" ParameterType="string"/>
<OverrideableParameter ID="MonitorConfigNC" Selector="$Config/MonitorConfigNC$" ParameterType="string"/>
<OverrideableParameter ID="MonitorApplicationPartitions" Selector="$Config/MonitorApplicationPartitions$" ParameterType="string"/>
<OverrideableParameter ID="FirstReplicationPeriod" Selector="$Config/FirstReplicationPeriod$" ParameterType="string"/>
<OverrideableParameter ID="ChangeInjectionFrequency" Selector="$Config/ChangeInjectionFrequency$" ParameterType="string"/>
<OverrideableParameter ID="TimeoutSeconds" Selector="$Config/TimeoutSeconds$" ParameterType="int"/>
</OverrideableParameters>
<ModuleImplementation Isolation="Any">
<Composite>
<MemberModules>
<DataSource ID="DS" TypeID="System!System.CommandExecuterPropertyBagSource">
<IntervalSeconds>$Config/IntervalSeconds$</IntervalSeconds>
<ApplicationName>%windir%\system32\cscript.exe</ApplicationName>
<WorkingDirectory/>
<CommandLine>//nologo $file/AD_Replication_Monitoring.vbs$ $Config/TargetComputerFQDNName$ $Config/TargetComputerName$ $Config/TargetFQDN$ $Config/IntersiteExpectedMaxLatency$ $Config/IntrasiteExpectedMaxLatency$ $Config/ObjectUpdateThreshold$ $Config/MonitorConfigNC$ $Config/MonitorDomainNC$ $Config/ChangeInjectionFrequency$ $Config/LogSuccessEvent$ $Config/MonitorApplicationPartitions$ $Config/FirstReplicationPeriod$ $Config/ManagementGroupName$ false</CommandLine>
<TimeoutSeconds>$Config/TimeoutSeconds$</TimeoutSeconds>
<RequireOutput>true</RequireOutput>
<Files>
<File>
<Name>AD_Replication_Monitoring.vbs</Name>
<Contents><Script>
'*************************************************************************
' Script Name - AD Replication Monitoring
'
' Purpose - Detect replication failures and slow replication.
'
' Assumptions - Script is run by a timed event
'
' Parameters - LogSuccessEvent - True/False value to indicates to log an
' an event for script success (useful for debugging)
' ObjectUpdateThreshold - This is the threshold beyond which
' the script assumes that replication is not occurring
' or the script is not running on the other DC
' IntersiteExpectedMaxLatency - This is the expected maximum
' time that replication will take to occur between sites
' IntrasiteExpectedMaxLatency - This is the expected maximum
' time that replication will take within a site
' ChangeInjectionFrequency - This dictates how often a
' change is injected into the system. The time between
' injections is calculated as: The frequency at which
' the script runs multiplied by the value of this
' parameter
' MonitorDomainNC - If TRUE, the domain naming context is
' monitored
' MonitorConfigNC - If TRUE, the configuration naming
' context is monitored
' MonitorApplicationPartitions - If TRUE, ALL application
' partitions are monitored
' FirstReplicationPeriod - The length of time that it is
' acceptable to wait for the first complete
' replication of a naming context to occur (in hours).
' The maximum value for this parameter is 7*24=168 Hours
' IsRODC - True/False value to indicate if the machine is
' an RODC
'
' (c) Copyright 2001, Microsoft Corporation, All Rights Reserved
' Proprietary and confidential to Microsoft Corporation
'*************************************************************************
Dim strInvalidParam
If (lFirstReplicationPeriod > 168) Or (lFirstReplicationPeriod < 6) Then
strInvalidParam = strInvalidParam & "FirstReplicationPeriod must be greater than " & _
"6 and less than 168. The current value of FirstReplicationPeriod is '" & _
lFirstReplicationPeriod & "'" & vbCrLf & _
"FirstReplicationPeriod will be set to the default value of 24 for this " & _
"execution of this script." & vbCrLf & vbCrLf
lFirstReplicationPeriod = 24
End If
If 1 > lInjectFreq Then
strInvalidParam = strInvalidParam & "ChangeInjectionFrequency must be greater than 1. " & vbCrLf & _
"ChangeInjectionFrequency will be set to the default value of 6 for this execution of " & _
"this script." & vbCrlf & vbCrLf
lInjectFreq = 6
End If
If Not(bMonConfig Or bMonDomain Or bMonAppPartition) Then
strInvalidParam = strInvalidParam & "MonitorDomainNC and MonitorConfigNC and MonitorApplicationPartitions " & _
"are all False. If the intention is to not monitor " & _
"replication, disable the 'Script - " & SCRIPT_NAME & "' rule, otherwise set one of these " & _
"parameters to True. Replication latency will not be monitored for this " & _
"execution of the script." & vbCrLf & vbCrLf
End If
If 5 > lIntraSiteMaxExpectedLatency Then
strInvalidParam = strInvalidParam & "IntraSiteExpectedMaxLatency must not be less than 5 minutes." & vbCrLf & _
"IntrasiteExpectedMaxLatency = " & lIntraSiteMaxExpectedLatency & vbCrLf & _
"IntrasiteExpectedMaxLatency will be set to the default value " & _
"of 5 minutes for this execution of this script." & vbCrLf & vbCrLf
lIntraSiteMaxExpectedLatency = 5
End If
If lInterSiteMaxExpectedLatency <= lIntraSiteMaxExpectedLatency Then
strInvalidParam = strInvalidParam & "InterSiteExpectedMaxLatency must be greater than the " & _
"IntrasiteExpectedMaxLatency parameter. IntersiteExpectedMaxLatency = " & _
lInterSiteMaxExpectedLatency & vbCrLf & "IntrasiteExpectedMaxLatency = " & _
lIntraSiteMaxExpectedLatency & vbCrLf & _
"IntersiteExpectedMaxLatency will be set to the value " & _
3 * lIntraSiteMaxExpectedLatency & " for this execution of this script." & vbCrLf & vbCrLf
lInterSiteMaxExpectedLatency = 3 * lIntraSiteMaxExpectedLatency
End If
If (lUpdateThreshold * 60) < 3 * lInterSiteMaxExpectedLatency Then
strInvalidParam = strInvalidParam & "ObjectUpdateThreshold must be greater than 3 times the IntersiteExpectedMaxLatency parameter." & vbCrLf & _
"NOTE: ObjectUpdateThreshold is in hours, IntersiteExpectedMaxLatency is in minutes." & vbCrLf & _
"ObjectUpdateThreshold = " & lUpdateThreshold & " hour(s) (" & lUpdateThreshold * 60 & " minutes)" & vbCrLf & _
"IntersiteExpectedMaxLatency = " & lInterSiteMaxExpectedLatency & " minute(s)" & vbCrLf & vbCrLf & _
"ObjectUpdateThreshold will be set to 24 hours or 3 * IntersiteExpectedMaxLatency, whichever is " & _
"greater, for this execution of this script." & vbCrLf & vbCrLf
If 3 * lInterSiteMaxExpectedLatency > 24 * 60 Then
lUpdateThreshold = (3 * lInterSiteMaxExpectedLatency) / 60
Else
lUpdateThreshold = 24
End If
End If
If Len(strInvalidParam) > 0 Then
' Found invalid parameters
InvalidParam strInvalidParam
End If
Set oADOConn = CreateObject("ADODB.Connection")
If Err <> 0 Then
ScriptError "CreateObject 'ADODB.Connection'." & GetErrorString(Err)
Else
oADOConn.Provider = "ADSDsOObject"
oADOConn.Open "ADs Provider"
End If
' Parameters have been validated and are now okay.
strLDAPSearchComputer = "LDAP://" & strLocalDC & "/"
' Determine whether we should be collecting perf data for the local DC
bLocalPerfData = False
Dim dtPerfData
dtPerfData = GetData ("ReplicationLatencyPerfDataFlag")
If IsDate(dtPerfData) Then
Dim localTime
Err.Clear
dtPerfData = CDate(dtPerfData)
localTime = FromUTC(dtPerfData)
If 0 <> Err Then
ScriptError "convert to local time from UTC." & vbCrLf & _
"Replication latency performance data will not be collected on " & _
"this machine during this execution of the script." & GetLastError(Err)
Else
If 120 > DateDiff("n", localTime, Now) Then
bLocalPerfData = True
End If
End If
End If
bCollectPerfData = False
dtPerfData = 0
dtPerfData = GetData ("ReplicationCollectionPerfDataFlag")
If IsDate(dtPerfData) Then
Err.Clear
dtPerfData = CDate(dtPerfData)
localTime = FromUTC(dtPerfData)
If 0 <> Err Then
ScriptError "convert to local time from UTC." & vbCrLf & _
"Replication latency performance data will not be collected on " & _
"this machine during this execution of the script." & GetLastError(Err)
Else
If 120 > DateDiff("n", localTime, Now) Then
bCollectPerfData = True
End If
End If
End If
Set oRootDSE = GetObject(strLDAPSearchComputer & "RootDSE")
If 0 <> Err Or IsEmpty(oRootDSE) Then
ScriptError "bind to '" & strLDAPSearchComputer & "RootDSE'." & GetErrorString(Err)
Else
Dim strDomain, strSchema, astrNCs
strConfigRoot = oRootDSE.Get("ConfigurationNamingContext")
strDomain = oRootDSE.Get("DefaultNamingContext")
strSchema = oRootDSE.Get("SchemaNamingContext")
astrNCs = oRootDSE.Get("NamingContexts")
If True = bMonConfig Then
If bIsRODC Then
ReplCheck strConfigRoot, "Configuration:" & TargetFQDN, oRootDSE
ElseIf UpdateMonitor(strConfigRoot, False) Then
ReplCheck strConfigRoot, "Configuration:" & TargetFQDN, oRootDSE
End If
End If
If True = bMonDomain Then
If bIsRODC Then
ReplCheck strDomain, "Domain:" & TargetFQDN, oRootDSE
ElseIf UpdateMonitor(strDomain, False) Then
ReplCheck strDomain, "Domain:" & TargetFQDN, oRootDSE
End If
End If
Dim strFirstReplicationErrors
'
' To determine whether multiple domain controllers exist, search the configuration
' partition for NTDSSettings objects. Count the number of objects that are returned
' and that's the number of domain controllers that exist.
'
If IsArray(astrNCs) Then
Dim index
For index = 0 to UBound(astrNCs)
ValidateFirstReplication astrNCs(index), strFirstReplicationErrors
If (astrNCs(index) <> strConfigRoot) And _
(astrNCs(index) <> strDomain) And _
(astrNCs(index) <> strSchema) Then
If True = bMonAppPartition Then
If bIsRODC Then
ReplCheck astrNCs(index), "NDNC:" & astrNCs(index), oRootDSE
ElseIf UpdateMonitor(astrNCs(index), True) Then
ReplCheck astrNCs(index), "NDNC:" & astrNCs(index), oRootDSE
End If
End If
End If
Next
End If
' If any errors were detected, log them
If Len(strTimeErrors) > 0 Then
CreateTimeError strTimeErrors
End If
If Len(strSlowErrors) > 0 Then
CreateSlowError strSlowErrors
SetData "SlowErrors", "True"
ElseIf GetData("SlowErrors") = "True" Then
ResetSlowError
SetData "SlowErrors", "False"
End If
If Len(strUpdateErrors) > 0 Then
CreateUpdateError strUpdateErrors
End If
If Len(strFirstReplicationErrors) > 0 Then
CreateFirstReplError strFirstReplicationErrors
SetData "FirstReplError", "True"
ElseIf GetData("FirstReplError") = "True" Then
ResetFirstReplError
SetData "FirstReplError", "False"
End If
CheckReplProv strLocalDC, oRootDSE
If bLogSuccess Then
LogEvent EVENT_ID_SUCCESS, EVENT_TYPE_INFORMATION, "completed successfully in " & DateDiff("s", dtStart, Now) & " seconds."
End If
End If
oAPI.ReturnItems
End Sub
'******************************************************************************
Sub ReplCheck(ByRef strRoot, ByRef strContextName, ByRef oRootDSE)
'
' Purpose: To check replication for the partition identified by strRoot
'
' Arguments: strRoot, the DN for the root of the partition to be checked.
' strContextName, the human friendly name of the partition being checked.
'
On Error Resume Next
' Find all the monitoring objects in this partition
Dim oStateBag
Dim strFQDN
Dim oADOConn
Set oADOConn = CreateObject("ADODB.Connection")
If Err <> 0 Then
ScriptError "CreateObject 'ADODB.Connection'." & GetErrorString(Err)
Else
oADOConn.Provider = "ADSDsOObject"
oADOConn.Open "ADs Provider"
End If
Dim rsMonitor, strQuery
strQuery = "<" & strLDAPSearchComputer & "CN=" & MONITORING_CONTAINER_NAME & "," & strRoot & ">;(objectCategory=container);whenChanged,adminDescription,cn;oneLevel"
Set rsMonitor = oADOConn.Execute(strQuery)
If 0 <> Err Then
ScriptError "execute query '" & strQuery & "'." & GetErrorString(Err)
Else
Dim dtRemote, dtLocal, lDiffMinutes, _
strRemoteDC, strRemoteSite, bPerfData, bValidAdminDesc
dtLocal = ToUTC(Now)
If 0 <> Err Then
ScriptError "convert to UTC time." & GetErrorString(Err)
Else
strLocalSite = GetDCsSite(oADOConn, strLocalDCShortName)
If 0 <> Err Then
ScriptError "get the local DCs site." & GetErrorString(Err)
Else
Do Until rsMonitor.EOF
' Validate adminDescription
bValidAdminDesc = AdminDesc2Date(rsMonitor("adminDescription"), dtRemote, bPerfData)
strRemoteDC = rsMonitor("cn")
If strRemoteDC <> strLocalDCShortName Then
strRemoteSite = GetDCsSite(oADOConn, strRemoteDC)
If bValidAdminDesc Then
If DateDiff("s", dtLocal, dtRemote) > 30 Then
TimeError strRemoteSite, strRemoteDC, dtRemote, dtLocal, strTimeErrors
Else
lDiffMinutes = DateDiff("n", dtRemote, dtLocal)
If lDiffMinutes > (lUpdateThreshold * 60) Then
' If the DC is still valid (i.e. the DC is still a DC in AD) then generate an error
' otherwise clean up the MOM Latency Monitor object for the DC.
Dim bValidDC
bValidDC = IsValidDC(strRemoteDC)
If 0 = Err Then
If bValidDC Then
UpdateError strRemoteDC, strRemoteSite, lDiffMinutes \ 60, strContextName, strUpdateErrors
strFQDN = GetFQDNForDC(rsMonitor("cn"), oRootDSE)
Set oStateBag = CreatePropertyBagFor("Update", strFQDN, strRemoteDC, "", oRootDSE, oADOConn)
oAPI.addItem oStateBag
Set oStateBag = Nothing
Else
CleanUpMLMObject strRemoteDC, strRoot
End If
End If
Else
lDiffMinutes = DateDiff("n", dtRemote, CDate(rsMonitor("whenChanged")))
' Check the intra and inter site replication latencies
If strLocalSite = strRemoteSite Then
If lDiffMinutes > 3 * lIntraSiteMaxExpectedLatency Then
SlowError strRemoteDC, strRemoteSite, lDiffMinutes, strContextName, strSlowErrors
strFQDN = GetFQDNForDC(rsMonitor("cn"), oRootDSE)
Set oStateBag = CreatePropertyBagFor("Latency", strFQDN, strRemoteDC, "", oRootDSE, oADOConn)
oAPI.addItem oStateBag
Set oStateBag = Nothing
End If
Else
If lDiffMinutes > 3 * lInterSiteMaxExpectedLatency Then
SlowError strRemoteDC, strRemoteSite, lDiffMinutes, strContextName, strSlowErrors
strFQDN = GetFQDNForDC(rsMonitor("cn"), oRootDSE)
Set oStateBag = CreatePropertyBagFor("Latency", strFQDN, strRemoteDC, "", oRootDSE, oADOConn)
oAPI.addItem oStateBag
Set oStateBag = Nothing
End If
End If
If bPerfData And bCollectPerfData Then
If GetData(strContextName & ":" & strRemoteDC & "_Update") <> dtRemote Then
Dim oPerfBag
Set oPerfBag = oAPI.CreateTypedPropertyBag(PerformanceDataType)
Call oPerfBag.AddValue("StatusCounter", "Replication Latency")
Call oPerfBag.AddValue("StatusInstance",strContextName & ":" & strRemoteDC)
Call oPerfBag.AddValue("StatusValue","" & lDiffMinutes )
Call oAPI.addItem(oPerfBag)
SetData strContextName & ":" & strRemoteDC & "_Update", dtRemote
Call CreatePerfData( strRemoteDC, lDiffMinutes)
End If
End If
End If
End If
End If
End If
rsMonitor.MoveNext
Loop
End If
End If
End If
End Sub
Function GetFQDNFromDN(ByRef strDN)
Dim oDC
Set oDC = GetObject(strDN)
GetFQDNFromDN = oDC.dnsHostName
End Function
Function GetFQDNForDC(ByRef strDC, ByRef oRootDSE)
Dim strFQDN
strFQDN = oRootDSE.Get("defaultNamingContext")
strFQDN = Mid(strFQDN, 4)
strFQDN = strDC & "." & Replace(strFQDN, ",DC=", ".")
GetFQDNForDC = strFQDN
End Function
Function CreatePropertyBag(ByRef strBucket, ByRef strKey, ByRef strValue)
Dim oStateBag
Set oStateBag = oAPI.CreateTypedPropertyBag(0)
oStateBag.AddValue "Bucket", strBucket
oStateBag.AddValue strKey, strValue
Set CreatePropertyBag = oStateBag
End Function
Function CreatePropertyBagFor(ByRef strBucket, ByRef strFQDN, ByRef strDC, ByRef strDN, ByRef oRootDSE, ByRef oADOConn)
Dim oStateBag
Set oStateBag = oAPI.CreateTypedPropertyBag(0)
oStateBag.AddValue "Bucket", strBucket
oStateBag.AddValue "Type", GetTargetDCType(strDC, oRootDSE, oADOConn)
oStateBag.AddValue "CN", strDC
oStateBag.AddValue "FQDN", strFQDN
oStateBag.AddValue "DN", strDN
Set CreatePropertyBagFor = oStateBag
End Function
Function GetTargetDCType(ByRef strDC, ByRef oRootDSE, ByRef oADOConn)
Dim strQuery
Dim cVersion
Dim strVersion
strQuery = "<LDAP://OU=domain controllers," & oRootDSE.Get("defaultNamingContext") & ">;(CN=" & strDC & ");operatingSystemVersion;oneLevel"
Set cVersion = oADOConn.Execute(strQuery)
strVersion = Left(cVersion.Fields("operatingSystemVersion").Value, 3)
GetTargetDCType = strVersion
End Function
'******************************************************************************
Function UpdateMonitor(strRoot, bIsNDNC)
'
' Purpose: To update the local DCs monitoring object for the partition
' identified by strRoot
'
' Arguments: strRoot, the DN for the root of the partition to be checked.
' bIsNDNC, True if the root is an NDNC, False otherwise
'
' Returns: Boolean, True if successful, False otherwise
'
On Error Resume Next
UpdateMonitor = False
' Check whether we actually need to update this naming context at the moment
Dim lUpdateCount, tlUpdateCount
tlUpdateCount = GetData("ExecutionsSinceLastUpdate" & strRoot)
if tlUpdateCount = "" Then
lUpdateCount = 0
Else
lUpdateCount = CLng(tlUpdateCount)
End if
If ((CLng(lUpdateCount) >= CLng(lInjectFreq)) Or (lUpdateCount = 0)) Then
' Look for the object that we want to update, if it's not there create it
Dim oObj
Set oObj = GetObject(strLDAPSearchComputer & "CN=" & strLocalDCShortName & ",CN=" & MONITORING_CONTAINER_NAME & "," & strRoot)
If 0 <> Err Then
oObj = 0
Err.Clear
' Look for the container in the root, if it's not there, create it on a uniquely identifiable
' DC. (Depends upon naming context.)
Dim oCont
Set oCont = GetObject(strLDAPSearchComputer & "CN=" & MONITORING_CONTAINER_NAME & "," & strRoot)
If 0 <> Err Then
oCont = 0
Err.Clear
' If we are updating one of the standard NCs, then find the PDC, if we are updating an
' NDNC then find the infrastructure master and create the container there.
Dim strLDAPSearchMaster
If bIsNDNC Then
Dim oRoleMaster
' Get the Infrastructure Master
Set oRoleMaster = GetInfrastructureMasterUsingWellKnownGUID(strRoot)
If 0 <> Err Then
ScriptError "obtain the InfrastructureMaster using a well known GUID." & GetErrorString(Err)
Else
strLDAPSearchMaster = "LDAP://" & oRoleMaster.Get("dnsHostName") & "/"
End If
Set oRoleMaster = Nothing
Else
' Get the PDC from the COM object
Dim oAD
Set oAD = CreateObject("McActiveDir.ActiveDirectory")
If 0 <> Err Then
ScriptError "create the 'McActiveDir.ActiveDirectory' object." & GetErrorString(Err)
Else
strLDAPSearchMaster = "LDAP://" & oAD.PDCMaster & "/"
Set oAD = Nothing
End If
End If
If Len(strLDAPSearchMaster) Then
'
' Attempt to get the container object on the search master. If it does not exist,
' create it. If it does exist then just wait for it to be replicated to us.
'
Set oCont = GetObject(strLDAPSearchMaster & "CN=OpsMgrLatencyMonitors," & strRoot)
'
' If we encountered an error, assume it was an 'object did not exist' type
' of error and try to make the object. If it was an access error then
' we'll create an event when we try to create the object.
'
If Err <> 0 Then
Err.Clear
Dim oRoot
Set oRoot = GetObject(strLDAPSearchMaster & strRoot)
If 0 <> Err Then
ScriptError "GetObject('" & strLDAPSearchMaster & strRoot & "')" & GetErrorString(Err)
Else
Set oCont = oRoot.Create("container", "CN=" & MONITORING_CONTAINER_NAME)
If 0 <> Err Then
ScriptError "Create('container', 'CN=" & MONITORING_CONTAINER_NAME & "')." & GetErrorString(Err)
Else
oCont.SetInfo
If &H80070005 = Err Then
AccessError "create the " & MONITORING_CONTAINER_NAME & " container", strRoot
oCont = 0
ElseIf 0 <> Err Then
ScriptError "create the container 'CN=" & MONITORING_CONTAINER_NAME & "," & strRoot & "'." & _
GetErrorString(Err) & vbCrLf & vbCrLf & "Check the access permissions for this object."
oCont = 0
End If
End If
End If
Else
Set oCont = 0
End If
End If
End If
Err.Clear
If IsObject(oCont) Then
' Look for the local DCs object in the container
Set oObj = oCont.GetObject("container", "CN=" & strLocalDCShortName)
If 0 <> Err Then
Err.Clear
' Try to create the object
Set oObj = oCont.Create("container", "CN=" & strLocalDCShortName)
If 0 <> Err Then
ScriptError "create the object named '" & strLocalDCShortName & "' in the container " & _
"'CN=" & MONITORING_CONTAINER_NAME & "," & strRoot & "'." & GetErrorString(Err)
oObj = 0
End If
End If
End If
End If
If IsObject(oObj) Then
' Update the adminDescription attribute
Dim strAdminDesc
strAdminDesc = Date2AdminDesc(Now, bLocalPerfData)
oObj.adminDescription = strAdminDesc
If 0 <> Err Then
ScriptError "write '" & strAdminDesc & "' to the adminDescription attribute of 'CN=" & _
strLocalDCShortName & ",CN=" & MONITORING_CONTAINER_NAME & "," & strRoot & "'." & GetErrorString(Err)
Else
oObj.SetInfo
If &H80070005 = Err Then
AccessError "update this DCs monitoring object", strRoot
oCont = 0
ElseIf 0 <> Err Then
ScriptError "write the adminDescription attribute of 'CN=" & strLocalDCShortName & ",CN=" & MONITORING_CONTAINER_NAME & "," & _
strRoot & "' to Active Directory." & GetErrorString(Err) & vbCrLf & "Check the access " & _
"permissions for this object."
Else
lUpdateCount = 1
UpdateMonitor = True
End If
End If
End If
Else
lUpdateCount = lUpdateCount + 1
' Only say we succeeded if the container object exists. If it does not exist then
' ReplCheck will create an error which will be misleading.
Set oCont = GetObject(strLDAPSearchComputer & "CN=" & MONITORING_CONTAINER_NAME & "," & strRoot)
If Err = 0 Then
UpdateMonitor = True
Set oCont = Nothing
End If
End If
SetData "ExecutionsSinceLastUpdate" & strRoot, lUpdateCount
End Function
'******************************************************************************
Function GetErrorString(oErr)
'
' Purpose: Attempts to find the description for an error if an error with
' no description is passed in.
'
' Parameters: oErr, the error object
'
' Return: String, the description for the error. (Includes the error code.)
'
Dim lErr, strErr
lErr = oErr
strErr = oErr.Description
On Error Resume Next
If 0 >= Len(strErr) Then
' If we don't have an error description, then check to see if the error
' is a 0x8007xxxx error. If it is, then look it up.
Const ErrorMask = &HFFFF0000
Const HiWord8007 = &H80070000
Const LoWordMask = 65535 ' This is equivalent to 0x0000FFFF
If (lErr And ErrorMask) = HiWord8007 Then
' Attempt to use 'net helpmsg' to get a description for the error.
Dim oShell
Set oShell = CreateObject("WScript.Shell")
If Err = 0 Then
Dim oExec
Set oExec = oShell.Exec("net helpmsg " & (lErr And LoWordMask))
Dim strMessage, i
Do
strMessage = oExec.stdout.ReadLine()
i = i + 1
Loop While (Len(strMessage) = 0) And (i < 5)
strErr = strMessage
End If
End If
End If
GetErrorString = vbCrLf & "The error returned was: '" & strErr & "' (0x" & Hex(lErr) & ")"
End Function
'******************************************************************************
Sub ScriptError(strError)
'
' Purpose: To generate a warning about a runtime script error.
'
' Arguments: strError, the description of the error
'
LogEvent EVENT_ID_SCRIPTERROR, EVENT_TYPE_WARNING, "encountered a runtime error." & vbCrLf & "Failed to " & strError
End Sub
'******************************************************************************
Sub AccessError(strError, strNCRoot)
'
' Purpose: To generate a warning about an access/permissions error.
'
' Arguments: strError, the description of the error
' strNCRoot, the DN of the naming context root
'
LogEvent EVENT_ID_ACCESSDENIED, EVENT_TYPE_WARNING, "encountered a permissions error." & vbCrLf & _
"The script failed to " & strError & " in the naming context '" & _
strNCRoot & "' because access was denied. Alter the permissions for this " & _
"naming context so that the script can add this container, or change the " & _
"parameters for this script to stop monitoring this naming context." & vbCrLf & _
GetErrorString(Err)
End Sub
'******************************************************************************
Sub InvalidParam(strError)
'
' Purpose: To generate an invalid parameter warning.
'
' Arguments: strError, the description of the error
'
LogEvent EVENT_ID_INVALIDPARAMETER, EVENT_TYPE_WARNING, "detected an error with one or more " & _
"parameters. The error is:" & vbCrLf & strError & vbCrLf & vbCrLf & _
"To correct the error, find the rule 'Script - " & SCRIPT_NAME & "' and from the response tab of it's " & _
"properties, edit the script and modify the parameter in question."
End Sub
'******************************************************************************
Sub LogEvent(lEventID, lEventType, strMessage)
'
' Purpose: To generate a MOM event
'
' Arguments: lEventID, the event code
' lEventType, the severity of the event
' strMessage, the message to include in the event
'
call CreateEventEx(lEventID, lEventType, strMessage)
End Sub
'******************************************************************************
Sub CreateEvent(lEventID, lEventType, strMessage)
'
' Purpose: To generate a MOM event
'
' Arguments: lEventID, the event code
' lEventType, the severity of the event
' strMessage, the message to include in the event
'
call CreateEventEx(lEventID, lEventType, strMessage)
End Sub
'******************************************************************************
Sub CreateEventEx(lEventID, lEventType, strMessage)
'
' Purpose: To generate a MOM event
'
' Arguments: lEventID, the event code
' lEventType, the severity of the event
' strMessage, the message to include in the event
'
oAPI.LogScriptEvent "AD Replication Monitoring", lEventID, lEventType, strMessage
if (lEventID=EVENT_ID_TIMESKEW or lEventID=EVENT_ID_ALLREPLICATIONLINKSFAILED or lEventID=EVENT_ID_FIRST_REPLICATION _
or lEventID=EVENT_ID_CLEANED_UP_NAMING_CONTEXT ) then
nState=1
end if
if (lEventID=EVENT_ID_NOUPDATEOCCURRED or lEventID=EVENT_ID_SLOWREPLICATION or lEventID=EVENT_ID_SOMEREPLICATIONLINKSFAILED _
or lEventID=EVENT_ID_INVALIDPARAMETER or lEventID=EVENT_ID_ACCESSDENIED or lEventID=EVENT_ID_REPLPROVINSTALLED ) then
if (nState<>1) then
nState=2
end if
end if
End Sub
'******************************************************************************
Function ToUTC(dtLocal)
'
' Purpose: To convert a date time to UTC
'
' Arguments: dtLocal
'
' Returns: Date, wrt to UTC
'
Dim oSet, oOS, lTZOffset
Set oSet = GetObject("winmgmts:").InstancesOf("Win32_OperatingSystem")
For Each oOS In oSet
lTZOffset = oOS.CurrentTimeZone
Next
dtLocal = dtLocal - (lTZOffset / 1440) ' Minutes per day
ToUTC = dtLocal
End Function
'******************************************************************************
Function FromUTC(dtUTC)
'
' Purpose: To convert a date time from UTC to Local
'
' Arguments: dtUTC
'
' Returns: Date, wrt to local time
'
Dim oSet, oOS, lTZOffset
Set oSet = GetObject("winmgmts:").InstancesOf("Win32_OperatingSystem")
For Each oOS In oSet
lTZOffset = oOS.CurrentTimeZone
Next
dtUTC = dtUTC + (lTZOffset / 1440) ' Minutes per day
FromUTC = dtUTC
End Function
'******************************************************************************
Function AdminDesc2Date(strAdminDesc, ByRef dtRemote, ByRef bPerfData)
'
' Purpose: Converts from the known internal format of adminDescription to
' a date and a flag identifying whether perf data is recorded.
'
' Arguments: [in] strAdminDesc - the raw adminDescription field value
' [out] dtRemote - the date encoded in the field
' [out] bPerfData - whether perf data should be recorded for this DC
'
' Returns: Boolean, True if strAdminDesc is valid, False otherwise
'
On Error Resume Next
Dim lDecimal, lPerfFlag
lDecimal = Instr(strAdminDesc, ".")
If (13 <= Len(strAdminDesc)) And (9 = lDecimal) Then
dtRemote = DateSerial(Mid(strAdminDesc, 1, 4), Mid(strAdminDesc, 5, 2), Mid(strAdminDesc, 7, 2)) + _
TimeSerial(Mid(strAdminDesc, 10, 2), Mid(strAdminDesc, 12, 2), 0)
lPerfFlag = Instr(strAdminDesc, "P")
If -1 <> lPerfFlag Then
If "P1" = Mid(strAdminDesc, lPerfFlag, 2) Then
bPerfData = True
End If
End If
AdminDesc2Date = IsDate(dtRemote)
End If
End Function
'******************************************************************************
Function TwoDigitDatePart(strDatePart, dtDate)
'
' Purpose: Returns part of a date padded to a minimum of two digits with
' zeroes
'
' Arguments: strDatePart, the part of the date to get (see MSDN DatePart)
' dtDate, the date to get the part from
'
' Returns: String, the two digit part of the date
'
Dim temp
temp = DatePart(strDatePart, dtDate)
If 1 = Len(temp) Then
TwoDigitDatePart = "0" & temp
Else
TwoDigitDatePart = temp
End If
End Function
'******************************************************************************
Function Date2AdminDesc(dtLocal, bPerfData)
'
' Purpose: Converts from the a date and flag to the known internal format
' of adminDescription.
'
' Arguments: dtLocal - the date to be encoded in the field (local time)
' bPerfData - whether perf data should be recorded for this DC
'
' Returns: String, adminDescription value
'
On Error Resume Next
Date2AdminDesc = ""
If IsDate(dtLocal) Then
dtLocal = ToUTC(dtLocal)
If 0 <> Err Then
ScriptError "convert to UTC time." & GetErrorString(Err)
Else
Date2AdminDesc = DatePart("yyyy", dtLocal) & _
TwoDigitDatePart("m", dtLocal) & _
TwoDigitDatePart("d", dtLocal) & "." & _
TwoDigitDatePart("h", dtLocal) & _
TwoDigitDatePart("n", dtLocal) & " "
If CBool(bPerfData) Then
Date2AdminDesc = Date2AdminDesc & "P1"
End If
End If
End If
End Function
'******************************************************************************
Sub TimeError(strRemoteSite, strRemoteDC, dtRemote, dtLocal, ByRef strErrors)
'
' Purpose: Adds information to the string containing the detected time errors
'
' Arguments: [in] strRemoteSite - the remote site name
' [in] strRemoteDC - the remote DCs name
' [in] dtRemote - the date from the remote DC
' [in] dtLocal - the data from the local DC
' [in, out] strErrors - the error string
'
strErrors = strErrors & strRemoteSite & Chr(7) & strRemoteDC & Chr(7) & _
CStr(dtRemote) & vbCrLf
End Sub
'******************************************************************************
Sub UpdateError(strRemoteDC, strRemoteSite, lDiffMinutes, strContextName, ByRef strErrors)
'
' Purpose: Adds information to the string containing the detected update errors
'
' Arguments: [in] strRemoteDC - the remote DCs name
' [in] strRemoteSite - the site of the remote DC
' [in] lDiffMinutes - how long ago the last update occurred
' [in] strContextName - the naming context
' [in, out] strErrors - the error string
'
strErrors = strErrors & strRemoteSite & Chr(7) & strRemoteDC & Chr(7) & lDiffMinutes & Chr(7) & strContextName & vbCrLf
End Sub
'******************************************************************************
Sub SlowError(strRemoteDC, strRemoteSite, lDiffMinutes, strContextName, ByRef strErrors)
'
' Purpose: Adds information to the string containing the detected slow errors
'
' Arguments: [in] strRemoteDC - the remote DCs name
' [in] strRemoteSite - the site of the remote DC
' [in] lDiffMinutes - how long ago the last update occurred
' [in] strContextName - the naming context
' [in, out] strErrors - the error string
'
strErrors = strErrors & strRemoteSite & Chr(7) & strRemoteDC & Chr(7) & lDiffMinutes & Chr(7) & strContextName & vbCrLf
End Sub
'******************************************************************************
Function GetDCsSite(oADOConn, strDCName)
'
' Purpose: To obtain the site DN from a DCs DN
'
' Arguments: oADOConn, an ADOConnection object to perform a search with
' strDCDistiguishedName, the DCs DN
'
' Returns: String, the site DN
'
On Error Resume Next
GetDCsSite = ""
' Work out what the remote DCs site is.
Dim rsDC, strQuery
strQuery = "<" & strLDAPSearchComputer & "CN=Sites," & strConfigRoot & ">;(&(cn=" & strDCName & ")(objectCategory=server));distinguishedName;subtree"
Set rsDC = oADOConn.Execute(strQuery)
If 0 <> Err Then
ScriptError "execute the following query:" & vbCrLf & strQuery & GetErrorString(Err)
Else
Dim lTemp, strTemp
Do Until rsDC.EOF
strTemp = rsDC("distinguishedName")
lTemp = Instr(strTemp, ",CN=")
If lTemp > 0 Then
lTemp = Instr(lTemp + 4, strTemp, "CN=")
If lTemp > 0 Then
' Get the Site, skipping the CN= bit
strTemp = Mid(strTemp, lTemp + 3)
lTemp = Instr(strTemp, ",CN=")
If lTemp > 1 Then
GetDCsSite = Left(strTemp, lTemp - 1)
End If
End If
End If
rsDC.MoveNext
Loop
End If
End Function
'******************************************************************************
Sub CreateUpdateError(strErrors)
'
' Purpose: Convert the strErrors string into an event message and log it.
'
' Arguments: strErrors, the string containing the details of the DCs with
' update errors.
'
' Sort the lines in the string based on site.
Dim aSorted
aSorted = SortByFirstColumn(strErrors, strLocalSite)
Dim index, lTemp, strMessage, strLastSite
For index = 0 to UBound(aSorted, 2) - 1
If strLastSite <> aSorted(0, index) Then
strLastSite = aSorted(0, index)
strMessage = strMessage & strLastSite & vbCrLf
End If
lTemp = Instr(aSorted(1, index), Chr(7))
If lTemp > 0 Then
Dim strDC, strTime, strNC
strDC = Left(aSorted(1, index), lTemp - 1)
strTime = Mid(aSorted(1, index), lTemp + 1)
lTemp = Instr(strTime, Chr(7))
If lTemp > 0 Then
strNC = Mid(strTime, lTemp + 1)
strTime = Left(strTime, lTemp - 1)
End If
strMessage = strMessage & " " & strDC & ", " & strNC & ", " & strTime & vbCrLf
End If
Next
CreateEvent EVENT_ID_NOUPDATEOCCURRED, EVENT_TYPE_WARNING, "The following DCs have not updated their OpsMgrLatencyMonitor " & _
"objects within the specified time period (" & lUpdateThreshold & " hours). " & _
"This is probably caused by either replication not occurring, or because the '" & _
SCRIPT_NAME & "' script is not running on the DC." & vbCrLf & vbCrLf & _
"Format: DC, Naming Context, Hours since last update" & vbCrLf & vbCrLf & _
strMessage
End Sub
'******************************************************************************
Sub CreateSlowError(strErrors)
'
' Purpose: Convert the strErrors string into an event message and log it.
'
' Arguments: strErrors, the string containing the details of the DCs with
' slow replication errors.
'
' Sort the lines in the string based on site
Dim aSorted
aSorted = SortByFirstColumn(strErrors, strLocalSite)
Dim index, lTemp, strMessage, strLastSite
For index = 0 to UBound(aSorted, 2) - 1
If strLastSite <> aSorted(0, index) Then
strLastSite = aSorted(0, index)
strMessage = strMessage & vbCrLf & "Site name: " & strLastSite & vbCrLf
If strLastSite = strLocalSite Then
strMessage = strMessage & "(Intrasite, expected replication time is " & lIntraSiteMaxExpectedLatency & " minutes)" & vbCrLf
Else
strMessage = strMessage & "(Intersite, expected replication time is " & lInterSiteMaxExpectedLatency & " minutes)" & vbCrLf
End If
End If
lTemp = Instr(aSorted(1, index), Chr(7))
If lTemp > 0 Then
Dim strDC, strTime, strNC
strDC = Left(aSorted(1, index), lTemp - 1)
strTime = Mid(aSorted(1, index), lTemp + 1)
lTemp = Instr(strTime, Chr(7))
If lTemp > 0 Then
strNC = Mid(strTime, lTemp + 1)
strTime = Left(strTime, lTemp - 1)
End If
strMessage = strMessage & " " & strDC & ", " & strNC & ", " & strTime & vbCrLf
End If
Next
CreateEvent EVENT_ID_SLOWREPLICATION, EVENT_TYPE_WARNING, "The following DCs took more than three times the expected " & _
"replication time to replicate." & vbCrLf & vbCrLf & _
"Format: DC, Naming Context, Calculated Replication Time (in minutes)" & vbCrLf & _
vbCrLf & strMessage
End Sub
'******************************************************************************
Sub ResetSlowError()
'
' Purpose: Create a 'success' event indicating slow replication is no longer
' a problem
'
' Arguments: None
'
CreateEvent EVENT_ID_SLOWREPLICATION, EVENT_TYPE_SUCCESS, "Slow replication is no longer occurring on this DC."
End Sub
'******************************************************************************
Sub CreateTimeError(strErrors)
'
' Purpose: Convert the strErrors string into an event message and log it.
'
' Arguments: strErrors, the string containing the details of the DCs with
' invalid timestamp errors.
'
' Sort the lines in the string based on site
Dim aSorted
aSorted = SortByFirstColumn(strErrors, strLocalSite)
Dim index, lTemp, strMessage, strLastSite
For index = 0 to UBound(aSorted, 2) - 1
If strLastSite <> aSorted(0, index) Then
strLastSite = aSorted(0, index)
strMessage = strMessage & strLastSite & vbCrLf
End If
lTemp = Instr(aSorted(1, index), Chr(7))
If lTemp > 0 Then
Dim strDC, strTime
strDC = Left(aSorted(1, index), lTemp - 1)
Err.Clear
strTime = FromUTC(CDate(Mid(aSorted(1, index), lTemp + 1)))
If 0 <> Err Then
strTime = Mid(aSorted(1, index), lTemp + 1) & " (UTC)"
End If
strMessage = strMessage & " " & strDC & " reported time: " & strTime & vbCrLf
End If
Next
CreateEvent EVENT_ID_TIMESKEW, EVENT_TYPE_WARNING, "The following DCs have clocks which are set in the future. " & _
"This can cause replication errors in Active Directory and prevents the '" & _
SCRIPT_NAME & "' script from detecting replication errors." & vbCrLf & _
strMessage
End Sub
'******************************************************************************
Sub CreateFirstReplError(strErrors)
'
' Purpose: Convert the strErrors string into an event message and log it.
'
' Arguments: strErrors, the string containing the details of the naming
' contexts that have yet to sync for the first time, or that
' generated errors when the check was made.
'
CreateEvent EVENT_ID_FIRST_REPLICATION, EVENT_TYPE_WARNING, "The following naming contexts " & _
"have not replicated for the first time or produced an error when " & _
" attempting to determine whether they have replicated for the first time." & _
vbCrLf & vbCrLf & strErrors
End Sub
'******************************************************************************
Sub ResetFirstReplError()
'
' Purpose: Create a 'success' event indicating that the first replication
' cycle has completed successfully
'
' Arguments: None
'
CreateEvent EVENT_ID_FIRST_REPLICATION, EVENT_TYPE_SUCCESS, "The first replication cycle has completed successfully."
End Sub
'******************************************************************************
Function SortByFirstColumn(strErrors, strFirstMatch)
'
' Purpose: Sorts the lines contained in a string by the first column.
'
' Arguments: strErrors, the string containing the lines to sort.
' Columns are delimited by chr(7)
' strFirstMatch, a special case value which is always sorted to
' the top of the list.
'
Dim aSorted, index, index2
Do While Len(strErrors) > 0
Dim strSite, lTemp
lTemp = Instr(strErrors, Chr(7))
If lTemp > 0 Then
strSite = Left(strErrors, lTemp - 1)
strErrors = Mid(strErrors, lTemp + 1)
lTemp = Instr(strErrors, vbCrLf)
Dim aRow
If lTemp > 0 Then
aRow = Array(strSite, Left(strErrors, lTemp - 1))
strErrors = Mid(strErrors, lTemp + 2)
Else
aRow = Array(strSite, strErrors)
strErrors = ""
End If
If IsArray(aSorted) Then
Dim bInserted
bInserted = False
For index = 0 to UBound(aSorted, 2)
If (aRow(0) = strFirstMatch) Or (aRow(0) < aSorted(0, index)) Then
' Insert here
Redim Preserve aSorted(2, UBound(aSorted, 1) + 1)
For index2 = UBound(aSorted, 2) - 1 to index + 1 step -1
aSorted(0, index2) = aSorted(0, index2 - 1)
aSorted(1, index2) = aSorted(1, index2 - 1)
Next
aSorted(0, index) = aRow(0)
aSorted(1, index) = aRow(1)
bInserted = True
Exit For
End If
Next
If Not(bInserted) Then
Redim Preserve aSorted(2, UBound(aSorted, 2) + 1)
aSorted(0, UBound(aSorted, 2) - 1) = aRow(0)
aSorted(1, UBound(aSorted, 2) - 1) = aRow(1)
End If
Else
Redim aSorted(2, 1)
aSorted(0, 0) = aRow(0)
aSorted(1, 0) = aRow(1)
End If
Else
Exit Do
End If
Loop
SortByFirstColumn = aSorted
End Function
'******************************************************************************
Function CreatePerfData(strDCName, lLatency)
'
' Purpose: Handles all aspects of performance data calculation. Stores the
' necessary performance data, and calculates min, max and average
' on a daily basis and sends those to MOM.
'
' Arguments: strDCName, the name of the DC for which the new data is applicable
' lLatency, the latest sample value of replication latency (in minutes)
'
On Error Resume Next
Dim lMin, lMax, lCumulativeLatency, lSampleCount, dtLastDate ,tmp
tmp = GetData(strDCName & "_Min")
if ( tmp = "") Then
lMin = 0
Else
lMin = CLng(tmp)
End if
tmp = GetData(strDCName & "_Max")
if ( tmp = "")Then
lMax = 0
Else
lMax = CLng(tmp)
End if
tmp = GetData(strDCName & "_Cum")
if ( tmp = "")Then
lCumulativeLatency = 0
Else
lCumulativeLatency = CLng(tmp)
End if
tmp = GetData(strDCName & "_Cnt")
if ( tmp = "")Then
lSampleCount = 0
Else
lSampleCount = CLng(tmp)
End if
dtLastDate = GetData(strDCName & "_Date")
Dim lDiff
lDiff = DateDiff("d", dtLastDate, Now)
If (lDiff <> 0) Or (dtLastDate = "") Then
If Not(dtLastDate="") Then
Set oBag= oAPI.CreateTypedPropertyBag(PerformanceDataType)
Call oBag.AddValue("StatusCounter", "Replication Latency:Minimum")
Call oBag.AddValue("StatusInstance",strDCName)
Call oBag.AddValue("StatusValue","" & lMin )
Call oAPI.addItem(oBag)
Set oBag= oAPI.CreateTypedPropertyBag(PerformanceDataType)
Call oBag.AddValue("StatusCounter", "Replication Latency:Maximun")
Call oBag.AddValue("StatusInstance",strDCName)
Call oBag.AddValue("StatusValue","" & lMax )
Call oAPI.addItem(oBag)
Set oBag= oAPI.CreateTypedPropertyBag(PerformanceDataType)
Call oBag.AddValue("StatusCounter", "Replication Latency:Average")
Call oBag.AddValue("StatusInstance",strDCName)
Call oBag.AddValue("StatusValue","" & (lCumulativeLatency \ lSampleCount) )
Call oAPI.addItem(oBag)
End If
SetData strDCName & "_Date", CStr(Now)
SetData strDCName & "_Cnt", 1
SetData strDCName & "_Min", lLatency
SetData strDCName & "_Max", lLatency
SetData strDCName & "_Cum", lLatency
Else
SetData strDCName & "_Cnt", lSampleCount + 1
If lLatency < lMin Then
SetData strDCName & "_Min", lLatency
End If
If lLatency > lMax Then
SetData strDCName & "_Max", lLatency
End If
SetData strDCName & "_Cum", lCumulativeLatency + lLatency
End If
End Function
'******************************************************************************
' CheckReplProv
' - Checks that replication is occurring using the WMI replication provider.
' - strLocalDC
' - oRootDSE
'******************************************************************************
Sub CheckReplProv(ByRef strLocalDC, ByRef oRootDSE)
On Error Resume Next
Dim oWMIObjs
Dim oPartner
Dim iNeighborCount
Dim iFailureCount
Dim strCN
Dim strFQDN
Dim strDN
Dim oStateBag
Dim strMessage
Dim oADOConn
Dim lTemp
Dim strTemp
Dim strNC
Dim dtLastSuccess
Set oADOConn = CreateObject("ADODB.Connection")
If Err <> 0 Then
ScriptError "CreateObject 'ADODB.Connection'." & GetErrorString(Err)
Else
oADOConn.Provider = "ADSDsOObject"
oADOConn.Open "ADs Provider"
End If
strMessage = "Format: DC, Naming Context, Last Successful Replication Time" & vbCrLf & vbCrLf & strMessage
Set oWMIObjs = GetObject("winmgmts:\\" & strLocalDC & "\root\MicrosoftActiveDirectory").InstancesOf("MSAD_ReplNeighbor")
If Err <> 0 Then
' Decide whether the error indicates that the WMI Provider is not installed
' (one of the following errors: Provider Not Found, Invalid Class, Invalid Object
' or Invalid Namespace) or another more generic error.
If Err.number = &H80041011 Or _
Err.number = &H80041010 Or _
Err.number = &H8004100F Or _
Err.number = &H8004100E Then
' This is to be expected if we are running on Win2K and don't have the
' replication provider installed.
LogEvent EVENT_ID_REPLPROVINSTALLED, EVENT_TYPE_INFORMATION, _
"The WMI Replication Provider is not installed." & _
GetErrorString(Err)
Else
' An error that does not necessarily indicate that the provider is not
' installed has occurred. Generate a generic error event.
ScriptError "determine whether the WMI Replication Provider is installed." & _
GetErrorString(Err)
End If
Exit Sub
End If
iFailureCount = 0
iNeighborCount = oWMIObjs.Count
For Each oPartner in oWMIObjs
If oPartner.ModifiedNumConsecutiveSyncFailures >= 2 Then
iFailureCount = iFailureCount + 1
strCN = oPartner.SourceDsaCN
Dim tempString
tempString = GetObject("LDAP://" & oPartner.SourceDsaDN).Parent
strFQDN = GetFQDNFromDN(tempString)
strDN = strFQDN & ":" & oPartner.NamingContextDN
Set oStateBag = CreatePropertyBagFor("SOMEREPLICATIONLINKSFAILED", strFQDN, strCN, strDN, oRootDSE, oADOConn)
oAPI.addItem oStateBag
Set oStateBag = Nothing
dtLastSuccess = oPartner.TimeOfLastSyncSuccess
If Len(dtLastSuccess) >= 14 Then
dtLastSuccess = DateSerial(Mid(dtLastSuccess, 1, 4), Mid(dtLastSuccess, 5, 2), Mid(dtLastSuccess, 7, 2)) + TimeSerial(Mid(dtLastSuccess, 9, 2), Mid(dtLastSuccess, 11, 2), Mid(dtLastSuccess, 13, 2))
End If
strNC = oPartner.NamingContextDN
lTemp = Instr(strNC, "=")
If lTemp > 0 Then
strTemp = Mid(strNC, lTemp + 1)
lTemp = Instr(strTemp, ",")
If lTemp > 0 Then
If Left(strNC, 3) = "DC=" Then
strNC = "Domain:"
Else
strNC = ""
End If
strNC = strNC & Left(strTemp, lTemp - 1)
End If
End If
strMessage = strMessage & oPartner.SourceDsaCN & ", " & strNC & ", " & dtLastSuccess & vbCrLf
End If
Next
If iFailureCount > 0 Then
If iFailureCount = iNeighborCount Then
CreateEvent EVENT_ID_ALLREPLICATIONLINKSFAILED, EVENT_TYPE_ERROR, "All of the replication partners for '" & _
strLocalDC & "' are failing to replicate. This indicates that no " & _
"updates are being received on this DC." & vbCrLf & vbCrLf & _
strMessage
Set oStateBag = CreatePropertyBag("ALLREPLICATIONLINKSFAILED", "Event", strMessage)
oAPI.addItem oStateBag
Set oStateBag = Nothing
Else
CreateEvent EVENT_ID_SOMEREPLICATIONLINKSFAILED, EVENT_TYPE_WARNING, "Some of the replication partners for '" & _
strLocalDC & "' are failing to replicate. Replication may still be " & _
"occurring via other replication partners." & vbCrLf & vbCrLf & _
strMessage
End If
End If
End Sub
'******************************************************************************
Function GetInfrastructureMasterUsingWellKnownGUID(strNCDN)
'
' Purpose: Finds (if available) the infrastructure role master in the naming
' context identified by strRoot.
'
' Arguments: strNCDN, the DN of the naming context to look in
'
' Returns: Object, either the ADSI object representing the infrastructure
' role master or NULL
'
' Remarks: Any error encountered will cause the method to throw an
' exception. This must be handled by the caller.
' This method does 3 binds. In a slow system this may take
' some time.
'
On Error Resume Next
Dim oContainer, oNTDS, lErr, strErr, strSource
Set oContainer = GetObject(strLDAPSearchComputer & "<WKGUID=2fbac1870ade11d297c400c04fd8d5cd," & strNCDN & ">")
If Err <> 0 Then
lErr = Err.number
strErr = "Failed to bind to '" & strLDAPSearchComputer & _
"<WKGUID=2fbac1870ade11d297c400c04fd8d5cd," & _
strNCDN & ">'." & GetErrorString(Err)
On Error Goto 0
Err.Raise lErr, "GetInfrastructureMasterUsingWellKnownGUID", strErr
End If
Set oNTDS = GetObject(strLDAPSearchComputer & oContainer.Get("fSMORoleOwner"))
If Err <> 0 Then
lErr = Err.number
strErr = "Failed to get the 'fSMORoleOwner' attribute from the object '" & _
strLDAPSearchComputer & "<WKGUID=2fbac1870ade11d297c400c04fd8d5cd," & _
strNCDN & ">'." & GetErrorString(Err)
On Error Goto 0
Err.Raise lErr, "GetInfrastructureMasterUsingWellKnownGUID", strErr
End If
Set GetInfrastructureMasterUsingWellKnownGUID = GetObject(oNTDS.Parent)
If Err <> 0 Then
lErr = Err.number
strErr = "Failed to get the object '" & oNTDS.Parent & "'." & GetErrorString(Err)
On Error Goto 0
Err.Raise lErr, "GetInfrastructureMasterUsingWellKnownGUID", strErr
End If
End Function
'******************************************************************************
Sub ValidateFirstReplication(strNamingContext, strFirstReplicationErrors)
'
' Purpose: To determine whether the specified naming context has completed
' it's initial replication. This is required before it can be used
' as a domain controller.
'
' Arguments: strNamingContext, the naming contexts DN
' [in, out] strFirstReplicationErrors, the string containing the
' errors identified by this method
'
' Returns: Nothing
'
' Remarks: The way to check to see if a naming context has succeeded following
' it's first replication is check if the attribute 'replUpToDateVector'
' exists. If it does exist then the naming context has completed it's
' first replication. We will generate an error from this function if
' the naming context's when created time is more than 24 hours prior
' to this method running and the first replication still has not
' occurred.
'
On Error Resume Next
Dim oNCRoot
Set oNCRoot = GetObject(strLDAPSearchComputer & strNamingContext)
If Err <> 0 Then
ScriptError "bind to '" & strLDAPSearchComputer & strNamingContext & "'" & _
GetErrorString(Err)
Else
Dim whenCreated
whenCreated = CDate(oNCRoot.Get("whenCreated"))
If Err <> 0 Then
ScriptError "get the 'whenCreated' attribute from the '" & strNamingContext & _
"' naming context." & GetErrorString(Err)
Else
Dim utcNow
utcNow = ToUTC(Now)
If 0 <> Err Then
ScriptError "convert to UTC time." & GetErrorString(Err)
Else
If DateDiff("h", whenCreated, utcNow) > 24 Then
Dim upToDateVector
upToDateVector = oNCRoot.Get("replUpToDateVector")
If Err <> 0 Then
If Err = &H8000500d Then
'
' Check to see if there is only one DC hosting this partition.
'
If CountDCsHostingPartition(strNamingContext) > 1 Then
strFirstReplicationErrors = strFirstReplicationErrors & "'" & _
strNamingContext & "' has not replicated since creation. " & _
"(whenCreated=" & whenCreated & ")" & vbCrLf & vbCrLf
End If
Else
' We could not get the vector. This may be because of a error, or because it doesn't
' exist. Report it and let the user decide.
strFirstReplicationErrors = strFirstReplicationErrors & _
strNamingContext & " : " & GetErrorString(Err)
End If
End If
End If
End If
End If
End If
End Sub
'******************************************************************************
Function GetData(strKey)
'
' Purpose: Retrieves data out of a varset. Uses the key to determine what
' data to retrieve.
'
' Arguments: strKey, the key of the data to retrieve
'
' Returns: String, the data to return or an empty string
'
On Error Resume Next
If IsNull(oReg) Then
Set oReg = CreateObject("WScript.Shell")
End If
Dim regData
regData = oReg.RegRead(REG_Key & "\" & strKey )
If IsNull(regData) or IsEmpty(regData) or regData = "" Then
GetData = ""
Else
GetData = regData
End If
Err.Clear
End Function
'******************************************************************************
Sub SetData(strKey, strData)
'
' Purpose: To store data in a varset. If the key exists then the data
' associated with that key is replaced, otherwise the key/data
' combination is added to the varset.
'
' Arguments: strKey, the key of the line to replace
' strData, the data to associate with the key
'
' Returns: Nothing
'
If IsNull(oReg) Then
Set oReg = CreateObject("WScript.Shell")
End If
Call oReg.RegWrite(REG_Key & "\" & strKey , strData )
Err.Clear
End Sub
'******************************************************************************
Function IsValidDC(strComputer)
'
' Purpose: To determine whether the specified computer is a domain controller.
'
' Arguments: strComputer, the name of the computer in question
'
' Returns: Nothing
'
On Error Resume Next
IsValidDC = False
' Perform a search for the computer name under the CN=Sites,CN=Configuration,DC=...
' container. If the computer is not found then return FALSE, otherwise return TRUE.
Dim oADOConn
Set oADOConn = CreateObject("ADODB.Connection")
If Err <> 0 Then
ScriptError "CreateObject 'ADODB.Connection'." & GetErrorString(Err)
On Error Goto 0
Err.Raise &H80004005
Else
oADOConn.Provider = "ADSDsOObject"
oADOConn.Open "ADs Provider"
If Err <> 0 Then
ScriptError "initialize ADODB.Connection." & GetErrorString(Err)
On Error Goto 0
Err.Raise &H80004005
Else
Dim rsMonitor, strQuery
strQuery = "<GC://CN=Sites," & strConfigRoot & ">;(&(cn=" & strComputer & ")(objectCategory=server));ADsPath;subtree"
Set rsMonitor = oADOConn.Execute(strQuery)
If 0 <> Err Then
ScriptError "execute query '" & strQuery & "'." & GetErrorString(Err)
On Error Goto 0
Err.Raise &H80004005
Else
If Not rsMonitor.EOF Then
' The computer exists in the directory, if it still has an NTDSDSA object
' as a child then it is still a domain controller.
Dim oComp
Set oComp = GetObject(rsMonitor.Fields("ADsPath"))
If 0 = Err Then
Dim oNTDSDSA
Set oNTDSDSA = oComp.GetObject("ntdsdsa", "CN=NTDS Settings")
If 0 = Err Then
IsValidDC = True
Else
Err.Clear
End If
Else
ScriptError "bind to the object '" & rsMonitor.Fields("ADsPath") & "'"
On Error Goto 0
Err.Raise &H80004005
End If
End If
End If
End If
End If
End Function
'******************************************************************************
Sub CleanUpMLMObject(strComputer, strNamingContext)
'
' Purpose: To delete the MOM Latency Monitor object owned by a given computer
' in a given naming context.
'
' Arguments: strComputer, the name of the computer to clean up for
' strNamingContext, the naming context to clean up
'
' Returns: Nothing
'
' Bind to the OpsMgrLatencyMonitors container and delete the specified computer
Dim oCont
Set oCont = GetObject(strLDAPSearchComputer & "CN=" & MONITORING_CONTAINER_NAME & "," & strNamingContext)
If 0 = Err Then
oCont.Delete "container", "CN=" & strComputer
If 0 <> Err Then
ScriptError "delete 'CN=" & strComputer & ",CN=" & MONITORING_CONTAINER_NAME & _
"," & strNamingContext & "'." & GetErrorString(Err)
Else
LogEvent EVENT_ID_CLEANED_UP_NAMING_CONTEXT, EVENT_TYPE_INFORMATION, "cleaned up " & _
"the naming context '" & strNamingContext & "' for the computer '" & _
strComputer & "'"
End If
Else
ScriptError "bind to 'CN=" & MONITORING_CONTAINER_NAME & "," & strNamingContext & _
"'." & GetErrorString(Err)
End If
End Sub
'******************************************************************************
Function CountDCsHostingPartition(strNamingContext)
'
' Purpose: To count the number of DCs hosting the given naming context
'
' Arguments: strNamingContext, the naming context to count DCs in
'
' Returns: The number of DCs (NTDSSettings objects) that are found.
'
On Error Resume Next
Dim oADOConn
Set oADOConn = CreateObject("ADODB.Connection")
If Err <> 0 Then
ScriptError "CreateObject 'ADODB.Connection'." & GetErrorString(Err)
Else
oADOConn.Provider = "ADSDsOObject"
oADOConn.Open "ADs Provider"
If Err <> 0 Then
ScriptError "initialize ADODB.Connection." & GetErrorString(Err)
Else
Dim rsDCs, strQuery
strQuery = "<" & strLDAPSearchComputer & strConfigRoot & ">;(&(objectCategory=nTDSDSA)(msDS-hasMasterNCs=" & strNamingContext & "));adspath;subTree"
Set rsDCs = oADOConn.Execute(strQuery)
If 0 <> Err Then
ScriptError "execute query '" & strQuery & "'." & GetErrorString(Err)
Else
rsDCs.MoveFirst
If 0 <> Err Then
ScriptError "execute query '" & strQuery & "'." & GetErrorString(Err)
Else
Do Until rsDCs.EOF
CountDCsHostingPartition = CountDCsHostingPartition + 1
rsDCs.MoveNext
Loop
End If
End If
End If
End If
End Function
Home
ENU 
Show References: