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
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)
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 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
ThrowScriptErrorNoAbort sMessage, oErr
GlobalErrorListToEventLog()
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)
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 occurred:"& 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.
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
' 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
On Error Resume Next
Dim wmiObjList: Set wmiObjList = WMIExecQuery("winmgmts:{impersonationLevel=impersonate}!\\.\ROOT\CIMV2", "SELECT PartOfDomain FROM Win32_ComputerSystem")
Dim wmiObj: Set wmiObj = GetFirstItemFromWMIQuery(wmiObjList)
If Err.Number <> 0 Or wmiObj Is Nothing Then
Call HandleErrorSPN(4, "Unable to determine whether the computer is domain joined")
Call SilentQuit()
End If
If Not wmiObj.PartOfDomain Then
Call SilentQuit()
End If
'get Domain DC=onecity,DC=corp,DC=fabrikam,DC=com
Dim sDefaultDomainNC
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
sDomainNC = Replace(sDefaultDomainNC, ",DC=", ".")
sDomainNC = Replace(sDomainNC, "DC=", ".")
Dim tempFqdn
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 & ">"
'sBase = "<LDAP://" & 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:").OpenDSObject("LDAP://RootDSE", vbNullString, vbNullString, ADS_SECURE_AUTHENTICATION Or ADS_READONLY_SERVER Or ADS_SERVER_BIND)
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
JPN 
Show References: