Use la búsqueda LDAP cuando el ámbito de una búsqueda sea el dominio o una unidad organizativa.
Cuando el ámbito de una búsqueda sea el bosque, la consulta se puede resolver dentro de cualquier partición mediante una búsqueda en un Catálogo global (GC).
Lista de valores:
LDAP
GC
Dim GlobalErrorList: Set GlobalErrorList = New ArrayList
Function IsValidObject(ByVal oObject)
IsValidObject = False
If IsObject(oObject) Then
If Not oObject Is Nothing Then
IsValidObject = True
End If
End If
End Function
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
Public Function GetSQLServiceName(sInstance)
If sInstance = SQL_DEFAULT Then
GetSQLServiceName = SQL_DEFAULT
Else
GetSQLServiceName = "MSSQL$" & sInstance
End If
End Function
'The function returns service or "Unknown" state
'Input:
' server - compute name
' service - system service name
'Output:
' service state or "Unknown" state
Function GetServiceState( sTargetComputer, sServiceName)
On Error Resume Next
Dim sNamespace, sQuery, oWMI, objClasses, sState
sNamespace = "winmgmts://" & sTargetComputer & "/root/cimv2"
sQuery = "SELECT State FROM Win32_Service where Name = """ & EscapeWQLString(sServiceName) & """"
Set oWMI = GetObject(sNamespace)
Set objClasses = oWMI.ExecQuery(sQuery)
if objClasses.Count >= 1 Then
sState = GetFirstItemFromWMIQuery(objClasses).Properties_.Item("State")
End If
If Err.number <> 0 Or objClasses.Count = 0 Then
sState = "Unknown"
End If
Err.Clear
GetServiceState = sState
End Function
'#Include File:SQL2008Constants.vbs
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
Class ArrayList
Private m_itemArray
Private Sub Class_Initialize()
Me.Clear
End Sub
Private Sub AddItemToArray(ByRef itemArray, ByVal item)
ReDim Preserve itemArray(UBound(itemArray) + 1)
itemArray(UBound(itemArray)) = item
End Sub
Public Sub Clear()
m_itemArray = Array()
End Sub
Public Sub Add(item)
AddItemToArray m_itemArray, item
End Sub
Public Sub RemoveAt(index)
If index < 0 Or index > UBound(m_itemArray) Then
Exit Sub
End If
Dim newArr: newArr = Array()
Dim i
For i = 0 To UBound(m_itemArray)
If i <> index Then
Call AddItemToArray(newArr, m_itemArray(i))
End If
Next
m_itemArray = newArr
End Sub
Public Property Get Count()
Count = UBound(m_itemArray) + 1
End Property
Public Property Get ItemsArray()
ItemsArray = m_itemArray
End Property
Public Property Get IsEmpty()
IsEmpty = UBound(m_itemArray) < 0
End Property
End Class
''''''''''''''''''''''''''''''''''''
''' ScriptLogger
''''''''''''''''''''''''''''''''''''
Class ScriptLogger
Dim sourceLogEvent
Private Sub Class_Initialize()
sourceLogEvent = "Management Group: " + ManagementGroupName + ". Script: " + WScript.ScriptName + ". Version: " + MANAGEMENT_PACK_VERSION
End Sub
Private Sub Class_Terminate()
End Sub
Public Property Get ErrorEventType
ErrorEventType = 1
End Property
Public Property Get WarningEventType
WarningEventType = 2
End Property
Public Property Get InfoEventType
InfoEventType = 4
End Property
Private Function LogEvent (message, eventType)
On Error Resume Next
Dim oAPI
Set oAPI = CreateObject("MOM.ScriptAPI")
Call oAPI.LogScriptEvent(sourceLogEvent, SCRIPT_EVENT_ID, eventType, message)
End Function
Public Function LogDebug(message)
if DEBUG_MODE Then
WScript.StdOut.WriteLine message
LogEvent message, Me.InfoEventType
End If
End Function
Public Function LogError(message)
if DEBUG_MODE Then
WScript.StdOut.WriteLine message
End If
LogEvent message, Me.ErrorEventType
End Function
Public Function LogWarning(message)
if DEBUG_MODE Then
WScript.StdOut.WriteLine message
End If
LogEvent message, Me.WarningEventType
End Function
Public Function LogFormattedError(customMessage)
Dim msg
If Err.number <> 0 Then
Me.LogError FormatErrorMessage(customMessage, "")
End If
End Function
Private Function ScriptInfo()
Dim commandLineInfo : commandLineInfo = WScript.ScriptFullName
Dim argument
For Each argument In WScript.Arguments
commandLineInfo = commandLineInfo & " """ & argument & """"
Next
ScriptInfo = commandLineInfo
End Function
End Class
Function FormatErrorMessage(customMessage, instanceName)
FormatErrorMessage = customMessage
If Err.number <> 0 Then
Dim msg
msg =_
" Error Number: " & CStr(Err.number) & VbCrLf & _
" Description: " & Err.Description
If Not IsEmpty(instanceName) And instanceName <> "" Then
msg = msg & VbCrLf & " Instance: " & instanceName
End If
If Not IsEmpty(customMessage) And customMessage <> "" Then
msg = customMessage & VbCrLf & msg & VbCrLf
End If
FormatErrorMessage = msg
End If
End Function
Function FormatDbErrorMessage(message, instanceName, dbName)
FormatDbErrorMessage = message & VbCrLf & _
" Instance: " & instanceName & VbCrLf & _
" Database: " & dbName
End Function
Function ThrowScriptErrorNoAbort(ByVal sMessage, ByVal oErr)
On Error Resume Next
Dim errorText: errorText = sMessage & ": " & oErr.Description
GlobalErrorList.Add errorText
End Function
Function ThrowScriptError(Byval sMessage, ByVal oErr)
On Error Resume Next
Dim oAPITemp: Set oAPITemp = MOMCreateObject("MOM.ScriptAPI")
oAPITemp.LogScriptEvent ("Management Group: " + ManagementGroupName + ". Script: " + WScript.ScriptName + ". Version: " + MANAGEMENT_PACK_VERSION), 4001, 1, sMessage & ". " & oErr.Description
Quit()
End Function
Sub HandleError(customMessage)
Dim localLogger
If Err.number <> 0 Then
Set localLogger = new ScriptLogger
Call localLogger.LogFormattedError(customMessage)
Call Wscript.Quit(0)
End If
End Sub
Function HandleErrorContinue(customMessage)
Dim localLogger
HandleErrorContinue = True
If Err.number <> 0 Then
HandleErrorContinue = False
Call GlobalErrorList.Add(FormatErrorMessage(customMessage, ""))
Call Err.Clear()
End If
End Function
Function HandleErrorContinueEx(customMessage, instanceName)
HandleErrorContinueEx = True
If Err.number <> 0 Then
HandleErrorContinueEx = False
Call GlobalErrorList.Add(FormatErrorMessage(customMessage, instanceName))
Call Err.Clear()
End If
End Function
Function HandleSqlErrorContinue(adoConnection, customMessage, instanceName)
HandleSqlErrorContinue = True
If Err.Number <> 0 Then
HandleSqlErrorContinue = False
Dim sqlErr
Dim e: Set e = new Error
e.Save
On Error Resume Next
If adoConnection.Errors.Count > 0 Then
Set sqlErr = adoConnection.Errors(0)
adoConnection.Errors.Clear
Call Err.Raise(sqlErr.Number, sqlErr.Source, sqlErr.Description)
Else
Call e.Raise()
End If
Call HandleErrorContinueEx(customMessage, instanceName)
End If
End Function
Function GetGlobalErrorListEventString()
GetGlobalErrorListEventString = ""
If Not GlobalErrorList.IsEmpty Then
GetGlobalErrorListEventString = "The next errors occured:"& vbNewLine & Join(GlobalErrorList.ItemsArray, vbNewLine & vbNewLine)
End If
End Function
Function GlobalErrorListToEventLog()
On Error Resume Next
If Not GlobalErrorList.IsEmpty Then
Dim localLogger: Set localLogger = New ScriptLogger
localLogger.LogWarning GetGlobalErrorListEventString()
End If
End Function
Function Quit()
WScript.Quit()
End Function
'#Include File:WMI.vbs
Function EscapeWQLString (ByVal strValue)
On Error Resume Next
Err.Clear
EscapeWQLString = Replace(Replace(strValue, "\", "\\"), "'", "\'")
End Function
Function ConnectToWMI(ComputerName, strNamespace)
Set ConnectToWMI = Nothing
Set ConnectToWMI = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & ComputerName & "\" & strNamespace)
End Function
Function WMIGetProperty(oWmi, sPropName, nCIMType, ErrAction)
Dim sValue, oWmiProp
If Not IsValidObject(oWmi) Then
If (ErrAction And ErrAction_ThrowError) = ErrAction_ThrowError Then _
ThrowScriptErrorNoAbort "Accessing property on invalid WMI object.", Err
If (ErrAction And ErrAction_Abort) = ErrAction_Abort Then _
Quit()
WMIGetProperty = ""
Exit Function
End If
On Error Resume Next
Set oWmiProp = oWmi.Properties_.Item(sPropName)
If Err.Number <> 0 Then
If (ErrAction And ErrAction_ThrowError) = ErrAction_ThrowError Then _
ThrowScriptErrorNoAbort "An error occurred while accessing WMI property: '" & sPropName & "'.", Err
If (ErrAction And ErrAction_Abort) = ErrAction_Abort Then _
Quit()
End If
On Error GoTo 0
If IsValidObject(oWmiProp) Then
sValue = oWmiProp.Value
If IsNull(sValue) Then
'
' If value is null, return blank to avoid any issues
'
WMIGetProperty = ""
Else
Select Case (oWmiProp.CIMType)
Case wbemCimtypeString, wbemCimtypeSint16, wbemCimtypeSint32, wbemCimtypeReal32, wbemCimtypeReal64, wbemCimtypeSint8, wbemCimtypeUint8, wbemCimtypeUint16, wbemCimtypeUint32, wbemCimtypeSint64, wbemCimtypeUint64:
If Not oWmiProp.IsArray Then
WMIGetProperty = Trim(CStr(sValue))
Else
WMIGetProperty = Join(sValue, ", ")
End If
Case wbemCimtypeBoolean:
If sValue = 1 Or UCase(sValue) = "TRUE" Then
WMIGetProperty = "True"
Else
WMIGetProperty = "False"
End If
Case wbemCimtypeDatetime:
Dim sTmpStrDate
'
' First attempt to convert the whole wmi date string
'
sTmpStrDate = Mid(sValue, 5, 2) & "/" & _
Mid(sValue, 7, 2) & "/" & _
Left(sValue, 4) & " " & _
Mid (sValue, 9, 2) & ":" & _
Mid(sValue, 11, 2) & ":" & _
Mid(sValue, 13, 2)
If IsDate(sTmpStrDate) Then
WMIGetProperty = CDate(sTmpStrDate)
Else
'
' Second, attempt just to convert the YYYYMMDD
'
sTmpStrDate = Mid(sValue, 5, 2) & "/" & _
Mid(sValue, 7, 2) & "/" & _
Left(sValue, 4)
If IsDate(sTmpStrDate) Then
WMIGetProperty = CDate(sTmpStrDate)
Else
'
' Nothing works - return passed in string
'
WMIGetProperty = sValue
End If
End If
Case Else:
WMIGetProperty = ""
End Select
End If
Else
If (ErrAction And ErrAction_ThrowError) = ErrAction_ThrowError Then _
ThrowScriptErrorNoAbort "An error occurred while accessing WMI property: '" & sPropName & "'.", Err
If (ErrAction And ErrAction_Abort) = ErrAction_Abort Then _
Quit()
WMIGetProperty = ""
End If
If (ErrAction And ErrAction_Trace) = ErrAction_Trace Then _
WScript.Echo " + " & sPropName & " :: '" & WMIGetProperty & "'"
End Function
Function WMIExecQuery(ByVal sNamespace, ByVal sQuery)
'
' WMIExecQuery :: Executes the WMI query and returns the result set.
'
'
Dim oWMI, oQuery, nInstanceCount
Dim e
Set e = New Error
On Error Resume Next
Set oWMI = GetObject(sNamespace)
e.Save
On Error GoTo 0
If IsEmpty(oWMI) Then
ThrowScriptErrorNoAbort "Unable to open WMI Namespace '" & sNamespace & "'. Check to see if the WMI service is enabled and running, and ensure this WMI namespace exists.", e
ThrowEmptyDiscoveryData
End If
On Error Resume Next
Set oQuery = oWMI.ExecQuery(sQuery)
e.Save
On Error GoTo 0
If IsEmpty(oQuery) Or e.Number <> 0 Then
ThrowScriptError "The Query '" & sQuery & "' returned an invalid result set. Please check to see if this is a valid WMI Query.", e
End If
'Determine if we queried a valid WMI class - Count will return 0 or empty
On Error Resume Next
nInstanceCount = oQuery.Count
e.Save
On Error GoTo 0
If e.Number <> 0 Then
ThrowScriptError "The Query '" & sQuery & "' did not return any valid instances. Please check to see if this is a valid WMI Query.", e
End If
Set WMIExecQuery = oQuery
End Function
Function GetFirstItemFromWMIQuery(ByRef oQuery)
ON ERROR RESUME NEXT
Err.Clear
Dim oResult: Set oResult = Nothing
Set oResult = oQuery.ItemIndex(0)
if Err.number <> 0 then
Err.Clear
Dim oObject
For Each oObject in oQuery
Set oResult = oObject
Exit For
Next
end if
Set GetFirstItemFromWMIQuery = oResult
End Function
'#Include File:SQLSPNMonitoring.vbs
' Copyright (c) Microsoft Corporation. All rights reserved.
' This script takes one parameters of the sql instance
' returns whether the SPN of SQL is correct.
Const SCRIPT_EVENT_ID = 4001
Function GetServiceAccount(sInstance)
Dim sServiceName : sServiceName = GetSQLServiceName(sInstance)
Dim oService, sObjectString
sObjectString = "winmgmts:\\.\root\cimv2"
Set oService = GetObject(sObjectString & ":Win32_Service.Name='" & EscapeWQLString(sServiceName) & "'")
GetServiceAccount = oService.StartName
Set oService = Nothing
End Function
Function CheckHostNameByPing(fqdn)
Dim objPing, objRetStatus
Set objPing = GetObject("winmgmts:{impersonationLevel=impersonate}").ExecQuery ("select * from Win32_PingStatus where address = '" & fqdn & "'")
CheckHostNameByPing = False
For Each objRetStatus in objPing
If objRetStatus.PrimaryAddressResolutionStatus = 0 Then
CheckHostNameByPing = True
Exit Function
End If
Next
End Function
Const SCRIPT_ERRORNUMBER = 4001
' Validate the arguments.
Dim oArgs
Set oArgs = WScript.Arguments
If oArgs.Count < 6 Then
WScript.Quit -1
End If
Dim sInstanceName, sFqdn, sAccount, sMachineName, sServiceName, sSearchScope
' Create the objects.
Dim oAPI, oBag
Set oAPI = CreateObject("MOM.ScriptAPI")
Set oBag = oAPI.CreatePropertyBag()
' Prepare account name for virtual service account
Dim sVirtualAccountName
sVirtualAccountName = "NT SERVICE\"
If StringEqualsInsensitive(sInstanceName, "MSSQLSERVER") Then
sVirtualAccountName = sVirtualAccountName & "MSSQLSERVER"
Else
sVirtualAccountName = sVirtualAccountName & "MSSQL$" & sInstanceName
End If
'get Domain DC=onecity,DC=corp,DC=fabrikam,DC=com
Dim sDefaultDomainNC
On Error Resume Next
if StringContainsInsensitive(sSearchScope, "GC") Or (StringContainsInsensitive(sSearchScope, "Global") and StringContainsInsensitive(sSearchScope, "Catalog")) then
sDefaultDomainNC = GetRootDomainNamingContext()
else
sDefaultDomainNC = GetDefaultRootNamingContext()
end if
' Log a information message if it's not domain joined.
If Err.number <> 0 Then
Call HandleErrorSPN(4, "The computer is not domain joined.")
End If
On Error Goto 0
' If domain NC is null, it's not domain joined computer, skip.
If IsNull(sDefaultDomainNC) Or sDefaultDomainNC = "" Then
Call SilentQuit()
End If
' If sFqdn doesn't include domain
dim sDomainNC
Dim tempFqdn
sDomainNC = Replace(sDefaultDomainNC, ",DC=", ".")
sDomainNC = Replace(sDomainNC, "DC=", ".")
if InStr(1, LCase(sFqdn), LCase(sDomainNC)) = 0 Then
tempFqdn = sFqdn & sDomainNC
If CheckHostNameByPing(tempFqdn) Then
sFqdn = tempFqdn
End If
End If
' Get the expected Account
Dim sExpectedAccount
' For LocalService and NetworkService account, we need to check both strings with space and without space.
If StringEqualsInsensitive(sAccount, "NT AUTHORITY\NETWORK SERVICE") Or StringEqualsInsensitive(sAccount, "NT AUTHORITY\NETWORKSERVICE") Or _
StringEqualsInsensitive(sAccount, "NT AUTHORITY\LOCAL SERVICE") Or StringEqualsInsensitive(sAccount, "NT AUTHORITY\LOCALSERVICE") Or _
StringEqualsInsensitive(sAccount, "LOCALSYSTEM") Or StringEqualsInsensitive(sAccount, sVirtualAccountName) Then
sExpectedAccount = LCase(sMachineName) & "$"
Else
' If the service account in a local account, skip
Dim sDomainPart
sDomainPart = GetDomainPart(sAccount)
If StringEqualsInsensitive(sDomainPart, sFqdn) Or StringEqualsInsensitive(sDomainPart, sMachineName) Or _
StringEqualsInsensitive(sDomainPart, ".") Or StringEqualsInsensitive(sDomainPart, "LOCALHOST") Or _
StringEqualsInsensitive(sDomainPart, "") Then
Call SilentQuit()
End If
sExpectedAccount = LCase(GetAccountOnly(sAccount))
End If
Dim dRequiredSpns, sSpn
Set dRequiredSpns = CreateObject("Scripting.Dictionary")
' Query protocols from WMI
Dim sWMIQuery, colProtocals, oProtocal
sWMIQuery = "SELECT ProtocolName FROM ServerNetworkProtocol where Enabled = true and InstanceName = '" & EscapeWQLString(sInstanceName) & "'"
Set colProtocals = WMIExecQuery ("winmgmts:\\" & sFqdn & "\root\Microsoft\SqlServer\" & SQL_WMI_NAMESPACE, sWMIQuery)
For Each oProtocal In colProtocals
If Not IsNull(oProtocal) Then
Select Case oProtocal.ProtocolName
Case "Tcp"
' Get the sql tcp ports.
Dim dTcpPorts, sPort
' TODO: the oProtocal.MultiIpConfigurationSupport is always true..
Set dTcpPorts = GetSqlTcpPorts(sInstanceName)
' Add required SPN for each tcp port
For Each sPort in dTcpPorts
If sPort <> "0" Then
sSpn = "MSSQLSvc/" & sFqdn & ":" & sPort
Call dRequiredSpns.Add(sSpn, sSpn)
End If
Next
Case "Np"
If StringEqualsInsensitive(sInstanceName, "MSSQLSERVER") = True Then
sSpn = "MSSQLSvc/" & sFqdn
Else
sSpn = "MSSQLSvc/" & sFqdn & ":" & sInstanceName
End If
Call dRequiredSpns.Add(sSpn, sSpn)
Case Else
' Do nothing.
End Select
End If
Next
'phase 2 Query AD..
Dim dSamAccountNames, sSamAccountName
Dim sMissingSpnList, sMisplacedSpnList, sDuplicateSpnList
Dim bSpnExistOnServiceAccount, bSpnExistOnNonServiceAccount, bHasIssue
bHasIssue = False
' For each required spn, query the AD.
For Each sSpn in dRequiredSpns
bSpnExistOnServiceAccount = False
bSpnExistOnNonServiceAccount = False
' Query the AD for the spn
Set dSamAccountNames = SearchADForSpn(sSpn, sDefaultDomainNC)
' If failed to query the AD, skip check
If dSamAccountNames is Nothing Then
Call SilentQuit()
End If
' For each account object returned, check if the samAccountName matches the expected value.
For Each sSamAccountName in dSamAccountNames
If LCase(sSamAccountName) = sExpectedAccount Then
bSpnExistOnServiceAccount = True
Else
bSpnExistOnNonServiceAccount = True
End If
Next
If Not bSpnExistOnServiceAccount And Not bSpnExistOnNonServiceAccount Then
bHasIssue = True
sMissingSpnList = sMissingSpnList & sSpn & ", "
End If
If Not bSpnExistOnServiceAccount And bSpnExistOnNonServiceAccount Then
bHasIssue = True
' We dint find the SPN on the Expected account, so all the existing SamAccountNames are incorrect.
For Each sSamAccountName in dSamAccountNames
sMisplacedSpnList = sMisplacedSpnList & sSpn & " - " & sSamAccountName & ", "
Next
End If
If bSpnExistOnServiceAccount And bSpnExistOnNonServiceAccount Then
bHasIssue = True
' We just want to include the SamAccountNames that doesnt match the Excepted Account
For Each sSamAccountName in dSamAccountNames
If LCase(sSamAccountName) <> sExpectedAccount Then
sDuplicateSpnList = sDuplicateSpnList & sSpn & " - " & sSamAccountName & ", "
End If
Next
End If
Next
' add result to the property bag and return.
Call oBag.AddValue("HasIssue", bHasIssue)
Call oBag.AddValue("MissingSpnList", NormalizeSpnList(sMissingSpnList))
Call oBag.AddValue("MisplacedSpnList", NormalizeSpnList(sMisplacedSpnList))
Call oBag.AddValue("DuplicateSpnList", NormalizeSpnList(sDuplicateSpnList))
Call oAPI.Return(oBag)
On Error Resume Next
Call GlobalErrorListToEventLog()
WScript.Quit()
' Quit silently
Sub SilentQuit()
Call oBag.AddValue("HasIssue", False)
Call oAPI.Return(oBag)
Call GlobalErrorListToEventLog()
WScript.Quit()
End Sub
' return if the string equals insensitively
Function StringEqualsInsensitive(strA, strB)
If LCase(strA) = LCase(strB) Then
StringEqualsInsensitive = True
Else
StringEqualsInsensitive = False
End If
End Function
' return if the string contains substring insensitively
Function StringContainsInsensitive(strA, strB)
If InStr(LCase(strA), LCase(strB)) > 0 Then
StringContainsInsensitive = True
Else
StringContainsInsensitive = False
End If
End Function
' This function accept "domain\account" input, returns "account"
' If the input is "account@domain", return "account"
Function GetAccountOnly(sAccount)
Dim iPos
' Check if the account is in "account@domain" format.
iPos = InStr(sAccount, "@")
If iPos > 1 Then
GetAccountOnly = Left(sAccount, iPos - 1)
Exit Function
End If
iPos = InStr(sAccount, "\")
If iPos > 0 Then
GetAccountOnly = Right(sAccount, Len(sAccount) - iPos)
Else
GetAccountOnly = sAccount
End If
End Function
' This function accept "domain\account" input, returns "domain"
' If the input is "account@domain", return "domain"
Function GetDomainPart(sAccount)
Dim iPos
' Check if the account is in "account@domain" format.
iPos = InStr(sAccount, "@")
If iPos > 0 Then
GetDomainPart = Right(sAccount, Len(sAccount) - iPos)
Exit Function
End If
iPos = InStr(sAccount, "\")
If iPos > 1 Then
GetDomainPart = Left(sAccount, iPos-1)
Else
GetDomainPart = ""
End If
End Function
' Remove the last "," if exists
Function NormalizeSpnList(sSpnList)
Dim iLen
iLen = Len(sSpnList)
If iLen > 2 Then
NormalizeSpnList = Left(sSpnList, iLen - 2)
Else
NormalizeSpnList = sSpnList
End If
End Function
' The function search the AD for the give SPN
Function SearchADForSpn(sSpn, sDefaultDomainNC)
Dim sBase, sFilter, sAttribs, sDepth, sQuery
' Use GC query here to improve the performance?
' If we query the entire forest, we have to use GC query.
sBase = "<GC://" & sDefaultDomainNC & ">"
' Build the query string.
sFilter = "(servicePrincipalName=" & sSpn & ")"
sAttribs = "samAccountName"
sDepth = "subTree"
sQuery = sBase & ";" & sFilter & ";" & sAttribs & ";" & sDepth
' Do the search
Dim oResults
On Error Resume Next
Set oResults = ExecuteADQuery(sQuery)
' Log a warning message if query failed.
If Err.number <> 0 Then
Call HandleErrorSPN(2, "Failed to execute the query '" & sQuery & "' in the Active Directory.")
Set SearchADForSpn = Nothing
Exit Function
End If
On Error Goto 0
Dim dSamAccountName, sSamAccountName
Set dSamAccountName = CreateObject("Scripting.Dictionary")
' Add the samAccountName to the dictionary
Do While Not oResults.EOF
sSamAccountName = oResults("samAccountName")
Call dSamAccountName.Add(sSamAccountName, sSamAccountName)
oResults.MoveNext
Loop
Set SearchADForSpn = dSamAccountName
End Function
' This function get the sql tcp ports.
Function GetSqlTcpPorts(sInstanceName)
Dim sTcpPort, sWMIQuery, iListenOnAllIPs
Dim dSqlTcpPorts, colProtocalProperties, oProperty
Set dSqlTcpPorts = CreateObject("Scripting.Dictionary")
' Get ListenOnAllIPs property
sWMIQuery = "SELECT PropertyName, PropertyNumVal FROM ServerNetworkProtocolProperty WHERE ProtocolName = 'Tcp' And PropertyName = 'ListenOnAllIPs' And InstanceName = '" & EscapeWQLString(sInstanceName) & "'"
Set colProtocalProperties = WMIExecQuery ("winmgmts:\\" & sFqdn & "\root\Microsoft\SqlServer\" & SQL_WMI_NAMESPACE, sWMIQuery)
For Each oProperty in colProtocalProperties
If Not IsNull(oProperty) Then
iListenOnAllIPs = oProperty.PropertyNumVal
Exit For
End If
Next
If iListenOnAllIPs = 1 Then
Call GetTcpPort(sInstanceName, "IPAll", dSqlTcpPorts)
Else
Dim oIPAddress, colIPAddressNames
sWMIQuery = "SELECT IPAddressName FROM ServerNetworkProtocolIPAddress WHERE ProtocolName = 'Tcp' And Enabled = true And InstanceName = '" & EscapeWQLString(sInstanceName) & "'"
Set colIPAddressNames = WMIExecQuery ("winmgmts:\\" & sFqdn & "\root\Microsoft\SqlServer\" & SQL_WMI_NAMESPACE, sWMIQuery)
For Each oIPAddress in colIPAddressNames
If Not IsNull(oIPAddress) Then
Call GetTcpPort(sInstanceName, oIPAddress.IPAddressName, dSqlTcpPorts)
End If
Next
End If
Set GetSqlTcpPorts = dSqlTcpPorts
End Function
Sub AddIfNotExist(ByRef dic, value)
If Not dic.Exists(value) Then
Call dic.Add(value, value)
End If
End Sub
' Get the TCP port for the given IPAddressName.
Sub GetTcpPort(sInstanceName, sIPAddressName, ByRef dic)
Dim sWMIQuery
Dim oProtocalProperty, colProtocalProperties
sWMIQuery = "SELECT PropertyName, PropertyStrVal FROM ServerNetworkProtocolProperty WHERE ProtocolName = 'Tcp' And IpAddressName = '" & EscapeWQLString(sIPAddressName) & "' And InstanceName = '" & EscapeWQLString(sInstanceName) & "'"
Set colProtocalProperties = WMIExecQuery ("winmgmts:\\" & sFqdn & "\root\Microsoft\SqlServer\" & SQL_WMI_NAMESPACE, sWMIQuery)
For Each oProtocalProperty In colProtocalProperties
If IsNull(oProtocalProperty) = False Then
If oProtocalProperty.PropertyName = "TcpPort" And oProtocalProperty.PropertyStrVal <> "" And IsNumeric(oProtocalProperty.PropertyStrVal) Then
Call AddIfNotExist(dic, oProtocalProperty.PropertyStrVal)
ElseIf oProtocalProperty.PropertyName = "TcpDynamicPorts" And oProtocalProperty.PropertyStrVal <> "" And IsNumeric(oProtocalProperty.PropertyStrVal) Then
Call AddIfNotExist(dic, oProtocalProperty.PropertyStrVal)
End If
End If
Next
End Sub
' This function return the root domain naming context
Function GetRootDomainNamingContext()
Dim oRootDse, sRootNamingContext
Set oRootDse = GetObject("GC://RootDSE")
If Not (oRootDse Is Nothing) Then
sRootNamingContext = oRootDse.Get("rootDomainNamingContext")
End If
GetRootDomainNamingContext = sRootNamingContext
End Function
' This function return the default root naming context
Function GetDefaultRootNamingContext()
Dim oRootDse, sRootNamingContext
Set oRootDse = GetObject("LDAP://RootDSE")
If Not (oRootDse Is Nothing) Then
sRootNamingContext = oRootDse.Get("defaultNamingContext")
End If
GetDefaultRootNamingContext = sRootNamingContext
End Function
' Execute the AD query.
Function ExecuteADQuery(sQuery)
Dim oConnection
Set oConnection = CreateObject("ADODB.Connection")
oConnection.Open "Data Source=Active Directory Provider;Provider=ADsDSOObject"
If Err.number = 0 Then
Set ExecuteADQuery = oConnection.Execute(sQuery)
Else
Set ExecuteADQuery = Nothing
End If
End Function
' Handle the error: log the error in the event log.
Sub HandleErrorSPN(iLevel, sMessage)
Call HandleErrorContinue(sMessage)
Call Err.Clear()
End Sub </Script></ScriptBody>
<TimeoutSeconds>$Config/TimeoutSeconds$</TimeoutSeconds>
</DataSource>
</MemberModules>
<Composition>
<Node ID="DS"/>
</Composition>
</Composite>
</ModuleImplementation>
<OutputType>System!System.PropertyBagData</OutputType>
</DataSourceModuleType>
Home
ESN 
Show References: