Function GetSubMatches(ByVal aRegexes, ByVal sText, ByRef sRemainingText, ByRef aCapturedSubMatches)
Dim oRegex
Set oRegex = New RegExp
oRegex.Global = False
Dim oMatches
Dim oMatch
Dim sPattern
Dim aSubMatches()
aCapturedSubMatches = aSubMatches
GetSubMatches = False
Dim i
Dim lSubMatchCount
lSubMatchCount = 0
sRemainingText = sText
For i = 0 To UBound(aRegexes)
sPattern = aRegexes(i)
oRegex.Pattern = "^" & sPattern
Set oMatches = oRegex.Execute(sRemainingText)
If oMatches.Count <> 1 Then
sRemainingText = sText
Exit Function
End If
Set oMatch = oMatches(0)
sRemainingText = Mid(sRemainingText, oMatch.Length + 1)
If i Mod 2 = 1 Then
lSubMatchCount = lSubMatchCount + 1
ReDim Preserve aSubMatches(lSubMatchCount - 1)
aSubMatches(lSubMatchCount - 1) = oMatch.Value
End If
Next
GetSubMatches = True
aCapturedSubMatches = aSubMatches
End Function
Function GenerateGUID()
Dim oTypeLib
Set oTypeLib = MomCreateObject("Scriptlet.TypeLib")
Dim sNewGUID
sNewGUID = oTypeLib.Guid
GenerateGUID = Left(sNewGUID, Len(sNewGUID)-2)
End Function
Function IsValidObject(ByVal oObject)
IsValidObject = False
If IsObject(oObject) Then
If Not oObject Is Nothing Then
IsValidObject = True
End If
End If
End Function
Sub RunCommand (ByVal sCommand, ByRef iErrCode, ByRef sOutput, ByRef sError)
Dim oShell, oFSO, oOut
Set oShell = MomCreateObject("WScript.Shell")
Set oFSO = MomCreateObject("Scripting.FileSystemObject")
sError = ""
sOutput = ""
Dim sOutputFileName
sOutputFileName = GenerateGUID() & ".out"
Dim sErrorFileName
sErrorFileName = GenerateGUID() & ".err"
Dim sFullCommand
sFullCommand = "cmd /c " & sCommand & " > " & sOutputFileName & " 2> " & sErrorFileName
iErrCode = oShell.run(sFullCommand, 2, true)
On Error Resume Next
Set oOut = oFSO.OpenTextFile(sOutputFileName)
On Error Goto 0
If IsValidObject(oOut) Then
On Error Resume Next
sOutput = oOut.ReadAll()
On Error Goto 0
oOut.Close
Else
ThrowScriptError "Could not write to the folder [" & oFSO.GetAbsolutePathName(".") & "]. Make sure the action account has " & _
"write access to this folder.", _
Err
End If
On Error Resume Next
oFSO.DeleteFile sOutputFileName
On Error Goto 0
If iErrCode <> 0 Then
Dim oErrorFile
On Error Resume Next
Set oErrorFile = oFSO.OpenTextFile(sErrorFileName)
On Error Goto 0
If IsValidObject(oErrorFile) Then
On Error Resume Next
sError = oErrorFile.ReadAll()
On Error Goto 0
oErrorFile.Close
End If
If sError = "" Then sError = sOutput
End If
On Error Resume Next
oFSO.DeleteFile sErrorFileName
On Error Goto 0
End Sub
Class Error
Private m_lNumber
Private m_sSource
Private m_sDescription
Private m_sHelpContext
Private m_sHelpFile
Public Sub Save()
m_lNumber = Err.number
m_sSource = Err.Source
m_sDescription = Err.Description
m_sHelpContext = Err.HelpContext
m_sHelpFile = Err.helpfile
End Sub
Public Sub Raise()
Err.Raise m_lNumber, m_sSource, m_sDescription, m_sHelpFile, m_sHelpContext
End Sub
Public Sub Clear()
m_lNumber = 0
m_sSource = ""
m_sDescription = ""
m_sHelpContext = ""
m_sHelpFile = ""
End Sub
Public Default Property Get Number()
Number = m_lNumber
End Property
Public Property Get Source()
Source = m_sSource
End Property
Public Property Get Description()
Description = m_sDescription
End Property
Public Property Get HelpContext()
HelpContext = m_sHelpContext
End Property
Public Property Get HelpFile()
HelpFile = m_sHelpFile
End Property
End Class
Function MomCreateObject(ByVal sProgramId)
Dim oError
Set oError = New Error
On Error Resume Next
Set MomCreateObject = CreateObject(sProgramId)
oError.Save
On Error Goto 0
If oError.Number <> 0 Then ThrowScriptError "Unable to create automation object '" & sProgramId & "'", oError
End Function
Function ThrowScriptErrorNoAbort(ByVal sMessage, ByVal oErr)
'
' ThrowScriptError :: Creates an event and sends it back to the mom server
'
'
Dim sErrDescription, sErrNumber
sErrDescription = oErr.Description
sErrNumber = oErr.Number
On Error Resume Next
Dim oScriptErrorEvent
Set oScriptErrorEvent = ScriptContext.CreateEvent()
With oScriptErrorEvent
.EventNumber = 40000
.EventType = EVENT_TYPE_ERROR
.Message = sMessage
.SetEventParameter """Microsoft Windows DHCP Server"""
.SetEventParameter sMessage
.SetEventParameter sErrDescription
.SetEventParameter sErrNumber
End With
ScriptContext.Submit oScriptErrorEvent
ScriptContext.Echo "ThrowScriptError('" & sMessage & "')"
End Function
Function ThrowScriptError(Byval sMessage, ByVal oErr)
'
' ThrowScriptError :: Creates an event and sends it back to the mom server
'
'
On Error Resume Next
ThrowScriptErrorNoAbort sMessage, oErr
ScriptContext.Quit()
End Function
Sub FailedToParseOutput(ByVal sCommand, ByVal sOutput)
ThrowScriptError "Could not parse the output of [" & sCommand & "]" & vbCrLf & "Output: " & sOutput, Err
End Sub
Sub ErrorRunningCommand(ByVal sCommand, ByVal sError)
ThrowScriptError "There was an error running [" & sCommand & "]" & vbCrLf & "Error: " & sError, Err
End Sub
Dim DHCP2000_MIB_COUNT_REGEX
DHCP2000_MIB_COUNT_REGEX = Array( _
"\r\n" & _
".*\r\n" & _
"\t.*\r\n" & _
"\t.*\r\n" & _
"\t.*\r\n" & _
"\t.*\r\n" & _
"\t.*\r\n" & _
"\t.*\r\n" & _
"\t.*\r\n" & _
"\t.*\r\n" & _
"\t.*\r\n" _
)
Dim DHCP2000_SCOPE_INFO_HEADER_REGEX
DHCP2000_SCOPE_INFO_HEADER_REGEX = Array( _
"\r\n" & _
"==============================================================================\r\n" & _
".*\r\n" & _
"==============================================================================\r\n" & _
"\r\n" _
)
Dim DHCP2000_ZERO_SCOPE_INFO_FOOTER_REGEX
DHCP2000_ZERO_SCOPE_INFO_FOOTER_REGEX = Array( _
"\r\n" & _
".* = 0 \r\n" & _
".*\.\r\n" _
)
Class DHCP2000
Private m_sNetshPath
Private m_bInitialized
Private m_oScopes
Private Sub Class_Initialize()
m_bInitialized = False
End Sub
Public Property Let NetshPath(ByVal sPath)
Dim oShell
Set oShell = MomCreateObject("WScript.Shell")
m_sNetshPath = oShell.ExpandEnvironmentStrings(sPath)
End Property
Private Sub CollectData()
Dim iErrCode
Dim sOutput
Dim sError
Dim sCommand
Dim aSubMatches
sCommand = """""" & m_sNetshPath & """ dhcp server show all"""
RunCommand sCommand, iErrCode, sOutput, sError
If iErrCode = 0 Then
Set m_oScopes = MomCreateObject("Scripting.Dictionary")
If Not GetSubMatches(DHCP2000_MIB_COUNT_REGEX, sOutput, sOutput, aSubMatches) Then
FailedToParseOutput sCommand, sOutput
End If
Dim oScope
Do While GetSubMatches(DHCP2000_SCOPE_COUNTERS_REGEX, sOutput, sOutput, aSubMatches)
Set oScope = New DHCPScope2000
oScope.Initialize aSubMatches
Set m_oScopes.Item(oScope.Subnet) = oScope
Loop
Else
ErrorRunningCommand sCommand, sError
End If
sCommand = """""" & m_sNetshPath & """ dhcp server show scope"""
RunCommand sCommand, iErrCode, sOutput, sError
If iErrCode = 0 Then
If GetSubMatches(DHCP2000_SCOPE_INFO_HEADER_REGEX, sOutput, sOutput, aSubMatches) Then
Do While GetSubMatches(DHCP2000_SCOPE_INFO_REGEX, sOutput, sOutput, aSubMatches)
Set oScope = m_oScopes.Item(aSubMatches(0))
oScope.Name = Trim(aSubMatches(1))
Loop
ElseIf Not GetSubMatches(DHCP2000_ZERO_SCOPE_INFO_FOOTER_REGEX, sOutput, sOutput, aSubMatches) Then
FailedToParseOutput sCommand, sOutput
End If
Else
ErrorRunningCommand sCommand, sError
End If
m_bInitialized = True
End Sub
Public Property Get Scopes
If Not m_bInitialized Then CollectData
Scopes = m_oScopes.Items()
End Property
End Class
Public Sub Initialize(ByVal aSubMatches)
m_sSubnet = aSubMatches(0)
m_lAddressesInUse = CLng(aSubMatches(1))
m_lFreeAddresses = CLng(aSubMatches(2))
m_lPendingOffers = CLng(aSubMatches(3))
m_lTotalAddresses = m_lAddressesInUse + m_lFreeAddresses + m_lPendingOffers
m_lPercentFree = 0
If m_lTotalAddresses <> 0 Then m_lPercentFree = CLng(Round(100 * m_lFreeAddresses / m_lTotalAddresses, 0))
End Sub
Public Property Get Subnet
Subnet = m_sSubnet
End Property
Public Property Get AddressesInUse
AddressesInUse = m_lAddressesInUse
End Property
Public Property Get FreeAddresses
FreeAddresses = m_lFreeAddresses
End Property
Public Property Get PendingOffers
PendingOffers = m_lPendingOffers
End Property
Public Property Get TotalAddresses
TotalAddresses = m_lTotalAddresses
End Property
Public Property Get PercentFree
PercentFree = m_lPercentFree
End Property
Public Property Get DisplayName
DisplayName = "[" & m_sSubnet & "]"
If m_sName <> "" Then
DisplayName = DisplayName & " " & m_sName
End If
End Property
Public Property Let Name(ByVal sName)
m_sName = sName
End Property
Public Property Get IsMemberOfSuperscope
IsMemberOfSuperscope = False
End Property
Public Property Get PerfCounterInstanceName
PerfCounterInstanceName = Left(DisplayName, 255)
End Property
End Class
Sub SubmitPerfData(ByVal sObjectName, ByVal sCounterName, ByVal sInstanceName, ByVal dValue)
Dim oPerfData
Set oPerfData = ScriptContext.CreatePerfData()
With oPerfData
.ObjectName = sObjectName
.CounterName = sCounterName
.InstanceName = sInstanceName
.Value = dValue
End With
ScriptContext.Submit oPerfData
End Sub
Function FormatDHCP2000ScopeEventMessage(ByVal sName, ByVal lFreeAddresses, ByVal lAddressesInUse, ByVal lPercentFree)
Dim MESSAGE
MESSAGE = _
"The DHCP Scope named ""%1"" has the following address status:" & vbCrLf & _
"" & vbCrLf & _
"Free Addresses: %2" & vbCrLf & _
"Addresses In Use: %3" & vbCrLf & _
"Percent Addresses Free: %4"
Dim sResult
sResult = Replace(MESSAGE, "%1", sName)
sResult = Replace(sResult, "%2", FormatNumber(lFreeAddresses, 0, vbTrue, vbFalse, vbTrue))
sResult = Replace(sResult, "%3", FormatNumber(lAddressesInUse, 0, vbTrue, vbFalse, vbTrue))
sResult = Replace(sResult, "%4", lPercentFree)
FormatDHCP2000ScopeEventMessage = sResult
End Function
Sub SubmitDHCP2000ScopeEvent(ByVal oScope)
Dim oEvent
Set oEvent = ScriptContext.CreateEvent()
With oEvent
.EventNumber = SCOPE_ADDRESS_STATUS_EVENT_ID
.EventSource = "DHCP Server 2000 - Scope Monitoring"
.SetEventParameter oScope.DisplayName
.SetEventParameter oScope.FreeAddresses
.SetEventParameter oScope.AddressesInUse
.SetEventParameter oScope.PercentFree
.Message = FormatDHCP2000ScopeEventMessage(oScope.DisplayName, _
oScope.FreeAddresses, _
oScope.AddressesInUse, _
oScope.PercentFree _
)
End With
ScriptContext.Submit oEvent
End Sub
Function EscapeRegex(ByVal sText)
Const METACHARACTERS = "\*+?|{[()^$."
Dim sResult
Dim i
For i = 1 To Len(sText)
Dim sCurrentChar
sCurrentChar = Mid(sText, i, 1)
If InStr(METACHARACTERS, sCurrentChar) <> 0 Then
sResult = sResult & "\"
End If
sResult = sResult & sCurrentChar
Next
EscapeRegex = sResult
End Function
Function FindDelimitedItemWildcard(ByVal sItem, ByVal sList, ByVal sDelimiter, ByVal bCaseSensitive)
If sList = "" Then
FindDelimitedItemWildcard = False
Exit Function
End If
Dim oRegex
Set oRegex = New RegExp
oRegex.IgnoreCase = Not bCaseSensitive
oRegex.Pattern = sList
FindDelimitedItemWildcard = oRegex.Test(sItem)
End Function
Function IsScopeIncluded(ByVal sScopeName, ByVal sIncludeList, ByVal sExcludeList)
Const LIST_DELIMITER = ";"
IsScopeIncluded = False
If FindDelimitedItemWildcard(sScopeName, sIncludeList, LIST_DELIMITER, False) Then
If Not FindDelimitedItemWildcard(sScopeName, sExcludeList, LIST_DELIMITER, False) Then
IsScopeIncluded = True
End If
End If
End Function
Sub Main()
Dim oDHCP
Set oDHCP = New DHCP2000
oDHCP.NetshPath = NETSH_PATH
Dim sExcludedScopes
sExcludedScopes = CStr(ScriptContext.Parameters.Get(EXCLUDE_SCOPES_PARAMETER_NAME))
Dim sIncludedScopes
sIncludedScopes = CStr(ScriptContext.Parameters.Get(INCLUDE_SCOPES_PARAMETER_NAME))
Dim oScope
For Each oScope In oDHCP.Scopes
SubmitPerfData DHCP_SERVER_PERF_OBJECT_NAME, SCOPE_FREE_ADDRESSES_PERF_COUNTER_NAME, oScope.PerfCounterInstanceName, oScope.FreeAddresses
SubmitPerfData DHCP_SERVER_PERF_OBJECT_NAME, SCOPE_ADDRESSES_IN_USE_PERF_COUNTER_NAME, oScope.PerfCounterInstanceName, oScope.AddressesInUse
If IsScopeIncluded(oScope.Subnet, sIncludedScopes, sExcludedScopes) Then
SubmitDHCP2000ScopeEvent oScope
End If
Next
End Sub</Script></Body>
<Language>VBScript</Language>
<Name>DHCP Server 2000 - Scope Monitoring</Name>
<Parameters>
<Parameter>
<Name>ExcludeScopes</Name>
<Value>$Config/Parameters/ExcludeScopes$</Value>
</Parameter>
<Parameter>
<Name>IncludeScopes</Name>
<Value>$Config/Parameters/IncludeScopes$</Value>
</Parameter>
</Parameters>
<ManagementPackId>[Microsoft.Windows.Server.DHCP,,1.0.0.1]</ManagementPackId>
</WriteAction>
</MemberModules>
<Composition>
<Node ID="RunScriptAction"/>
</Composition>
</Composite>
</ModuleImplementation>
<InputType>SystemLibrary!System.BaseData</InputType>
</WriteActionModuleType>
Home
Show References: