Dim GlobalErrorList: Set GlobalErrorList = New ArrayList
Dim oAPI
Set oAPI = MOMCreateObject("MOM.ScriptAPI")
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)
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)
FormatErrorMessage = customMessage
If Err.number <> 0 Then
Dim msg
msg = Replace(" Error Number: #P1# " & VbCrLf & " Description: #P2# ", "#P1#", CStr(Err.number) )
msg = Replace(msg, "#P2#", Err.Description )
msg = customMessage & VbCrLf & msg & VbCrLf
FormatErrorMessage = msg
End If
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
localLogger.LogFormattedError(customMessage)
Wscript.Quit 0
End If
End Sub
Function HandleErrorContinue(customMessage)
Dim localLogger
HandleErrorContinue = True
If Err.number <> 0 Then
HandleErrorContinue = False
GlobalErrorList.Add FormatErrorMessage(customMessage)
Err.Clear
End If
End Function
Function HandleSqlErrorContinue(adoConnection, customMessage)
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
HandleErrorContinue customMessage
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(strValue, "'", "\'")
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 = 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:ConnectionString.vbs
Function ArraysAreIntersected(ByRef arrA, ByRef arrB)
Dim itemA, itemB
ArraysAreIntersected = False
For Each itemA in arrA
For Each itemB in arrB
If itemA = itemB Then
ArraysAreIntersected = True
Exit Function
End If
Next
Next
End Function
Function ArrayContains(ByRef arr, ByRef searchItem)
ArrayContains = False
Dim item
For Each item In arr
If item = searchItem Then
ArrayContains = True
Exit Function
End If
Next
End Function
Function GetDriverVersionObj(oVersion)
Dim tpName, vVersion
tpName = TypeName(oVersion)
Select Case tpName
Case "DriverVersion"
Set vVersion = oVersion
Case "String"
Set vVersion = (new DriverVersion)(oVersion)
Case Else
Call Err.Raise(7100, "DriverVersion", "Parameter is not an instance of type DriverVersion.")
End Select
Set GetDriverVersionObj = vVersion
End Function
Class DriverVersion
Private m_major
Private m_minor
Private m_build
Private m_revision
Public Default Function Init(versionStr)
Parse(versionStr)
Set Init = Me
End Function
Private Sub Parse(vStr)
Dim parts, versionRegex, oRegex, matches
Set oRegex = New RegExp
oRegex.Pattern = "^(\d{1,8})(.\d{1,8}){0,3}$"
Set matches = oRegex.Execute(vStr)
If matches.Count = 0 Then
Call Err.Raise(7100, "DriverVersion", "Invalid version string.")
End If
parts = Split(vStr, ".")
m_major = CLng(parts(0))
m_minor = 0
m_build = 0
m_revision = 0
IF UBound(parts) >= 1 Then
m_minor = CLng(parts(1))
If UBound(parts) >= 2 Then
m_build = CLng(parts(2))
If UBound(parts) >= 3 Then
m_revision = CLng(parts(3))
End If
End If
End If
End Sub
Public Function CompareTo(v)
Dim d
d = m_major - v.Major
If d <> 0 Then
CompareTo = d
Exit Function
End If
d = m_minor - v.Minor
If d <> 0 Then
CompareTo = d
Exit Function
End If
d = m_build - v.Build
If d <> 0 Then
CompareTo = d
Exit Function
End If
d = m_revision - v.Revision
CompareTo = d
End Function
Public Function ToString()
ToString = "" & m_major & "." & m_minor & "." & m_build & "." & m_revision
End Function
Public Property Get Major()
Major = m_major
End Property
Public Property Get Minor()
Minor = m_minor
End Property
Public Property Get Build()
Build = m_build
End Property
Public Property Get Revision()
Revision = m_revision
End Property
End Class
Class VersionRange
Private m_startVersion
Private m_endVersion
Public Default Function Init(sStartVersion, sEndVersion)
Set m_startVersion = GetDriverVersionObj(sStartVersion)
Set m_endVersion = GetDriverVersionObj(sEndVersion)
Set Init = Me
End Function
Public Property Get StartVersion()
Set StartVersion = m_startVersion
End Property
Public Property Get EndVersion()
Set EndVersion = m_endVersion
End Property
End Class
Class DriverItem
Private m_name
Private m_nameVersion
Private m_driverVersion
Private m_parseObject
Public Default Function Init(sName, oNameVersion, oDriverVersion, ByRef oParseObject)
m_Name = sName
Set m_nameVersion = GetDriverVersionObj(oNameVersion)
Set m_driverVersion = GetDriverVersionObj(oDriverVersion)
Set m_parseObject = oParseObject
Set Init = Me
End Function
Public Property Get Name()
Name = m_name
End Property
Public Property Get NameVersion()
Set NameVersion = m_nameVersion
End Property
Public Property Get DriverVersion()
Set DriverVersion = m_driverVersion
End Property
Public Property Get ParseObject()
Set ParseObject = m_parseObject
End Property
End Class
Public Default Function Init(sNameRegex, sVersionRegex, sNameMinVersion, sNameMaxVersion, oVersionRangeArray)
m_computerId = "."
m_nameRegexStr = sNameRegex
Set m_nameRegex = New RegExp
m_nameRegex.Pattern = m_nameRegexStr
m_versionRegexStr = sVersionRegex
If Not IsNull(m_versionRegexStr) Then
If Len(m_versionRegexStr) > 0 Then
Set m_versionRegex = New RegExp
m_versionRegex.Pattern = m_versionRegexStr
m_versionRegex.Global = True
End If
End If
Set m_nameMinVersion = GetDriverVersionObj(sNameMinVersion)
Set m_nameMaxVersion = GetDriverVersionObj(sNameMaxVersion)
m_driverVersionArr = oVersionRangeArray
DriverCollection = Array()
IsNativeClient = False
Set Init = Me
End Function
Private Function CheckVersion(oVersion, vMinVersion, vMaxVersion)
Dim vVersion: Set vVersion = GetDriverVersionObj(oVersion)
CheckVersion = vVersion.CompareTo(vMinVersion) >= 0 And (vVersion.ToString() = MAX_DRIVER_VERSION_STR Or vMinVersion.CompareTo(vMaxVersion) = 0 Or vVersion.CompareTo(vMaxVersion) < 0)
End Function
Public Function MatchName(sDriverName)
Dim matches
Set matches = m_nameRegex.Execute(sDriverName)
If matches.Count > 0 Then
MatchName = True
Exit Function
End If
MatchName = False
End Function
Public Function GetNameVersion(sDriverName)
Dim sVersion, matches
If Not IsNull(m_versionRegexStr) Then
Set matches = m_versionRegex.Execute(sDriverName)
If matches.Count > 0 Then
sVersion = matches(0).Value
End If
End If
If Not IsNull(sVersion) Then
Set GetNameVersion = GetDriverVersionObj(sVersion)
Else
Set GetNameVersion = GetDriverVersionObj("0")
End If
End Function
Public Function CheckNameVersion(oVersion)
CheckNameVersion = CheckVersion(oVersion, m_nameMinVersion, m_nameMaxVersion)
End Function
Public Function CheckDriverVersion(oVersion)
Dim i: i = 0
CheckDriverVersion = False
Dim driverVersionItem
For Each driverVersionItem In m_driverVersionArr
If CheckVersion(oVersion, driverVersionItem.StartVersion, driverVersionItem.EndVersion) Then
CheckDriverVersion = True
Exit For
End If
Next
End Function
Public Function GetDriverVersion(sDriverName)
Dim computerId, driverPath, sDllVersion, objFSO, oRegistry
Dim HKEY_LOCAL_MACHINE: HKEY_LOCAL_MACHINE = &H80000002
Set oRegistry = GetObject("winmgmts:\\" & m_computerId & "\root\default:StdRegProv")
oRegistry.GetStringValue HKEY_LOCAL_MACHINE, "SOFTWARE\ODBC\ODBCINST.INI\" & sDriverName, "Driver", driverPath
Set objFSO = CreateObject("Scripting.FileSystemObject")
sDllVersion = objFSO.GetFileVersion(driverPath)
Set GetDriverVersion = (new DriverVersion)(sDllVersion)
End Function
Public Sub AddDriver(ByRef oDriver)
ReDim Preserve DriverCollection(UBound(DriverCollection) + 1)
Set DriverCollection(UBound(DriverCollection)) = oDriver
End Sub
Public Sub ResetState()
DriverCollection = Array()
End Sub
Public Property Get DriverNameRegex()
DriverNameRegex = m_nameRegexStr
End Property
Public Property Get NameMinVersion()
Set NameMinVersion= m_nameMinVersion
End Property
Public Property Get NameMaxVersion()
Set NameMaxVersion = m_nameMaxVersion
End Property
Public Property Get VersionRangeCollection()
VersionRangeCollection = m_driverVersionArr
End Property
Public Property Get CollectionIsEmpty()
CollectionIsEmpty = UBound(DriverCollection) < 0
End Property
End Class
Private Sub Class_Initialize()
Set m_selectorRules(0) = (new DriverSelectorRule)("^SQL\sServer\sNative\sClient\s\d{1,8}(\.\d{1,8})?$","\d{1,8}(\.\d{1,8})?$", "11.0", "11.0",_
Array(_
(new VersionRange)("2011.110.6020.0", MAX_DRIVER_VERSION_STR),_
(new VersionRange)("2011.110.5592.0", "2011.110.6000.0"),_
(new VersionRange)("2011.110.5347.0", "2011.110.5522.0")))
m_selectorRules(0).IsNativeClient = True
Set m_selectorRules(1) = (new DriverSelectorRule)("^ODBC\sDriver\s\d{1,8}(\.\d{1,8})?\sfor\sSQL\sServer$", "\d{1,8}(\.\d{1,8})?(?=\sfor\sSQL\sServer$)", "11.0", MAX_DRIVER_VERSION_STR,_
Array(_
(new VersionRange)("2014.120.4219.0", MAX_DRIVER_VERSION_STR),_
(new VersionRange)("2014.120.2546.0", "2014.120.4000.0")))
Set m_selectorRules(2) = (new DriverSelectorRule)("^SQL\sServer\sNative\sClient\s\d{1,8}(\.\d{1,8})?$", "\d{1,8}(\.\d{1,8})?$","0", MAX_DRIVER_VERSION_STR, Array((new VersionRange)("0", MAX_DRIVER_VERSION_STR)))
m_selectorRules(2).IsNativeClient = True
Set m_selectorRules(3) = (new DriverSelectorRule)("^ODBC\sDriver\s\d{1,8}(\.\d{1,8})?\sfor\sSQL\sServer$", "\d{1,8}(\.\d{1,8})?(?=\sfor\sSQL\sServer$)", "0", MAX_DRIVER_VERSION_STR, Array((new VersionRange)("0", MAX_DRIVER_VERSION_STR)))
Public Sub ProcessDrivers(enabledServerProtocols)
Dim ri, i, isSelected, currentSelect, oError
Set oError = New Error
Call ResetState()
On Error Resume Next
Dim ncNamespace: ncNamespace = GetNsNameWithHighestVersion()
Dim clientProtocols: clientProtocols = GetEnabledNativeClientProtocols(ncNamespace)
Dim ncProtocolsAreIntersected: ncProtocolsAreIntersected = ArraysAreIntersected(enabledServerProtocols, clientProtocols)
Call ProcessSystemOdbcDrivers(ncProtocolsAreIntersected)
oError.Save
If oError.Number <> 0 Then
AddError(oError)
m_selectedDriverName = m_defaultDriverName
m_processed = true
Exit Sub
End If
On Error GoTo 0
Dim driver, selectorRule
For Each selectorRule In m_selectorRules
If Not selectorRule.CollectionIsEmpty Then
For Each driver In selectorRule.DriverCollection
If isSelected Then
If driver.NameVersion.CompareTo(currentSelect.NameVersion) >= 0 And driver.DriverVersion.CompareTo(currentSelect.DriverVersion) >= 0 Then
Set currentSelect = driver
End If
Else
Set currentSelect = driver
isSelected = True
End If
Next
End If
If isSelected Then
Exit For
End If
Next
If isSelected Then
m_selectedDriverName = currentSelect.Name
If currentSelect.ParseObject.IsNativeClient Then
oError.Clear
On Error Resume Next
GetNativeClientSettings(ncNamespace)
oError.Save
If oError.Number <> 0 Then
AddError(oError)
End If
m_ncli_tcpProtocolEnabled = ArrayContains(clientProtocols, "tcp")
On Error GoTo 0
End If
Else
m_selectedDriverName = m_defaultDriverName
End If
m_processed = True
End Sub
Private Sub ProcessOdbcDriver(driverName, protocolsAreIntersected)
Dim i, isInstalled, oRegistry, oNameVersion, oDriverVersion
On Error GoTo 0
Set oRegistry = GetObject("winmgmts:\\.\root\default:StdRegProv")
oRegistry.GetStringValue HKEY_LOCAL_MACHINE, "SOFTWARE\ODBC\ODBCINST.INI\ODBC Drivers", driverName, isInstalled
i = 0
Dim selectorRule
For Each selectorRule In m_selectorRules
If(isInstalled <> "Installed") Then
Exit For
End If
If selectorRule.MatchName(driverName) Then
If (Not selectorRule.IsNativeClient) Or (selectorRule.IsNativeClient And protocolsAreIntersected) Then
Set oNameVersion = selectorRule.GetNameVersion(driverName)
If (selectorRule.CheckNameVersion(oNameVersion)) Then
Set oDriverVersion = selectorRule.GetDriverVersion(driverName)
If (selectorRule.CheckDriverVersion(oDriverVersion)) Then
selectorRule.AddDriver((new DriverItem)(driverName, oNameVersion, oDriverVersion, selectorRule))
Exit For
End If
End If
End If
End If
Next
End Sub
Private Sub ProcessSystemOdbcDrivers(protocolsAreIntersected)
Dim oRegistry, driverNames, paramValueTypes, i, oError
Set oError = New Error
Set oRegistry = GetObject("winmgmts:\\" & m_computerId & "\root\default:StdRegProv")
oRegistry.EnumValues HKEY_LOCAL_MACHINE, "SOFTWARE\ODBC\ODBCINST.INI\ODBC Drivers", driverNames, paramValueTypes
On Error Resume Next
Dim driverName
For Each driverName In driverNames
oError.Clear
Call ProcessOdbcDriver(driverName, protocolsAreIntersected)
oError.Save
If(oError.Number <> 0) Then
AddError(oError)
End If
Next
End Sub
Private Function GetNsNameWithHighestVersion()
Dim rootNs: rootNs = "winmgmts:{impersonationLevel=impersonate}!\\.\root\Microsoft\SqlServer"
Dim oWMI: Set oWMI = GetObject(rootNs)
Dim namespaces: Set namespaces = oWMI.ExecQuery("SELECT Name FROM __NAMESPACE WHERE Name LIKE 'ComputerManagement%'")
Dim currentName: currentName = ""
Dim objItem
For Each objItem In namespaces
If objItem.Name > currentName Then
currentName = objItem.Name
End If
Next
GetNsNameWithHighestVersion = rootNs & "\" & currentName
End Function
Private Sub GetNativeClientSettings(namespaceFullName)
Dim sNamespace, oWMI, objClasses, sState, sTargetComputer
Set oWMI = GetObject(namespaceFullName)
Set objClasses = oWMI.ExecQuery("SELECT FlagName, FlagValue FROM ClientSettingsGeneralFlag")
Dim objItem
For Each objItem in objClasses
Select Case objItem.FlagName
Case "Force protocol encryption"
m_ncli_ForceProtocolEncryption = objItem.FlagValue
Case "Trust Server Certificate"
m_ncli_TrustServerCertificate = objItem.FlagValue
End Select
Next
End Sub
Private Function GetEnabledNativeClientProtocols(namespaceFullName)
Dim oWMI: Set oWMI = GetObject(namespaceFullName)
Dim oQuery: Set oQuery = oWMI.ExecQuery("SELECT ProtocolName, ProtocolOrder FROM ClientNetworkProtocol")
If oQuery.Count > 0 Then
Dim protocolsArr: Set protocolsArr = New ArrayList
Dim protocolItem
For Each protocolItem In oQuery
If protocolItem.ProtocolOrder > 0 Then
protocolsArr.Add LCase(protocolItem.ProtocolName)
End If
Next
GetEnabledNativeClientProtocols = protocolsArr.ItemsArray
Else
GetEnabledNativeClientProtocols = Array()
End If
End Function
Private Sub AddError(oError)
Dim newSize
newSize = UBound(ErrorCollection) + 1
ReDim Preserve ErrorCollection(newSize)
ErrorCollection(newSize) = "[" & (oError.Number and 65535) & "][" & oError.Source & "] " & oError.Description
End Sub
Private Sub ResetState()
Dim pr
ErrorCollection = Array()
For Each pr In m_selectorRules
pr.ResetState()
Next
End Sub
Private Sub ThrowIfNotProcessed()
If Not m_processed Then
Call Err.Raise(SCRIPT_EVENT_ID, "", "Drivers are not processed. Call 'ProcessDrivers' first.")
End If
End Sub
Public Property Get HasErrors()
HasErrors = UBound(ErrorCollection) >= 0
End Property
Public Property Get DriverName()
ThrowIfNotProcessed
DriverName = m_selectedDriverName
End Property
Public Property Get UseFqdn()
ThrowIfNotProcessed
UseFqdn = m_ncli_ForceProtocolEncryption And Not m_ncli_TrustServerCertificate
End Property
Public Property Get ClientTcpProtocolEnabled()
ThrowIfNotProcessed
ClientTcpProtocolEnabled = m_ncli_tcpProtocolEnabled
End Property
End Class
Class UniqueCollection
Private m_dict
Public Default Function Init()
Set m_dict = CreateObject("Scripting.Dictionary")
Set Init = Me
End Function
Public Sub PutItem(item)
If Not m_dict.Exists(item) Then
m_dict.add item, ""
End If
End Sub
Public Function Exists(item)
Exists = m_dict.Exists(item)
End Function
Public Function GetItems()
GetItems = m_dict.Keys()
End Function
Public Sub Clear()
m_dict.RemoveAll()
End Sub
End Class
Class SqlServerTcpIpSettings
Private m_listenAllIPs
Private m_ipSettings
Public Default Function Init(listenAllIps, ipSettings)
m_listenAllIPs = listenAllIps
Set m_ipSettings = ipSettings
Set Init = Me
End Function
Public Property Get ListenAllIPs()
ListenAllIPs = m_listenAllIPs
End Property
Public Property Get IpSettings()
Set IpSettings = m_ipSettings
End Property
End Class
Function EscapeConnStringValue (ByVal strValue)
On Error Resume Next
Err.Clear
EscapeConnStringValue = "{" + Replace(strValue, "}", "}}") + "}"
End Function
Function EscapeWQLString (ByVal strValue)
ON ERROR RESUME NEXT
Err.Clear
EscapeWQLString = Replace(strValue, "'", "\'")
End Function
For i = 0 to Ubound(aReserved)
If vEncDec = "enc" Then
vString = Replace(vString,aReserved(i,0),aReserved(i,1))
End If
If vEncDec = "dec" Then
vString = Replace(vString,aReserved(i,1),aReserved(i,0))
End If
Next
furlEncode = vString
End Function
Function DelimitSqlIdentifier(identifier)
DelimitSqlIdentifier = "[" + Replace(identifier, "]", "]]") + "]"
End Function
Function SqlTcpPortIsEmpty(tcpPort)
SqlTcpPortIsEmpty = (tcpPort = "" Or tcpPort = "0")
End Function
Function GetDataSource(server, tcpPort)
Dim dataSource : dataSource = server
If Not SqlTcpPortIsEmpty(tcpPort) Then
Dim nameParts : nameParts = Split(dataSource, "\")
dataSource = nameParts(0) & "," & tcpPort
End If
GetDataSource = dataSource
End Function
Function GetConnectionString(driverName, dataSource, databaseName)
GetConnectionString = "Driver=" & EscapeConnStringValue(driverName) & ";Server=" & EscapeConnStringValue(dataSource) & ";Database=" & EscapeConnStringValue(databaseName) & ";Trusted_Connection=yes;"
End Function
Function GetEnabledSqlServerProtocols(namespaceName, computerName, instanceName)
Dim oWMI: Set oWMI = GetObject("winmgmts:\\" & computerName & "\root\Microsoft\SqlServer\" & namespaceName)
Dim oQuery: Set oQuery = oWMI.ExecQuery("SELECT ProtocolName, Enabled FROM ServerNetworkProtocol WHERE InstanceName = '"& EscapeWQLString(instanceName) &"'")
If oQuery.Count > 0 Then
Dim protocolsArr: Set protocolsArr = New ArrayList
Dim protocolItem
For Each protocolItem In oQuery
If protocolItem.Enabled Then
protocolsArr.Add LCase(protocolItem.ProtocolName)
End If
Next
GetEnabledSqlServerProtocols = protocolsArr.ItemsArray
Else
GetEnabledSqlServerProtocols = Array()
End If
End Function
Function GetSqlServerTcpIpSettings(instanceName, computerName)
ON ERROR RESUME NEXT
Dim oWMI, oQuery, tcpItem
Dim i, j
Dim uc: Set uc = (new UniqueCollection)()
Dim isListenAll: isListenAll = False
Dim ipSettings: Set ipSettings = CreateObject("Scripting.Dictionary")
Set oWMI = GetObject("winmgmts:\\" & computerName & "\root\Microsoft\SqlServer\" & SQL_WMI_NAMESPACE)
Set oQuery = oWMI.ExecQuery("SELECT * FROM ServerNetworkProtocolProperty WHERE ProtocolName = 'Tcp' AND InstanceName = '"& EscapeWQLString(instanceName) &"' AND PropertyName = 'ListenOnAllIPs'")
If oQuery.Count >0 Then
Dim isListenAllObj: Set isListenAllObj = GetFirstItemFromWMIQuery(oQuery)
If isListenAllObj.PropertyNumVal = 1 Then
isListenAll = True
End If
End If
Dim tcpPorts, tcpPort, processedPort
If isListenAll Then
Set oQuery = oWMI.ExecQuery("SELECT * FROM ServerNetworkProtocolProperty WHERE ProtocolName = 'Tcp' AND InstanceName = '"& EscapeWQLString(instanceName) &"' AND IPAddressName = 'IPAll' AND (PropertyName = 'TcpPort' OR PropertyName = 'TcpDynamicPorts') AND PropertyStrVal <> ''")
If oQuery.Count > 0 Then
For Each tcpItem In oQuery
tcpPorts = Split(tcpItem.PropertyStrVal,",")
For Each tcpPort In tcpPorts
processedPort = Trim(tcpPort)
If Not SqlTcpPortIsEmpty(processedPort) Then
uc.PutItem(processedPort)
End If
Next
Next
ipSettings.add "IPAll", uc.GetItems()
End If
Else
Set oQuery = oWMI.ExecQuery("SELECT * FROM ServerNetworkProtocolProperty WHERE ProtocolName = 'Tcp' AND InstanceName = '"& EscapeWQLString(instanceName) &"' AND IPAddressName <> '' AND PropertyName = 'Enabled' AND PropertyNumVal = 1")
Dim ipItem
If oQuery.Count > 0 Then
For Each ipItem In oQuery
Dim ipAddressName : ipAddressName = ipItem.IPAddressName
Dim oQuery2 : Set oQuery2 = oWMI.ExecQuery("SELECT * FROM ServerNetworkProtocolProperty WHERE ProtocolName = 'Tcp' AND InstanceName = '" + EscapeWQLString(instanceName) + "' AND IPAddressName = '" + EscapeWQLString(ipAddressName) + "' AND PropertyName = 'IpAddress' AND PropertyStrVal != ''")
If oQuery2.Count > 0 Then
Dim ipAddress : ipAddress = GetFirstItemFromWMIQuery(oQuery2).PropertyStrVal
Dim oQuery3: Set oQuery3 = oWMI.ExecQuery("SELECT * FROM ServerNetworkProtocolProperty WHERE ProtocolName = 'Tcp' AND InstanceName = '"& EscapeWQLString(instanceName) &"' AND IPAddressName = '"& EscapeWQLString(ipAddressName) &"' AND (PropertyName = 'TcpPort' OR PropertyName = 'TcpDynamicPorts') AND PropertyStrVal <> ''")
If oQuery3.Count > 0 Then
uc.Clear()
Dim portItem
For Each portItem In oQuery3
tcpPorts = Split(portItem.PropertyStrVal,",")
For Each tcpPort In tcpPorts
processedPort = Trim(tcpPort)
If Not SqlTcpPortIsEmpty(processedPort) Then
uc.PutItem(processedPort)
End If
Next
ipSettings.add ipAddress, uc.GetItems()
Next
End If
End If
Next
End If
End If
Set GetSqlServerTcpIpSettings = (new SqlServerTcpIpSettings)(isListenAll, ipSettings)
End Function
Function GetTcpPortsString(ByVal inputDataSource)
On Error Resume Next
Dim computerName, instanceName, pathArray
pathArray = Split(inputDataSource, "\")
computerName = pathArray(0)
instanceName = "MSSQLSERVER"
If (UBound(pathArray) > 0) Then
instanceName = pathArray(1)
End If
Dim tcpIpSettings: Set tcpIpSettings = GetSqlServerTcpIpSettings(instanceName, computerName)
Dim upc : Set upc = (new UniqueCollection)()
Dim ip, port
For Each ip In tcpIpSettings.IpSettings.Keys
For Each port In tcpIpSettings.IpSettings.Item(ip)
upc.PutItem port
Next
Next
GetTcpPortsString = Join(upc.GetItems(),", ")
End Function
Public Sub SqlTestDestination(dbConnection, serverName, instanceName, isADODB)
Dim destinationTestQuery
Dim queryServerName, queryInstanceName
On Error Goto 0
Dim serverNameWithoutDomain : serverNameWithoutDomain = serverName
destinationTestQuery = "select CAST(SERVERPROPERTY('MachineName') AS nvarchar(128)) as ServerName, @@servicename as InstanceName"
if 0 = Err.number then
Dim queryResult
if isADODB then
Set queryResult = dbConnection.ExecuteQueryTE(destinationTestQuery)
else
Set queryResult = dbConnection.Execute(destinationTestQuery)
end if
if Not queryResult.EOF then
queryServerName = UCase(queryResult("ServerName").Value)
queryInstanceName = UCase(queryResult("InstanceName").Value)
Dim dotPosition : dotPosition = InStr(1, serverName, ".")
if Not IsNull(dotPosition) And (dotPosition > 0) then
serverNameWithoutDomain = Left(serverName, dotPosition - 1)
end if
if (UCase(serverNameWithoutDomain) = queryServerName) And (UCase(instanceName) = queryInstanceName) then
Exit Sub
end if
end if
dbConnection.Close()
Err.Raise 16389, "", "Connection target check failed: connected to " & serverNameWithoutDomain & "\" & instanceName & ", but got " & queryServerName & "\" & queryInstanceName & "."
end if
End Sub
Sub TryToConnectAndValidate(connectionObj, connectionString, timeout, machineName, instanceName, isADODB)
On Error GoTo 0
If isADODB Then
connectionObj.Open connectionString, "", timeout
Else
if (connectionObj.Mode <> 0) then
connectionObj.Close()
end if
connectionObj.ConnectionTimeout = timeout
connectionObj.Open connectionString
End If
SqlTestDestination connectionObj, machineName, instanceName, isADODB
End Sub
Function FormatConnectionErrorMessage(dataSource, lastError)
FormatConnectionErrorMessage = "Connection to data source '" & dataSource & "' failed: " & lastError.Description
End Function
Function SmartConnectWithoutSQLADODB(ByVal inputDataSource, ByVal tcpPort, ByVal machineName, ByVal instanceName, ByVal databaseName)
On Error Resume Next
Dim dbMasterConnection, dataSource, connectionString, errorMessage
Dim targetName : targetName = inputDataSource
Dim lastError : Set lastError = new Error
Dim errorMessageList : Set errorMessageList = New ArrayList
Dim ds: Set ds = New DriverSelector
Dim enabledServerProtocols: enabledServerProtocols = GetEnabledSqlServerProtocols(SQL_WMI_NAMESPACE, machineName, instanceName)
ds.ProcessDrivers(enabledServerProtocols)
Dim selectedDriverName: selectedDriverName = ds.DriverName
Dim useFqdn: useFqdn = ds.UseFqdn
Dim hasErrors: hasErrors = ds.HasErrors
Set dbMasterConnection = CreateObject("ADODB.Connection")
'Connect using Sql Browser
dataSource = GetDataSource(inputDataSource, "")
connectionString = GetConnectionString(selectedDriverName, dataSource, databaseName)
lastError.Clear
TryToConnectAndValidate dbMasterConnection, connectionString, 15, machineName, instanceName, False
lastError.Save
If lastError.Number = 0 Then
Set SmartConnectWithoutSQLADODB = dbMasterConnection
Exit Function
Else
errorMessageList.Add FormatConnectionErrorMessage(dataSource, lastError)
End If
'Try to connect through tcp/ip protocol only if it is enabled
If ArrayContains(enabledServerProtocols, "tcp") And ds.ClientTcpProtocolEnabled Then
Dim dsComputerName: dsComputerName = Split(inputDataSource, "\")(0)
Dim tcpIpSettings : Set tcpIpSettings = GetSqlServerTcpIpSettings(instanceName, dsComputerName)
If useFqdn Then
targetName = machineName
Else
targetName = dsComputerName
End if
Dim ip, port
'Use ports configured for all interfaces
If tcpIpSettings.ListenAllIPs Then
For Each port In tcpIpSettings.IpSettings.item("IPAll")
dataSource = GetDataSource(targetName, port)
connectionString = GetConnectionString(selectedDriverName, dataSource, databaseName)
lastError.Clear
TryToConnectAndValidate dbMasterConnection, connectionString, 10, machineName, instanceName, False
lastError.Save
If lastError.Number = 0 Then
Set SmartConnectWithoutSQLADODB = dbMasterConnection
Exit Function
Else
errorMessageList.Add FormatConnectionErrorMessage(dataSource, lastError)
End If
Next
Else
'Use one port from each interface
Dim upc : Set upc = (new UniqueCollection)()
For Each ip In tcpIpSettings.IpSettings.Keys
port = tcpIpSettings.IpSettings.Item(ip)(0)
If Not upc.Exists(port) Then
upc.PutItem port
dataSource = GetDataSource(targetName, port)
connectionString = GetConnectionString(selectedDriverName, dataSource, databaseName)
lastError.Clear
TryToConnectAndValidate dbMasterConnection, connectionString, 10, machineName, instanceName, False
lastError.Save
If lastError.Number = 0 Then
Set SmartConnectWithoutSQLADODB = dbMasterConnection
Exit Function
Else
errorMessageList.Add FormatConnectionErrorMessage(dataSource, lastError)
End If
End If
Next
'Go through all interfaces and ports
If Not useFqdn Then
For Each ip In tcpIpSettings.IpSettings.Keys
For Each port In tcpIpSettings.IpSettings.Item(ip)
dataSource = GetDataSource(ip, port)
connectionString = GetConnectionString(selectedDriverName, dataSource, databaseName)
lastError.Clear
TryToConnectAndValidate dbMasterConnection, connectionString, 10, machineName, instanceName, False
lastError.Save
If lastError.Number = 0 Then
Set SmartConnectWithoutSQLADODB = dbMasterConnection
Exit Function
Else
errorMessageList.Add FormatConnectionErrorMessage(dataSource, lastError)
End If
Next
Next
End If
End If
End If
GlobalErrorList.Add "Cannot connect to the target Sql Server instance. Connection log:" & vbNewLine & Join(errorMessageList.ItemsArray, vbNewLine)
Set SmartConnectWithoutSQLADODB = Nothing
End Function
Function SmartConnect(cnADOConnection, inputDataSource, tcpPort, machineName, instanceName, databaseName)
On Error Resume Next
Dim dataSource, connectionString, errorMessage
Dim targetName : targetName = serverName
Dim lastError : Set lastError = new Error
Dim errorMessageList : Set errorMessageList = New ArrayList
Dim ds: Set ds = New DriverSelector
Dim enabledServerProtocols: enabledServerProtocols = GetEnabledSqlServerProtocols(SQL_WMI_NAMESPACE, machineName, instanceName)
ds.ProcessDrivers(enabledServerProtocols)
Dim selectedDriverName: selectedDriverName = ds.DriverName
Dim useFqdn: useFqdn = ds.UseFqdn
Dim hasErrors: hasErrors = ds.HasErrors
'Connect using Sql Browser
dataSource = GetDataSource(inputDataSource, "")
connectionString = GetConnectionString(selectedDriverName, dataSource, databaseName)
lastError.Clear
TryToConnectAndValidate cnADOConnection, connectionString, 15, machineName, instanceName, True
lastError.Save
If lastError.Number = 0 Then
SmartConnect = True
Exit Function
Else
errorMessageList.Add FormatConnectionErrorMessage(dataSource, lastError)
End If
'Try to connect through tcp/ip protocol only if it is enabled
If ArrayContains(enabledServerProtocols, "tcp") And ds.ClientTcpProtocolEnabled Then
Dim dsComputerName: dsComputerName = Split(inputDataSource, "\")(0)
Dim tcpIpSettings : Set tcpIpSettings = GetSqlServerTcpIpSettings(instanceName, dsComputerName)
If useFqdn Then
targetName = machineName
Else
targetName = dsComputerName
End if
Dim ip, port
'Use ports configured for all interfaces
If tcpIpSettings.ListenAllIPs Then
For Each port In tcpIpSettings.IpSettings.item("IPAll")
dataSource = GetDataSource(targetName, port)
connectionString = GetConnectionString(selectedDriverName, dataSource, databaseName)
lastError.Clear
TryToConnectAndValidate cnADOConnection, connectionString, 10, machineName, instanceName, True
lastError.Save
If lastError.Number = 0 Then
SmartConnect = True
Exit Function
Else
errorMessageList.Add FormatConnectionErrorMessage(dataSource, lastError)
End If
Next
Else
'Use one port from each interface
Dim upc : Set upc = (new UniqueCollection)()
For Each ip In tcpIpSettings.IpSettings.Keys
port = tcpIpSettings.IpSettings.Item(ip)(0)
If Not upc.Exists(port) Then
upc.PutItem port
dataSource = GetDataSource(targetName, port)
connectionString = GetConnectionString(selectedDriverName, dataSource, databaseName)
lastError.Clear
TryToConnectAndValidate cnADOConnection, connectionString, 10, machineName, instanceName, True
lastError.Save
If lastError.Number = 0 Then
SmartConnect = True
Exit Function
Else
errorMessageList.Add FormatConnectionErrorMessage(dataSource, lastError)
End If
End If
Next
'Go through all interfaces and ports
If Not useFqdn Then
For Each ip In tcpIpSettings.IpSettings.Keys
For Each port In tcpIpSettings.IpSettings.Item(ip)
dataSource = GetDataSource(ip, port)
connectionString = GetConnectionString(selectedDriverName, dataSource, databaseName)
lastError.Clear
TryToConnectAndValidate cnADOConnection, connectionString, 10, machineName, instanceName, True
lastError.Save
If lastError.Number = 0 Then
SmartConnect = True
Exit Function
Else
errorMessageList.Add FormatConnectionErrorMessage(dataSource, lastError)
End If
Next
Next
End If
End If
End If
GlobalErrorList.Add "Cannot connect to the target Sql Server instance. Connection log:" & vbNewLine & Join(errorMessageList.ItemsArray, vbNewLine)
SmartConnect = False
End Function
'#Include File:DatabaseHelpers.vbs
Function ExtractHostNameFromEndpoint(ByVal sEndpoint)
If sEndpoint = "" Then
ExtractHostNameFromEndpoint = ""
Exit Function
End If
Dim oRegEx, oMatches
Set oRegEx = MomCreateObject("VBScript.RegExp")
oRegEx.Pattern = "://(.+):"
Set oMatches = oRegEx.Execute(sEndpoint)
If oMatches.Count > 0 Then
If oMatches(0).SubMatches.Count > 0 Then
ExtractHostNameFromEndpoint = oMatches(0).SubMatches(0)
Else
ExtractHostNameFromEndpoint = sEndpoint
End If
Else
ExtractHostNameFromEndpoint = sEndpoint
End If
End Function
Function GetMirroringLevelName(ByVal nSafetyLevel, ByVal sWitnessName)
GetMirroringLevelName = "Unknown state"
If nSafetyLevel = 1 Then
GetMirroringLevelName = "High-performance mode"
Else
If sWitnessName = "" Then
GetMirroringLevelName = "High-safety mode without automatic failover"
Else
GetMirroringLevelName = "High-safety mode with automatic failover"
End If
End If
End Function
Function IsExcluded(ByVal sDatabase, ByVal sExcludeList)
Dim aExcludes, bMatch, nIndex
bMatch = False
If Trim(sExcludeList) = "*" Then
bMatch = True
Else
aExcludes = Split(sExcludeList, ",")
For nIndex = 0 To UBound(aExcludes)
If LCase(sDatabase) = LCase(Trim(aExcludes(nIndex))) Then
bMatch = True
End If
Next
End If
IsExcluded = bMatch
End Function