<DataSourceModuleType ID="AD_Client_Connectivity.DataSource" Accessibility="Internal">
<Configuration>
<xsd:element name="IntervalSeconds" type="xsd:int"/>
<xsd:element name="TargetComputerName" type="xsd:string"/>
<xsd:element name="LogSuccessEvent" type="xsd:boolean"/>
<xsd:element name="BindThreshold" type="xsd:string"/>
<xsd:element name="SearchThreshold" type="xsd:string"/>
<xsd:element name="FailureThreshold" type="xsd:string"/>
<xsd:element name="PingThreshold" type="xsd:string"/>
<xsd:element name="ManagementGroupName" type="xsd:string"/>
<xsd:element name="TimeoutSeconds" type="xsd:int"/>
<xsd:element name="VerboseLogging" type="xsd:boolean"/>
</Configuration>
<OverrideableParameters>
<OverrideableParameter ID="IntervalSeconds" ParameterType="int" Selector="$Config/IntervalSeconds$"/>
<OverrideableParameter ID="LogSuccessEvent" ParameterType="string" Selector="$Config/LogSuccessEvent$"/>
<OverrideableParameter ID="BindThreshold" ParameterType="string" Selector="$Config/BindThreshold$"/>
<OverrideableParameter ID="PingThreshold" ParameterType="string" Selector="$Config/PingThreshold$"/>
<OverrideableParameter ID="FailureThreshold" ParameterType="string" Selector="$Config/FailureThreshold$"/>
<OverrideableParameter ID="SearchThreshold" ParameterType="string" Selector="$Config/SearchThreshold$"/>
<OverrideableParameter ID="TimeoutSeconds" ParameterType="int" Selector="$Config/TimeoutSeconds$"/>
<OverrideableParameter ID="VerboseLogging" ParameterType="string" Selector="$Config/VerboseLogging$"/>
</OverrideableParameters>
<ModuleImplementation>
<Composite>
<MemberModules>
<DataSource ID="DS" TypeID="System!System.CommandExecuterPropertyBagSource">
<IntervalSeconds>$Config/IntervalSeconds$</IntervalSeconds>
<ApplicationName>%windir%\system32\cscript.exe</ApplicationName>
<WorkingDirectory/>
<CommandLine>//nologo $file/AD_Client_Connectivity.vbs$ $Config/TargetComputerName$ $Config/LogSuccessEvent$ $Config/BindThreshold$ $Config/SearchThreshold$ $Config/FailureThreshold$ $Config/PingThreshold$ $Config/ManagementGroupName$ $Config/VerboseLogging$</CommandLine>
<TimeoutSeconds>$Config/TimeoutSeconds$</TimeoutSeconds>
<RequireOutput>true</RequireOutput>
<Files>
<File>
<Name>AD_Client_Connectivity.vbs</Name>
<Contents><Script>
'*************************************************************************
' Script Name - AD Client Connectivity
'
' Purpose - Determines if the DCs being tested are in sync time-wise
'
' Assumptions - Script is run by a timed event
'
' Parameters - BindThreshold - The number of milliseconds a bind is allowed
' to take.
' - SearchThreshold - The number of milliseconds that a search
' is allowed to take.
' - FailureThreshold - The number of consecutive failures allowed
' before an alert is raised.
' - LogSuccessEvent - Logs an event when the script completes.
' - VerboseLogging - Turns on extra logging to help debug any
' issues with this script. Debug data is
' logged in 1004 events in the OPS MGR log.
'
' (c) Copyright 2002, Microsoft Corporation, All Rights Reserved
' Proprietary and confidential to Microsoft Corporation
'*************************************************************************
Dim oADOConn, oOOMADS, lErr, strErr, lFailLimit, bVerboseLogging
' Globals to hold client state for this execution of the script
Dim bPerformance, bAvailability, bFoundErrorState
bPerformance = True
bAvailability = True
' Accessed via many parts of the script
Dim owParams, IsTargetAgentless,TargetFQDNComputer, oReg, oAPI, bLogSuccess, oBag, strVerboseLogging
Set owParams = WScript.Arguments
if owParams.Count < 7 Then
Wscript.quit -1
End if
Dim strClientComputer
strClientComputer = TargetFQDNComputer
PerformGlobalSetup
If Err = 0 Then
' Run the tests
Dim astrDCs, strComputer, strDomain, strFQDN, bContinue, bFailed
astrDCs = LoadDCsFromFile()
If Err <> 0 Then
ScriptError "while loading the Domain Controllers from file."
Else
Dim iIndex
For iIndex = 0 To UBound(astrDCs)
Dim strLine
strLine = astrDCs(iIndex)
Err.Clear
if iIndex = 0 Then
If 0 = Len(strLine) Then ' in case the array of DCs is empty
strFQDN = oOOMADS.PDCMaster
strComputer = oOOMADS.GetFlatComputerName(strFQDN)
strDomain = oOOMADS.GetDomainForDC(strFQDN)
End if
Else
' Split the line into a DC and Domain components
SplitConfigLineIntoComponents strLine, strDomain, strComputer, strFQDN
End If
If Err = 0 Then
If 0 < Len(strComputer) And 0 < Len(strDomain) And 0 < Len(strFQDN) Then
bContinue = False
bFailed = False
PingTest strFQDN
If Err = 0 Then
bContinue = True
Else
bFailed = True
bAvailability = False
End If
HandleScriptReturn strComputer, strDomain, PING_TEST
If bContinue Then
NetUseTest strFQDN
If Err <> 0 Then
bFailed = True
bAvailability = False
End If
HandleScriptReturn strComputer, strDomain, NETUSE_TEST
' Clear any residual errors
Err.Clear
LDAPPingTest strFQDN, strComputer, strDomain
If Err = 0 Then
bContinue = True
Else
bFailed = True
bContinue = False
bAvailability = False
End If
HandleScriptReturn strComputer, strDomain, LDAP_PING_TEST
If bContinue Then
ADSIBindTest strFQDN, strComputer, strDomain
If Err = 0 Then
bContinue = True
Else
bFailed = True
bContinue = False
' We're not setting bAvailability to False here because
' it has to be set inside the ADSIBindTest in case it failed
' the performance test rather than the connectivity test
End If
HandleScriptReturn strComputer, strDomain, ADSIBIND_TEST
End If
End If
If Not(bFailed) Then
' We did not encounter any errors for this iteration of the tests
' clear the consecutive errors counter for this computer.
ResetConsecutiveErrorCounters strComputer, strDomain
' Note that we do not create the property bag with the state "GOOD" here because that will be
' created only if by the end of iterating through the Domain Controller's array we find no issues.
End If
End If
End If
Next
End If
Else
ScriptError "while performing global setup."
End If
If CBool(GetTestParameter(SCRIPT_NAME, LOG_SUCCESS, bLogSuccess)) Then
CreateEvent EVENT_ID_SUCCESS, EVENT_TYPE_INFORMATION, "The script '" & SCRIPT_NAME & _
"' has completed in " & DateDiff("s", dtStart, Now) & " seconds."
End If
Else
bFoundErrorState=true
CreateEvent EVENT_ID_AGENTLESS, EVENT_TYPE_ERROR, "The AD Management Pack does not support the agentless management mode." & vbCrLf & _
"The script '" & SCRIPT_NAME & "' will not execute." & vbCrLf & _
"To prevent this alert being generated again, either change the monitoring " & _
"mode of the computer '" & TargetFQDNComputer & "' to agent-managed " & _
"or disable the rule that generated this alert."
End If
if bFoundErrorState=false Then
set oBag = oAPI.CreateTypedPropertyBag(StateDataType)
oBag.AddValue "State", "GOOD"
oBag.AddValue "EventID", EVENT_ID_SUCCEEDED
oAPI.AddItem oBag
End If
oAPI.ReturnItems
End Sub
'******************************************************************************
Function GetTestParameter(strTest, strParameterName, strDefaultParamValue)
'
' Purpose: To retrieve a script parameter. The parameter is first retrieved
' from the ScriptContext, then if an entry exists in the .ini file
' that entry will be used instead.
'
' Parameters: strTest - The name of the test.
' strParameterName - The name of the parameter being retrieved.
'
' Returns: The value of the parameter (if it is found in either the ScriptContext,
' or the registry)
'
On Error Resume Next
GetTestParameter = strDefaultParamValue
Dim oReg
Set oReg = CreateObject("WScript.Shell")
If 0 <> Err Then
ScriptError "create the 'WScript.Shell' object."
Else
Dim strKey, strValue
strKey = REGISTRY_TESTS & "\" & strTest & "\" & strParameterName
strValue = oReg.RegRead(strKey)
If Err = 0 Then
If 0 < Len(strValue) Then
GetTestParameter = strValue
End If
Else
If Err = &H80040004 Or _
Err = &H80070002 Or _
Err = &H80070003 Then
' The registry key wasn't there, this is expected if the user does
' not wish to override the global parameter
Err.Clear
Else
ScriptError "reading the parameter '" & strParameterName & "' for the test '" & _
strTest & "' from the registry."
End If
End If
End If
End Function
'******************************************************************************
Sub GetTestParameters(strTest, dictParams)
'
' Purpose: To retrieve the parameters for the script.
'
' Parameters: strTest - the name of the test
' dictParams - a dictionary that holds the parameter names. The
' parameter values will be filled in by this method.
'
' Returns: Nothing
'
If Not IsObject(dictParams) Then
Err.Raise ERR_PARAM_NOT_FOUND, "GetScriptParameters", "dictParams must be an object."
End If
Dim aKeys, avalues
aKeys = dictParams.Keys
avalues = dictParams.Items
Dim iIndex
For iIndex = 0 to UBound(aKeys)
dictParams.Item(aKeys(iIndex)) = GetTestParameter(strTest, aKeys(iIndex), avalues(iIndex))
Next
End Sub
'******************************************************************************
Function LoadDCsFromFile()
'
' Purpose: To retrieve a list of DC names from a file
'
' Parameters: astrDCs - the array to put the DC names into
'
' Returns: Nothing
'
Dim oFSO, oTempFolder, oFile, astrDCs
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oTempFolder = oFSO.GetSpecialFolder(2) ' Temp Folder
On Error Resume Next
Set oFile = oFSO.OpenTextFile(oTempFolder.Path & "\MonitoredDCs.txt", 1, False, -1)
If Err = 0 Then
Do Until oFile.AtEndOfStream
On Error Goto 0
Dim strLine
strLine = oFile.ReadLine()
If IsArray(astrDCs) Then
Dim iSize
' LBound is always 0, so with one element, UBound is also 0. Increment it
' by one to make space for the new item.
iSize = UBound(astrDCs) + 1
Redim Preserve astrDCs(iSize)
astrDCs(iSize) = strLine
Else
' Create an array with the first item in it.
astrDCs = Array(strLine)
End If
Loop
Else
' If the error is 'file does not exist' then it just means that
' the script 'AD Client Update DCs' has not produced a list of
' DCs yet. Ignore this error.
If Err = &H35 Then
Err.Clear
astrDCs = Array("")
End If
End If
LoadDCsFromFile = astrDCs
End Function
'******************************************************************************
Function GetLocalSiteName()
'
' Purpose: To retrieve the site name for this computer.
'
' Returns: String, the site name (or an empty string if it cannot be determined)
'
Dim oADSysInfo
Set oADSysInfo = CreateObject("ADSystemInfo")
GetLocalSiteName = oADSysInfo.SiteName
End Function
'******************************************************************************
Sub LogEvent()
'
' Purpose: To log the current error as an event
'
' Parameters: None
'
' Returns: Nothing
'
lErr = Err.number
strErrorDescription = Err.Description
strErrorSource = Err.Source
On Error Resume Next
CreateEvent EVENT_ID_SCRIPT_FAILURE, EVENT_TYPE_INFORMATION, "An error occurred while executing " & _
strErrorSource & "." & vbCrLf & "The error was:" & vbCrLf & _
strErrorDescription & " (0x" & Hex(lError) & ")"
End Sub
'******************************************************************************
Sub LogError()
'
' Purpose: To log the current error as an error
'
' Parameters: None
'
' Returns: Nothing
'
lErr = Err.number
strErrorDescription = Err.Description
strErrorSource = Err.Source
On Error Resume Next
CreateEvent EVENT_ID_SCRIPT_FAILURE, EVENT_TYPE_ERROR, "An error occurred while executing " & _
strErrorSource & "." & vbCrLf & "The error was:" & vbCrLf & _
strErrorDescription & " (0x" & Hex(lError) & ")"
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
'
On Error Resume Next
oAPI.LogScriptEvent "AD Client Connectivity", lEventID, lEventType, strMessage
End Sub
'******************************************************************************
Sub ScriptError(strContext)
'
' Purpose: To generate an alert for the current error and then throw the
' exception so it can be caught at a higher level.
'
' Arguments: strContext - the current context, this is added to the message
' that is alerted to the user
'
' Returns: nothing
'
' Remarks: Always throws an error
'
Dim strError
strError = "The script '" & SCRIPT_NAME & "' failed while " & strContext & _
GetErrorString(Err)
CreateEvent EVENT_ID_SCRIPT_FAILURE, EVENT_TYPE_WARNING, strError
bFoundErrorState=true
End Sub
'******************************************************************************
Sub PingTest(strComputer)
'
' Purpose: To perform a ping test against the specified computer
'
' Arguments: strComputer - the computer to be tested.
'
' Returns: nothing
'
' Remarks: If an error occurs, it will be thrown, it must be caught by the
' caller
'
On Error Resume Next
' Use the OOMADS object to Ping the computer
'Dim strIPAddress
'strIPAddress = oOOMADS.GetIPAddress(strComputer)
'If Len(strIPAddress) > 0 Then
If Len(strComputer) > 0 Then
bDNSSuccess = True
Dim lngPingTime
lngPingTime = 0
lAttemptCount = 0
' If the ping or bind fails then retry it up to MAX_REPEAT_COUNT times.
' This is to accomodate any transient network conditions that may exist.
Do
lngPingTime = oOOMADS.Ping(strComputer)
If 0 > lngPingTime Then
' Wait a bit before trying again.
oOOMADS.Sleep 500
End If
lAttemptCount = lAttemptCount + 1
Loop While (0 > lngPingTime) And (lAttemptCount < MAX_REPEAT_COUNT)
If 0 > lngPingTime Then
' The ping failed, generate an alert
lErr = Err.number
strErr = Err.Description
On Error Goto 0
Err.Raise ERR_PING_FAILED, "Ping Test", "Failed to ping the domain controller '" & _
strComputer & "." & strErr & " (0x" & Hex(lErr) & ")"
End If
Else
lErr = Err.number
strErr = Err.Description
Dim strMessage
strMessage = "Getting the IP Address of the " & _
"domain controller '" & strComputer & "' failed." & vbCrLf & _
strErr & " (0x" & Hex(lErr) & ")" & vbCrLf
' Get the DNS servers configured for this machine
Dim strDNSServers
strDNSServers = GetDNSServerList()
If Len(strDNSServers) > 0 Then
strMessage = strMessage & "The DNS servers configured for this machine are:" & _
vbCrLf & strDNSServers
End If
On Error Goto 0
Err.Raise ERR_PING_FAILED, "Ping Test", strMessage
End If
If bVerboseLogging Then
strVerboseLogging = vbCrLf & _
"The Ping test for " & SCRIPT_NAME & " has been invoked with the following arguments:" & vbCrLf & _
"StateValuePath = " & sStateValuePath & vbCrLf & _
"Computer = " & strComputer & vbCrLf & _
"FailLimit = " & lFailLimit & vbCrLf & _
"AttemptCount = " & lAttemptCount & vbCrLf & _
"MaxRepeatCount = " & MAX_REPEAT_COUNT & vbCrLf & _
"PingTime = " & lngPingTime & vbCrLf & _
"VerboseLogging = " & bVerboseLogging & vbCrLf
End If
End Sub
'******************************************************************************
Sub PerformGlobalSetup()
'
' Purpose: To perform global setup for the
'
' Arguments: none
'
' Returns: nothing
'
' Remarks: Sets up the global variables and objects. If an error is thrown
' by this method, the other tests cannot run.
' NOTE: No error handling, any errors must be caught by caller
'
' Make sure there is no error handling
On Error Goto 0
' Create an instance of the COM object
Set oOOMADS = CreateObject("McActiveDir.ActiveDirectory")
If (0 <> Err.Number) Or (Not(IsObject(oOOMADS))) Then
Dim errorString
errorString = "The script '" & SCRIPT_NAME & "' failed to create object " & _
"'McActiveDir.ActiveDirectory'. This is an unexpected error." & vbCrLf & vbCrLf & _
GetErrorString(Err) & vbCrLf & vbCrLf & _
"The Active Directory Management Pack Objects (OOMADs) components are not installed on the Domain Controller. These components are required for the monitoring scripts to run successfully. See Alert Knowledge for additional details."
' Create an instance of the ADO object
Set oADOConn = CreateObject("ADODB.Connection")
oADOConn.Provider = "ADSDsOObject"
oADOConn.Open "ADs Provider"
' Get the global script parameters
lFailLimit = CLng(GetTestParameter(SCRIPT_NAME, FAIL_LIMIT, owParams(4)))
If lFailLimit < 1 Then
InvalidParameter FAIL_LIMIT, GTE, 3, "", 1, 0
lFailLimit = 3
End If
End Sub
'******************************************************************************
Sub NetUseTest(strComputer)
'
' Purpose: To perform a net use test against the specified computer
'
' Arguments: strComputer - the computer to be tested.
'
' Returns: nothing
'
' Remarks: If an error occurs, it will be thrown, it must be caught by the
' caller
'
On Error Resume Next
Dim oNetwork
Set oNetwork = CreateObject("WScript.Network")
If 0 <> Err.Number Then
On Error Goto 0
lErr = Err.number
strErr = Err.Description
On Error Goto 0
Err.Raise ERR_NETUSE_FAILED, "NetUseTest", _
"failed to create the object 'WScript.Network'." & vbCrLf & _
strErr & vbCrLf & "(0x" & Hex(lErr) & ")"
Else
' Connect to the Sysvol share on the DC
oNetwork.MapNetworkDrive "", "\\" & strComputer & "\SYSVOL"
If 0 <> Err.Number Then
lErr = Err.number
strErr = Err.Description
On Error Goto 0
Err.Raise ERR_NETUSE_FAILED, "NetUseTest", _
"'net use \\" & strComputer & "\SYSVOL' failed." & vbCrLf & _
strErr & vbCrLf & "(0x" & Hex(lErr) & ")"
Else
' Delete the share that was created
oNetwork.RemoveNetworkDrive "\\" & strComputer & "\SYSVOL"
End If
Set oNetwork = Nothing
End If
If bVerboseLogging Then
strVerboseLogging = vbCrLf & _
"The NET USE test for " & SCRIPT_NAME & " has been invoked with the following arguments:" & vbCrLf & _
"StateValuePath = " & sStateValuePath & vbCrLf & _
"Computer = " & strComputer & vbCrLf & _
"FailLimit = " & lFailLimit & vbCrLf & _
"VerboseLogging= " & bVerboseLogging & vbCrLf
End If
' Sometimes the RemoveNetworkDrive call fails, ignore it and continue
Err.Clear
End Sub
'******************************************************************************
Sub LDAPPingTest(strFQMN, strComputer, strDomain)
'
' Purpose: To perform an LDAP Ping against the specified computer
'
' Arguments: strFQDN - the FQMN of the machine to be tested
' strComputer - the computer to be tested.
' strDomain - the domain of the computer being tested
'
' Returns: nothing
'
' Load the parameters
Dim oParams
Set oParams = CreateObject("Scripting.Dictionary")
' Add the parameters to the dictionary
oParams.Add LDAP_PING_TIMEOUT, owParams(5)
' Get the parameter values
GetTestParameters SCRIPT_NAME, oParams
If 0 <> Err.number Then
ScriptError Err
Else
' Read the parameters from the dictionary
Dim lTimeout
lTimeout = CDbl(oParams.Item(LDAP_PING_TIMEOUT))
' Validate the parameters
If lTimeout > 60 Then
InvalidParameter LDAP_PING_TIMEOUT, LTE, 10, "seconds", 60, 0
lTimeout = 10
End If
' Make sure we don't have any residual errors lingering around
Err.Clear
' Do the test using the global oomads object
Dim lPingTime
On Error Resume Next
lPingTime = oOOMADS.LDAPPing(strFQMN, lTimeout)
If Err <> 0 Then
lErr = Err.number
strErr = Err.Description
On Error Goto 0
Err.Raise ERR_LDAP_PING_FAILED, "LDAPPingTest", "The LDAP Ping to '" & strComputer & "' failed." & _
vbCrLf & strErr & " (0x" & Hex(lErr) & ")"
Else
' Ping succeeded, record the perf data (in seconds rather than milliseconds)
Set oBag= oAPI.CreateTypedPropertyBag(PerformanceDataType)
oBag.AddValue "StatusCounter", "AD Client LDAP Ping Time"
oBag.AddValue "StatusInstance", strFQMN
oBag.AddValue "StatusValue", "" & (lPingTime / 1000)
oAPI.addItem oBag
End If
End If
If bVerboseLogging Then
strVerboseLogging = vbCrLf & _
"The LDAP Ping test for " & SCRIPT_NAME & " has been invoked with the following arguments:" & vbCrLf & _
"StateValuePath = " & sStateValuePath & vbCrLf & _
"FQMN = " & strFQMN & vbCrLf & _
"Computer = " & strComputer & vbCrLf & _
"Domain = " & strDomain & vbCrLf & _
"FailLimit = " & lFailLimit & vbCrLf & _
"Timeout = " & lTimeout & vbCrLf & _
"VerboseLogging = " & bVerboseLogging & vbCrLf
End If
End Sub
'******************************************************************************
Sub ADSIBindTest(strFQMN, strComputer, strDomain)
'
' Purpose: To perform a bind test against the specified computer
'
' Arguments: strFQMN - the FQMN of the machine to be tested
' strComputer - the computer to be tested.
' strDomain - the domain of the computer being tested
'
' Returns: nothing
'
On Error Resume Next
' Load the parameters
Dim oParams
Set oParams = CreateObject("Scripting.Dictionary")
' Add the parameters to the dictionary
oParams.Add BIND_THRESHOLD, owParams(2)
oParams.Add SEARCH_THRESHOLD, owParams(3)
' Get the parameter values
GetTestParameters SCRIPT_NAME, oParams
If 0 <> Err.number Then
ScriptError "getting the ADSI Bind test parameters."
Else
' Read the parameters from the dictionary
Dim lBindThreshold, lSearchThreshold
lBindThreshold = CDbl(oParams.Item(BIND_THRESHOLD))
lSearchThreshold = CDbl(oParams.Item(SEARCH_THRESHOLD))
' Validate the parameters
If lBindThreshold > 60000 Then
InvalidParameter BIND_THRESHOLD, LTE, 1000, "milliseconds", 60000, 0
lBindThreshold = 1000
End If
If lSearchThreshold > 60000 Then
InvalidParameter SEARCH_THRESHOLD, LTE, 2000, "milliseconds", 60000, 0
lSearchThreshold = 2000
End If
If bVerboseLogging Then
strVerboseLogging = vbCrLf & _
"The ADSI Bind test for " & SCRIPT_NAME & " has been invoked with the following arguments:" & vbCrLf & _
"StateValuePath = " & sStateValuePath & vbCrLf & _
"FQMN = " & strFQMN & vbCrLf & _
"Computer = " & strComputer & vbCrLf & _
"Domain = " & strDomain & vbCrLf & _
"FailLimit = " & lFailLimit & vbCrLf & _
"BindThreshold = " & lBindThreshold & vbCrLf & _
"SearchThreshold = " & lSearchThreshold & vbCrLf & _
"VerboseLogging = " & bVerboseLogging & vbCrLf
End If
Dim oRootDSE
Dim dtStart, dtEnd, lDiff
Set oRootDSE = oOOMADs.BindObject("LDAP://" & strFQMN & "/RootDSE")
lDiff = oOOMADs.BindLast
If Err <> 0 Then
ScriptError "getting 'LDAP://" & strFQMN & "/RootDSE."
bAvailability = False
Else
' Bind succeeded, record perf data
Set oBag= oAPI.CreateTypedPropertyBag(PerformanceDataType)
oBag.AddValue "StatusCounter", "AD Client LDAP Bind Time"
oBag.AddValue "StatusInstance", strFQMN
oBag.AddValue "StatusValue", "" & (lDiff / 1000)
oAPI.addItem oBag
If lDiff > lBindThreshold Then
bPerformance = False
' The bind threshold was exceeded, generate an event
On Error Goto 0
' The search threshold was exceeded, raise an error
Err.Raise ERR_SEARCH_TIMEOUT, "ADSIBindTest", "The bind to 'LDAP://" & _
strFQMN & "/RootDSE' took " & lDiff & " milliseconds, " & _
"which is longer than the allowed " & lBindThreshold & _
" milliseconds."
End If
' We have the RootDSE, now try searching for an object
Dim strDomainNamingContext
strDomainNamingContext = oRootDSE.Get("defaultNamingContext")
Dim strSearch
strSearch = "<LDAP://" & strFQMN & "/" & strDomainNamingContext & _
">;(cn=" & strComputer & ");cn;subtree"
dtStart = Now
Dim rsResults
Set rsResults = oADOConn.Execute(strSearch)
dtEnd = Now
lDiff = DateDiff("s", dtStart, dtEnd)
If 0 <> Err Then
lErr = Err.number
strErr = Err.Description
bAvailability = False
On Error Goto 0
Err.Raise ERR_SEARCH_FAILED, "ADSIBindTest", "The search '" & strSearch & "' failed." & _
vbCrLf & strErr & " (0x" & Hex(lErr) & ")"
Else
' Enumerate the results
While Not rsResults.EOF
rsResults.MoveNext
Wend
If 0 <> Err Then
lErr = Err.number
strErr = Err.Description
bAvailability = False
On Error Goto 0
Err.Raise ERR_SEARCH_FAILED, "ADSIBindTest", "Enumerating the results from the " & _
"search '" & strSearch & "' failed." & vbCrLf & strErr & _
" (0x" & Hex(lErr) & ")"
Else
' Search succeeded, record perf data
Set oBag= oAPI.CreateTypedPropertyBag(PerformanceDataType)
oBag.AddValue "StatusCounter", "ADSI Client Search Time"
oBag.AddValue "StatusInstance",""
oBag.AddValue "StatusValue", "" & lDiff
oAPI.addItem oBag
If lDiff > lSearchThreshold Then
bPerformance = False
On Error Goto 0
' The search threshold was exceeded, raise an error
Err.Raise ERR_SEARCH_TIMEOUT, "ADSIBindTest", "The search '" & strSearch & _
"' took " & lDiff & " milliseconds, which is longer than the " & _
"allowed " & lSearchThreshold & " milliseconds."
End If
End If
End If
End If
End If
End Sub
'******************************************************************************
Sub InvalidParameter(strParameter, lParamType, lDefault, strUnits, l1st, l2nd)
'
' Purpose: To log an event indicating what was wrong with the parameter
'
' Arguments: strParamter - the parameter name
' lParamType - the type of the error, whether it should have been
' less than a number, greater or within a band
' lDefault - the default value that the parameter will be set to
' strUnits - the units for the parameter (currently unused)
' l1st - the first boundary (used for all parameter types)
' l2nd - the second boundary (only used for bands)
'
' Returns: nothing
'
On Error Resume Next
Dim strMessage
strMessage = "The script '" & SCRIPT_NAME & "' has detected an invalid parameter." & _
vbCrLf & "The parameter '" & strParameter & "'"
Select Case lParamType
Case LTE
strMessage = strMessage & " must be less than " & l1st & "."
Case GTE
strMessage = strMessage & " must be greater than " & l1st & "."
Case BAND
strMessage = strMessage & " must be between " & l1st & " and " & l2nd & "."
End Select
strMessage = strMessage & vbCrLf & vbCrLf & "'" & strParameter & "' will be set to " & _
lDefault & " for this execution of the script."
CreateEvent EVENT_ID_INVALID_PARAMETER, EVENT_TYPE_WARNING, strMessage
End Sub
'******************************************************************************
Sub HandleScriptReturn(strComputer, strDomain, lTestID)
'
' Purpose: If Err <> 0 Then the test failed, generate an event indicating that
' the test failed. If three consecutive failures have occurred then
' generate an alert indicating this fact. If the test succeeded then
' clear the consecutive error count, if we are in an error state,
' generate a success event.
'
' Arguments: strComputer - the computer being tested.
' strDomain - the domain of the computer being tested
' lTestID - the identifier of the test.
'
' Returns: nothing
'
Dim lError, strError, strSource
lError = Err.number
strError = Err.Description
strSource = Err.Source
On Error Resume Next
Dim lConsecutiveErrors, tmp
tmp = GetData(strComputer & "ErrCnt")
if tmp = "" Then
lConsecutiveErrors = 0
else
lConsecutiveErrors = CLng(tmp)
end if
If lError <> 0 Then
lConsecutiveErrors = lConsecutiveErrors + 1
If lConsecutiveErrors <= lFailLimit Then
SetData strComputer & "ErrDesc", CStr(GetData(strComputer & "ErrDesc")) & vbCrLf & _
Now() & " : " & strError & " (0x" & Hex(lError) & ")"
End If
If lConsecutiveErrors = lFailLimit Then
' Generate an event detailing the errors that occurred,
' and send 'BAD' property bag only after the number of
' failures equals the failure threshold.
Dim strMessage
strMessage = "While '" & SCRIPT_NAME & "' was running, " & lFailLimit & _
" consecutive errors were encountered." & vbCrLf & _
"A message will be generated when the test succeeds. " & _
"Look for a success alert from '" & SCRIPT_NAME & _
"' with ID = " & EVENT_ID_TEST_SUCCEEDED & "." & vbCrLf & vbCrLf & _
"To see the errors look for events from '" & SCRIPT_NAME & _
"' with event ID " & EVENT_ID_TEST_FAILED & ". The public " & _
"view 'Client Side Events' shows these events." & _
vbCrLf & vbCrLf & "The last " & lFailLimit & " errors were:"
strMessage = strMessage & GetData(strComputer & "ErrDesc")
set oBag = oAPI.CreateTypedPropertyBag(StateDataType)
oBag.AddValue "State", "BAD"
oBag.AddValue "EventID", EVENT_ID_TEST_FAILED
oBag.AddValue "ErrorString", strError
oAPI.AddItem oBag
bFoundErrorState = true
End If
CreateRemoteEvent strComputer, strDomain, EVENT_ID_TEST_FAILED, EVENT_TYPE_WARNING, strError
' Increment the counters
SetData strComputer & "ErrCnt", lConsecutiveErrors
' Set the SuccessCount to 0 so that we'll execute the test again
' the next time the script runs
SetData strComputer & "SuccessCount", 0
End If
If bVerboseLogging Then
strVerboseLogging = strVerboseLogging & _
"ConsecutiveErrors = " & lConsecutiveErrors & vbCrLf
If lError <> 0 Then
strVerboseLogging = strVerboseLogging & _
"Error number = " & lError & vbCrLf & _
"Error Description = " & strError & vbCrLf & _
"Error Source = " & strSource & vbCrLf
End If
CreateRemoteEvent strComputer, strDomain, EVENT_ID_VERBOSE_LOGGING, EVENT_TYPE_INFORMATION, strVerboseLogging
End If
End Sub
'******************************************************************************
Sub ResetConsecutiveErrorCounters(strComputer, strDomain)
'
' Purpose: Reset the consecutive error counters for a computer
'
' Arguments: strComputer, the computer to to reset the counters for
'
Dim lConsecutiveErrors, tmp
tmp = GetData(strComputer & "ErrCnt")
if tmp = "" Then
lConsecutiveErrors = 0
else
lConsecutiveErrors = CLng(tmp)
end if
If lConsecutiveErrors >= lFailLimit Then
' We have succeeded after a number of consecutive failures. Create a
' success event.
CreateRemoteEvent strComputer, strDomain, EVENT_ID_TEST_SUCCEEDED, EVENT_TYPE_INFORMATION, "The script '" & SCRIPT_NAME & "' has succeeded following " & _
lConsecutiveErrors & " consecutive failures." & vbCrLf
End If
SetData strComputer & "ErrCnt", 0
SetData strComputer & "ErrDesc", ""
End Sub
'******************************************************************************
Sub CreateRemoteEvent(strComputer, strDomain, lEventID, lEventType, strMessage)
oAPI.LogScriptEvent "AD Client Connectivity", lEventID, lEventType, strMessage 'we dont have the api to log on remote machine
End Sub
'******************************************************************************
Function GetData(strKey)
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)
If IsNull(oReg) Then
Set oReg = CreateObject("WScript.Shell")
End If
Call oReg.RegWrite(REG_Key & "\" & strKey , strData )
Err.Clear
End Sub
'******************************************************************************
' Name: GetErrorString
'
' 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.)
'
Function GetErrorString(oErr)
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
Else
Select Case lErr
Case &H80041003
strErr = "WMI Provider Returned : Access Denied"
End Select
End If
End If
GetErrorString = "The error returned was: '" & strErr & "' (0x" & Hex(lErr) & ")"
End Function
'******************************************************************************
Function GetDNSServerList()
'
' Purpose: Generates a list of the DNS servers configured for the local
' computer
'
' Parameters: none
'
' Returns: String - the list of DNS servers
'
On Error Resume Next
' Work out what the configured DNS servers are:
Dim oWMI
Set oWMI = GetObject("winmgmts:").ExecQuery("SELECT * FROM Win32_NetworkAdapterConfiguration")
If 0 <> Err Then
GetDNSServerList = "An error occurred while querying for the DNS servers configured " & _
"for this machine." & GetErrorString(Err)
Else
If IsEmpty(oWMI) Then
GetDNSServerList = "There are no DNS servers configured for this machine."
Else
Dim strDNSServers
' Add the configured DNS Servers to the message
Dim oX, strDNS
If IsObject(oWMI) Then
For Each oX in oWMI
If Not(IsNull(oX)) Then
If Not(IsNull(oX.DNSServerSearchOrder)) Then
For Each strDNS in oX.DNSServerSearchOrder
If Len(strDNS) > 0 Then
strDNSServers = strDNSServers & strDNS & vbCrLf
End If
Next
End If
End If
Next
End If
GetDNSServerList = strDNSServers
End If
End If
End Function
'******************************************************************************
Sub SplitConfigLineIntoComponents(strLine, strDomain, strComputer, strFQDN)
'
' Purpose: Splits a line read from the configuration file into it's
' components.
'
' Parameters: strLine - The line to split
' strDomain - The domain part
' strComputer - The short computer name
' strFQDN - The computers FQDN (will hold the short name if
' there is no FQDN in the file)
'
' Returns: nothing
'
Dim iSplit
' Find the first delimiter
iSplit = Instr(strLine, "\")
' We must have a domain because the machine is a DC. If there is no domain then the
' AD Update DCs script failed.
If 0 <> iSplit Then
strDomain = Left(strLine, iSplit - 1)
strLine = Mid(strLine, iSplit + 1)
' Now look for a second delimiter. If there isn't one, use the remainder of
' the line as both the FQDN and the short name.
iSplit = Instr(strLine, "\")
If 0 <> iSplit Then
strComputer = Left(strLine, iSplit - 1)
strFQDN = Mid(strLine, iSplit + 1)
Else
strComputer = strLine
strFQDN = strComputer
End If
Else
Err.Raise EVENT_ID_INVALID_PARAMETER, SCRIPT_NAME, "The line read from the configuration file is invalid." & vbCrLf & _
"It should be of the form 'Domain/ComputerName/ComputerFQDN'." & vbCrLf & _
"The line in error is:" & vbCrLf & strLine
End If
End Sub
Home
PTB 
Show References: