远程桌面连接支持网络级身份验证修复脚本 vbs

本文链接：https://blog.csdn.net/tanaya/article/details/51503011

WIN7系统有时候很奇怪，远程桌面一点连接就异常崩溃了，纠结此问题好久，在网上找到这个修复脚本，稍微修改了几个地方。

' ============================================
' CheckCredSSP.vbs
'
' Verifies that the settings necessary for CredSSP are enabled on XP clients
' As per http://support.microsoft.com/kb/951608
'
' Checks if DisableRootAutoUpdate policy setting is enabled to avoid a 30-second
' delay when clients have no access to Windows Update and NLA is used
'
' Displays a summary of any credential delegation policy settings found
'
'远程桌面连接支持网络级身份验证, WIN7 操作系统也可以使用
' ============================================
const HKEY_LOCAL_MACHINE = &H80000002
const REG_SZ = 1
strComputer = "."

' Variables to hold results of key enumeration and the value types
arrNames = Array()
arrTypes = Array()

' Variables to hold values for REG_MULTI_SZ, REG_SZ and REG_DWORD data
arrValues = Array()
strValue = ""
dwValue = 0

' Object to allow us access to the registry
Set objReg=GetObject( _
    "winmgmts:{impersonationLevel=impersonate}!\\" & _
   strComputer & "\root\default:StdRegProv")

' ============================================
' Check for (and add if necessary) tspkg in REG_MULTI_SZ value
' ============================================
strKeyPath = "SYSTEM\CurrentControlSet\Control\Lsa"
strValueName = "Security Packages"
bPresent_tspkg = FALSE

If ( objReg.GetMultiStringValue( HKEY_LOCAL_MACHINE, strKeyPath, strValueName, arrValues ) <> 0 ) Then
	' Failed to read the value, exit early
	'WScript.Echo "打开值失败: " & strValueName
	'WScript.Quit
	ReDim arrValues(0)
	arrValues(0) = "tspkg"
	iError = objReg.SetMultiStringValue( HKEY_LOCAL_MACHINE, strKeyPath, strValueName, arrValues )
	If ( iError <> 0 ) Then
		' Failed to write the value, exit early
		WScript.Echo "写入值失败: " & strValueName & vbCrLf & "错误代码: " & iError
		WScript.Quit
	End If	
Else
	For Each strElement in arrValues
	  If strElement = "tspkg" Then bPresent_tspkg = TRUE
	Next

	If Not bPresent_tspkg Then
	  ReDim Preserve arrValues( UBound( arrValues ) + 1 )
	  arrValues( UBound( arrValues ) ) = "tspkg"
	  iError = objReg.SetMultiStringValue( HKEY_LOCAL_MACHINE, strKeyPath, strValueName, arrValues )
	  If ( iError <> 0 ) Then
		' Failed to write the value, exit early
		WScript.Echo "写入值失败: " & strValueName & vbCrLf & "错误代码: " & iError
		WScript.Quit
	  End If
	End If
End If


' ============================================
' Check for (and add if necessary) credssp.dll in REG_SZ value
' ============================================
strKeyPath = "SYSTEM\CurrentControlSet\Control\SecurityProviders"
strValueName = "SecurityProviders"
bPresent_credssp = FALSE

If ( objReg.GetStringValue( HKEY_LOCAL_MACHINE, strKeyPath, strValueName, strValue ) <> 0 ) Then
	' Failed to read the value, exit early
	'WScript.Echo "打开值失败: " & strValueName
	'WScript.Quit
	strValue = "credssp.dll"
	iError = objReg.SetStringValue( HKEY_LOCAL_MACHINE, strKeyPath, strValueName, strValue )
	If ( iError <> 0 ) Then
		' Failed to write the value, exit early
		WScript.Echo "写入值失败: " & strValueName & vbCrLf & "错误代码: " & iError
		WScript.Quit
	End If 
Else
	' Convert the comma-separated string into an array of strings to check each element
	arrValues = ConvertStrToArr( strValue )
	For Each strElement in arrValues
	  ' We use LTrim() to ignore leading spaces (i.e. spaces after commas)
	  If LTrim( strElement ) = "credssp.dll" Then bPresent_credssp = TRUE
	Next

	If Not bPresent_credssp Then
	  If ( strValue <> "" ) Then strValue = strValue & ", "
	  strValue = strValue & "credssp.dll"
	  iError = objReg.SetStringValue( HKEY_LOCAL_MACHINE, strKeyPath, strValueName, strValue )
	  If ( iError <> 0 ) Then
		' Failed to write the value, exit early
		WScript.Echo "写入值失败: " & strValueName & vbCrLf & "错误代码: " & iError
		WScript.Quit
	  End If
	End If
End If


' ============================================
' Check for DisableRootAutoUpdate = 1
' ============================================
strKeyPath = "SOFTWARE\Policies\Microsoft\SystemCertificates\AuthRoot"
strValueName = "DisableRootAutoUpdate"

strPolicyOutput = vbCrLf & vbCrLf &_
                  "DisableRootAutoUpdate policy setting "

' Does the value exist and is non-zero?
If ( objReg.GetDWORDValue( HKEY_LOCAL_MACHINE, strKeyPath, strValueName, dwValue ) = 0 ) Then
  If ( dwValue <> 0 ) Then
    strPolicyOutput = strPolicyOutput & "found : ENABLED" & vbCrLf & vbCrLf
  Else
    strPolicyOutput = strPolicyOutput & "found : DISABLED" & vbCrLf & vbCrLf
  End If
Else
  strPolicyOutput = strPolicyOutput & "NOT found" & vbCrLf &_
                    "Consider enabling the following policy setting if hitting a ~30 second delay:" & vbCrLf &_
                    "Administrative Templates > System > Internet Communication Management > Internet Communication Settings" & vbCrLf &_
                    "Turn off Automatic Root Certificates Update" & vbCrLf & vbCrLf
End If


' ============================================
' Check for any policy settings relating to credential delegation
' ============================================
strKeyPath = "SOFTWARE\Policies\Microsoft\Windows\CredentialsDelegation"

If ( objReg.EnumValues( HKEY_LOCAL_MACHINE, strKeyPath, arrNames, arrTypes ) <> 0 ) Then
  strPolicyOutput = strPolicyOutput & "Found no credential delegation policy settings (e.g. SSO, saved credentials)" & vbCrLf &_
                    "Recommend reading KB951608 if SSO is required." & vbCrLf &_
                    "Or check under:" & vbCrLf &_
                    "Administrative Templates > System > Credentials Delegation" & vbCrLf
Else
  strPolicyOutput = strPolicyOutput & "Found credential delegation policy settings..." & vbCrLf

  strPolicyCheck = CheckPolicy( "DenyDefaultCredentials" )
  If ( strPolicyCheck = "" ) Then
    strPolicyCheck = CheckPolicy( "AllowDefaultCredentials" )
    strPolicyCheck = strPolicyCheck & CheckPolicy( "AllowDefCredentialsWhenNTLMOnly" )
  Else
    strPolicyOutput = strPolicyOutput & vbCrLf & "DEFAULT credential delegation (SSO) explicitly DENIED by policy" & vbCrLf
  End If
  strPolicyOutput = strPolicyOutput & strPolicyCheck

  strPolicyCheck = CheckPolicy( "DenySavedCredentials" )
  If ( strPolicyCheck = "" ) Then
    strPolicyCheck = CheckPolicy( "AllowSavedCredentials" )
    strPolicyCheck = strPolicyCheck & CheckPolicy( "AllowSavedCredentialsWhenNTLMOnly" )
  Else
    strPolicyOutput = strPolicyOutput & vbCrLf & "SAVED credential delegation explicitly DENIED by policy" & vbCrLf
  End If
  strPolicyOutput = strPolicyOutput & strPolicyCheck
End If

' ============================================
' Display summary of actions
' ============================================
strOutput = "Security Packages - tspkg : "

If Not bPresent_tspkg Then
  strOutput = strOutput & "存在 (已增加)"
Else
  strOutput = strOutput & "存在"
End If

strOutput = strOutput & vbCrLf & vbCrLf &_
            "SecurityProviders - credssp.dll : "

If Not bPresent_credssp Then
  strOutput = strOutput & "存在 (已增加)"
Else
  strOutput = strOutput & "存在"
End If

WScript.Echo strOutput & strPolicyOutput

' ============================================
' Function to convert a comma-separated string into an array of strings
' ============================================
Function ConvertStrToArr ( strInput )
  Set objRegExp = CreateObject( "VBScript.RegExp" )
  objRegExp.IgnoreCase = TRUE
  objRegExp.Global = TRUE
  objRegExp.Pattern = ",(?=([^']*'[^']*')*(?![^']*'))"
  ConvertStrToArr = Split( objRegExp.Replace(strInput, "\b"), "\b" )
End Function

' ============================================
' Function to check for a credential delegation policy setting
' ============================================
Function CheckPolicy ( strPolicy )
  dwValue = 0
  If ( objReg.GetDWORDValue( HKEY_LOCAL_MACHINE, strKeyPath, strPolicy, dwValue ) = 0 ) Then
    CheckPolicy = strPolicy & " = " & dwValue
    If ( dwValue <> 0 ) Then
      CheckPolicy = CheckPolicy & " (ENABLED)" & vbCrLf
      If ( objReg.EnumValues( HKEY_LOCAL_MACHINE, strKeyPath & "\" & strPolicy, arrNames, arrTypes ) = 0 ) Then
        If IsArray( arrNames ) Then
          For i = 0 To UBound( arrNames )
            If ( arrTypes( i ) = REG_SZ ) Then
              If ( objReg.GetStringValue( HKEY_LOCAL_MACHINE, strKeyPath & "\" & strPolicy, arrNames( i ), strValue ) <> 0 ) Then
                ' Failed to read the value, exit early
                 WScript.Echo "打开值失败: " & arrNames( i )
                 WScript.Quit
              End If
              CheckPolicy = CheckPolicy & " > " & strValue & vbCrLf
            End If
          Next
        Else
          CheckPolicy = CheckPolicy & " > [no SPNs specified]" & vbCrLf
        End If
      Else
        CheckPolicy = CheckPolicy & " > [no SPNs specified]" & vbCrLf
      End If
    Else
      CheckPolicy = CheckPolicy & " (DISABLED)" & vbCrLf
    End If
  End If
End Function

原来是 HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\SecurityProviders 下面的 SecurityProviders 值 'credssp.dll' 没有