Dx21 - Script Library

Home

eZine

Coding

Software

Network Admin.

Home > Coding > Libraries > Script Library > View Item Info

	Back
	Scripting References

Discover MTU Value

Discovers the local computer's best maximum transmission unit (MTU) value for the local LAN and provides the chance to optionally apply to the system.

Option Explicit

'////////////////////////////////////////////////////
'Determine and Set MTU Value
'File Name: GetMTU.VBS
'Script Version: 1.0.0
'Last Edit: 05/26/09
'Developer: Dx21, LLC
'////////////////////////////////////////////////////

Const HKEY_LOCAL_MACHINE  	=	&H80000002
Const REG_SZ				= 	1
Const REG_DWORD				=	4
Const REG_MULTI_SZ			=	7
Const MAXMTU 				= 	1500		'http://en.wikipedia.org/wiki/Maximum_transmission_unit
Const MINMTU				=	575
Const INCREMENTS			=	10
Const bUpdateNDISWAN		= 	False		'Toggle to have the script create/update the Ndiswan

Dim objShell: Set objShell = CreateObject("WScript.Shell")
Dim objRE: Set objRE = New clsRegEdit

Dim IPAddress, DefaultGateway, ServiceName
Dim dtStart

Dim objExec, intMTU, RetVal, intCounter
Dim bConsole:	bConsole = (InStr(1, UCase(WScript.FullName), "CSCRIPT") >0)

If GetLocalIPInformation = False Then CleanEnv -1
dtStart = Now

'Find initial value
For intCounter = MAXMTU To MINMTU Step (INCREMENTS * -1)
	If bConsole Then WScript.Echo "Macro Evaluation: " & intCounter
	
	Set objExec = objShell.Exec("%comspec% /c ping -n 1 -f -l " & intCounter & " " & DefaultGateway)
	RetVal = objExec.StdOut.ReadAll
	
	If InStr(1, RetVal, "Packet needs to be fragmented", vbTextCompare) = 0 Then Exit For
Next
intMTU = intCounter

'Find max value
If intMTU < MAXMTU Then
	For intCounter = intMTU+1 To (intMTU + (INCREMENTS-1))
		if bConsole Then WScript.Echo "Micro Evaluation: " & intCounter
		
		Set objExec = objShell.Exec("%comspec% /c ping -n 1 -f -l " & intCounter & " " & DefaultGateway)
		RetVal = objExec.StdOut.ReadAll
		
		If InStr(1, RetVal, "Packet needs to be fragmented", vbTextCompare) > 0 Then Exit For
	Next
	intMTU = intCounter -1
End If

If bConsole Then WScript.Echo "Discovery time: " & DateDiff("s",dtStart,Now) & " seconds"

'Report or actually write
If MsgBox("The Correct MTU for this computer is " & intMTU & VbCrLf & VbCrLf & "Would you like this setting applied to this computer?", vbYesNo+vbQuestion,"Value Found") = vbYes Then
	objRE.WriteRegEntry HKEY_LOCAL_MACHINE, "SYSTEM\CurrentControlSet\Services\Tcpip\Parameters\Interfaces\" & ServiceName, "MTU", intMTU, REG_DWORD
	
	If bUpdateNDISWAN Then
		objRE.WriteRegEntry HKEY_LOCAL_MACHINE, "SYSTEM\CurrentControlSet\Services\Ndiswan\Parameters\Protocols\0", "ProtocolType", 2048, REG_DWORD
		objRE.WriteRegEntry HKEY_LOCAL_MACHINE, "SYSTEM\CurrentControlSet\Services\Ndiswan\Parameters\Protocols\0", "ProtocolMTU", intMTU, REG_DWORD	
	End If
	
	MsgBox "The values have been set.  You will need to reboot your computer before they take effect.", vbOKOnly+vbInformation,"Done"
End If

CleanEnv 0

Function GetLocalIPInformation()
	'On Error Resume Next: Err.Clear 
	
	Const R1 = "SOFTWARE\Microsoft\Windows NT\CurrentVersion\NetworkCards"
	Const R2 = "SYSTEM\CurrentControlSet\Services\Tcpip\Parameters\Interfaces"
	
	Dim CardID: CardID = objRE.EnumKey(HKEY_LOCAL_MACHINE,R1,0)
	ServiceName = objRE.ReadRegEntry(HKEY_LOCAL_MACHINE,R1 & "\" & CardID,"ServiceName", REG_SZ)
	
	Dim TempVal: TempVal = objRE.ReadRegEntry(HKEY_LOCAL_MACHINE,R2 & "\" & ServiceName, "IPAddress", REG_MULTI_SZ)
	IPAddress = TempVal(0)
	If IPAddress = "0.0.0.0" Then
		TempVal = objRE.ReadRegEntry(HKEY_LOCAL_MACHINE,R2 & "\" & ServiceName, "DhcpIPAddress", REG_SZ)
		IPAddress = TempVal
	End If
	
	TempVal = objRE.ReadRegEntry(HKEY_LOCAL_MACHINE,R2 & "\" & ServiceName, "DefaultGateway", REG_MULTI_SZ)
	If UBound(TempVal) = -1 Then
		TempVal = objRE.ReadRegEntry(HKEY_LOCAL_MACHINE,R2 & "\" & ServiceName, "DhcpDefaultGateway", REG_MULTI_SZ)
		DefaultGateway = TempVal(0)
	Else
		DefaultGateway = TempVal(0)
	End If
	
	GetLocalIPInformation = ((Err.Number = 0) And (Len(IPAddress) > 0) And (Len(DefaultGateway) > 0))
End Function

Sub CleanEnv(intExitCode)
	On Error Resume Next
	
	Set objShell = Nothing
	
	WScript.Quit intExitCode
End Sub

'////////////////////////////////////////////////////
'Copyright © 2009 Dx21, LLC
'			   a Washingtion Limited Liability Company
'			   All Rights Reserved
'
'Use of this script is subject to the terms and conditions
'as listed in our public Copyright and Disclamer statments.
'Those statements must be agreed to prior to use of this
'script:
'
'http://dx21.com/home/tos.aspx
'////////////////////////////////////////////////////

Class clsRegEdit
	'////////////////////////////////////////////////////
	'WMI Registry Manipulations Class
	'File Name: clsRegEdit
	'Script Version: 1.1.2
	'Last Edit: 04/28/2009
	'Developer: Dx21, LLC
	'////////////////////////////////////////////////////

' "Constants"
	Dim HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_LOCAL_MACHINE
	Dim HKEY_USERS, HKEY_CURRENT_CONFIG, HKEY_DYN_DATA
	
	Dim REG_SZ, REG_EXPAND_SZ, REG_BINARY, REG_DWORD, REG_DWORD_BIG_ENDIAN
	Dim REG_LINK, REG_MULTI_SZ, REG_RESOURCE_LIST, REG_FULL_RESOURCE_DESCRIPTOR
	Dim REG_RESOURCE_REQUIREMENTS_LIST, REG_QWORD	
	
	Dim KEY_QUERY_VALUE, KEY_SET_VALUE, KEY_CREATE_SUB_KEY, KEY_ENUMERATE_SUB_KEYS
	Dim KEY_NOTIFY, KEY_CREATE, DELETE, READ_CONTROL, WRITE_DAC, WRITE_OWNER 
	
	Dim W95, W98, W98SE, WME, WNT4, W2000, WXP, W2003, WV, W2008, W7
   
	'---------------------------------------------------------------------------------
	'Private Objects
	Dim objWMI, objFSO, objShell
				   
	'---------------------------------------------------------------------------------
	'Private Properties
	Dim strLastComputerName, strComputerOS, strComputerCaption
	Dim bConvertToHex, bDUPreLoad, bDUOpen
			   
	'---------------------------------------------------------------------------------
	'Class Events
			   
	Private Sub Class_Initialize()	  
		Set objShell = CreateObject("WScript.Shell")
		Set objFSO = CreateObject("Scripting.FileSystemObject")
		
		bDUPreLoad = False
		bDUOpen = False
		 
		ComputerName = "."
		bConvertToHex = True
				
		'General Values		
		HKEY_CLASSES_ROOT   			= &H80000000
		HKEY_CURRENT_USER   			= &H80000001
		HKEY_LOCAL_MACHINE  			= &H80000002
		HKEY_USERS          			= &H80000003
		HKEY_CURRENT_CONFIG 			= &H80000005
		HKEY_DYN_DATA       			= &H80000006 ' Windows 95/98 only

REG_SZ							=  1
		REG_EXPAND_SZ                  	=  2
		REG_BINARY                     	=  3
		REG_DWORD                      	=  4
		REG_DWORD_BIG_ENDIAN           	=  5 ' Not supported
		REG_LINK                       	=  6 ' Not supported
		REG_MULTI_SZ                   	=  7
		REG_RESOURCE_LIST              	=  8 ' Not supported
		REG_FULL_RESOURCE_DESCRIPTOR   	=  9 ' Not supported
		REG_RESOURCE_REQUIREMENTS_LIST 	= 10 ' Not supported
		REG_QWORD                      	= 11 ' Windows Vista/Server 2008/Win 7 only
		
		KEY_QUERY_VALUE					= &H00000001
		KEY_SET_VALUE					= &H00000002
		KEY_CREATE_SUB_KEY				= &H00000004
		KEY_ENUMERATE_SUB_KEYS			= &H00000008
		KEY_NOTIFY						= &H00000010
		KEY_CREATE						= &H00000020
		DELETE							= &H00010000
		READ_CONTROL					= &H00020000
		WRITE_DAC						= &H00040000
		WRITE_OWNER 					= &H00080000
		
		'http://en.wikipedia.org/wiki/Microsoft_Windows
		W95		= "4.0.950"
		W98		= "4.10.1998"
		W98SE	= "4.10.2222"
		WME		= "4.90.3000"
		WNT4	= "4.0.1381"
		W2000	= "5.0.2195"
		WXP 	= "5.1.2600"
		W2003  	= "5.2.3790"
		WV		= "V6.0.6001"
		W2008 	= "S6.0.6001"
		W7		= "6.1.7000"
	End Sub
   
	Private Sub Class_Terminate()
		On Error Resume Next: Err.Clear
		
		If bDUOpen = True Then 
			bDUPreLoad = False
			UnloadDefaultUserRegistry True
		End If
	   
		Set objWMI = Nothing
		Set objShell = Nothing
		Set objFSO = Nothing
	End Sub
			   
	'---------------------------------------------------------------------------------
	'Public Properties
	
	Public Property Get ComputerOSVersion
		ComputerOSVersion = strComputerOS
	End Property
			   
	Public Property Let ComputerName(strTargetComputerName)
		Dim bIP, bNetBIOS, bDNS, bValidName
		bValidName = False
	   
		'Validate passed information
		Dim objRE: Set objRE = New RegExp
		objRE.IgnoreCase = True
		objRE.Global = True
		
		'Local
		If strTargetComputerName = "." Then
			bValidName = True
		Else
			'Test conditions - not exhaustive
		   
			'Is it an IP Address
			objRE.Pattern = "\b(?:(?:25[0-5]|2[0-4][0-9]|[01]?[0-9][0-9]?)\.){3}(?:25[0-5]|2[0-4][0-9]|[01]?[0-9][0-9]?)\b"
			bIP = objRE.Test(strTargetComputerName)
		   
			'NetBIOS Name (rough)
			objRE.Pattern = "^[A-Za-z0-9\-]{3,16}$"
			bNetBIOS = objRE.Test(strTargetComputerName)
 
			'DNS Pattern
			objRE.Pattern = "^[A-Za-z0-9\-]{3,16}\.[A-Za-z0-9\-]{3,16}\.[A-Za-z]{2,4}$"
			bDNS = objRE.Test(strTargetComputerName)
		   
			If bIP Or bNetBIOS Or bDNS Then bValidName = True
		End If
		
		If Not bValidName Then
			'invalid name - error out
			RaiseError "ComputerName1", "Invalid computer name / IP passed"
			Exit Property
		End If
			
		'We only have to take action if we are not connected to specified host
		If strTargetComputerName = strLastComputerName Then Exit Property
				   
		'OK - new connection
		strLastComputerName = strTargetComputerName
	   
		'Connect to specified host's WMI Namespace
		On Error Resume Next: Err.Clear
	   
		Set objWMI = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strTargetComputerName & "\root\default:StdRegProv")
		If Err.Number <> 0 Then
			strLastComputerName = ""
			RaiseError "ComputerName2", "Could not connect to specified computer"
			Exit Property
		End If
		
		'Determine OS - helps set registry type limits
		strComputerOS = ""
		
		Dim objW, colOS, objOS
		Set objW = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strTargetComputerName & "\root\CIMV2")
		Set colOS = objW.ExecQuery("SELECT Version, Caption FROM Win32_OperatingSystem")
		For Each objOS In colOS
			strComputerCaption = objOS.Caption
			'Fix for Vista / 2008 save version information
			If objOS.Version = "6.0.6001" Then
				If InStr(1, UCase(strComputerCaption), "VISTA") > 0 Then
					strComputerOS = "V6.0.6001"
				Else
					strComputerOS = "S6.0.6001"
				End If
			Else
				strComputerOS = objOS.Version
			End If
		Next
		Set objW = Nothing
		Set colOS = Nothing
		Set objOS = Nothing
		
		If strComputerOS = "" Or Err.Number <> 0 Then RaiseError "ComputerName3", "Could not determine Windows version"
	End Property
	Public Property Get ComputerName
		ComputerName = strLastComputerName
	End Property
		
	Public Property Let ReturnBinaryAsHEX(bValue)
		bConvertToHex = CBool(bValue)
	End Property
	Public Property Get ReturnBinaryAsHEX
		ReturnBinaryAsHEX = bConvertToHex
	End Property
	
	Public Property Let KeepDefaultUserProfileOpen(bValue)
		bDUPreLoad = bValue
	End Property
	Public Property Get KeepDefaultUserProfileOpen
		KeepDefaultUserProfileOpen = bDUPreLoad
	End Property
	
	'---------------------------------------------------------------------------------
	'Private Functions
			   
	Private Function HexToDec(HexValue)
	'Converts A Hex number into a Decimal value
		Const HexBase = "0123456789ABCDEF"
			   
		Dim Sum, DigitCount, MultiBase
		Dim Index, HexDigit, RetVal, HexPosition
			   
		Sum = 0
		DigitCount = 0
		MultiBase = 1
			   
		For Index = Len(HexValue) To 1 Step -1
			HexDigit = Mid(HexValue, Index, 1)
			HexPosition = InStr(1, HexBase, HexDigit)-1
			RetVal = RetVal + (HexPosition*MultiBase)
			MultiBase = MultiBase * 16
		Next
			   
		HexToDec = RetVal
	End Function
			   
	Private Function DelKeyEnum(ByVal dblRegHive, ByVal strKeyPath)
		Const vbVarArray = 8204
				   
		Dim colKeys, objKey, strNewKey
		Dim intRetVal
				   
		objWMI.EnumKey dblRegHive, strKeyPath, colKeys
			   
		If VarType(colKeys) = vbVarArray Then
			For Each objKey In colKeys
				'Format Display
				strNewKey = strKeyPath & "\" & objKey
			   
				'Enumerate children
				If DelKeyEnum(dblRegHive, strNewKey) = False Then
					DelKeyEnum = False
					Exit Function
				End If
			Next
		End If
				   
		intRetVal = objWMI.DeleteKey(dblRegHive, strKeyPath)
		Select Case intRetVal
			Case 0
				'The registry key was deleted successfully.
				DelKeyEnum = True
			Case 2
				'The registry key was not found on this system.
				DelKeyEnum = True
			Case 5
				'The registry key could not be removed.  Access Denied.
				DelKeyEnum = False
			Case Else
				'Unknown error code
				DelKeyEnum = False
		End Select
	End Function	 
			   
	Private Function ConvertSDOptionsToSDDL(sd)
		'http://www.scriptinganswers.com/forum2/forum_posts.asp?TID=1278
	    Dim sddl
	   
	    sddl = "("
	    sddl = sddl & sd.Owner & ","
	    sddl = sddl & sd.DaclDefaulted & ","
	    sddl = sddl & sd.SaclDefaulted & ","
	    sddl = sddl & sd.GroupDefaulted & ","
	    sddl = sddl & sd.OwnerDefaulted & ","
	    sddl = sddl & sd.Revision
	    sddl = sddl & ")"
	
	    ConvertSDOptionsToSDDL = sddl	
	End Function
	
	Private Function SDControlCOnvertToSDDL(sd_control)
		'http://techtasks.com/code/viewbookcode/214
		Const ADS_SD_CONTROL_SE_SACL_PROTECTED        = &H2000
		Const ADS_SD_CONTROL_SE_DACL_PROTECTED        = &H1000
		Const ADS_SD_CONTROL_SE_DACL_AUTO_INHERITED   = &H400
		Const ADS_SD_CONTROL_SE_SACL_AUTO_INHERITED   = &H800
		Const ADS_SD_CONTROL_SE_SACL_AUTO_INHERIT_REQ = &H200
		Const ADS_SD_CONTROL_SE_DACL_AUTO_INHERIT_REQ = &H100
		Const ADS_SD_CONTROL_SE_SACL_DEFAULTED        = &H20
		Const ADS_SD_CONTROL_SE_SACL_PRESENT          = &H10
		Const ADS_SD_CONTROL_SE_DACL_DEFAULTED        = &H8
		Const ADS_SD_CONTROL_SE_DACL_PRESENT          = &H4
		Const ADS_SD_CONTROL_SE_GROUP_DEFAULTED       = &H2
		Const ADS_SD_CONTROL_SE_OWNER_DEFAULTED       = &H1
		
		'http://msdn.microsoft.com/en-us/library/aa772287(VS.85).aspx
		Const ADS_SD_CONTROL_SE_SELF_RELATIVE           = &h8000
		
		'http://www.scriptinganswers.com/forum2/forum_posts.asp?TID=1278
	    Dim sddl
	    sddl = 0
	   
	    If sd_control And ADS_SD_CONTROL_SE_DACL_AUTO_INHERIT_REQ Then sddl = sddl + ADS_SD_CONTROL_SE_DACL_AUTO_INHERIT_REQ
	    If sd_control And ADS_SD_CONTROL_SE_DACL_AUTO_INHERITED Then sddl = sddl + ADS_SD_CONTROL_SE_DACL_AUTO_INHERITED
	    If sd_control And ADS_SD_CONTROL_SE_DACL_DEFAULTED Then sddl = sddl + ADS_SD_CONTROL_SE_DACL_DEFAULTED
	    If sd_control And ADS_SD_CONTROL_SE_DACL_PRESENT Then sddl = sddl + ADS_SD_CONTROL_SE_DACL_PRESENT
	    If sd_control And ADS_SD_CONTROL_SE_DACL_PROTECTED Then sddl = sddl + ADS_SD_CONTROL_SE_DACL_PROTECTED
	    If sd_control And ADS_SD_CONTROL_SE_GROUP_DEFAULTED Then sddl = sddl + ADS_SD_CONTROL_SE_GROUP_DEFAULTED
	    If sd_control And ADS_SD_CONTROL_SE_OWNER_DEFAULTED Then sddl = sddl + ADS_SD_CONTROL_SE_OWNER_DEFAULTED
	    If sd_control And ADS_SD_CONTROL_SE_SACL_AUTO_INHERIT_REQ Then sddl = sddl + ADS_SD_CONTROL_SE_SACL_AUTO_INHERIT_REQ
	    If sd_control And ADS_SD_CONTROL_SE_SACL_AUTO_INHERITED Then sddl = sddl + ADS_SD_CONTROL_SE_SACL_AUTO_INHERITED
	    If sd_control And ADS_SD_CONTROL_SE_SACL_DEFAULTED Then sddl = sddl + ADS_SD_CONTROL_SE_SACL_DEFAULTED
	    If sd_control And ADS_SD_CONTROL_SE_SACL_PRESENT Then sddl = sddl + ADS_SD_CONTROL_SE_SACL_PRESENT
	    If sd_control And ADS_SD_CONTROL_SE_SACL_PROTECTED Then sddl = sddl + ADS_SD_CONTROL_SE_SACL_PROTECTED
	    If sd_control And ADS_SD_CONTROL_SE_SELF_RELATIVE Then sddl = sddl + ADS_SD_CONTROL_SE_SELF_RELATIVE
	   
	    SDControlCOnvertToSDDL = "(" & sddl & ")" & VbCrLf
	   
	End Function
	
	Private Function ACEConvertToSDDL(acl)
		'http://www.scriptinganswers.com/forum2/forum_posts.asp?TID=1278
	    Dim ace 'As ActiveDs.AccessControlEntry
	    Dim sddl, ace_sddl
	   
	    If Not (acl Is Nothing) Then
	   
	        For Each ace In acl
	            ace_sddl = "("
	            ace_sddl = ace_sddl & ace.Trustee
	            ace_sddl = ace_sddl & ")" & VbCrLf
	            sddl = sddl & ace_sddl
	        Next
	       
	       
	    End If
	   
	    ACEConvertToSDDL = sddl
	   
	End Function
	
	Private Function Uni2Ansi(s)
		'http://www.scriptinganswers.com/forum2/forum_posts.asp?TID=1278
	    For i = 6 To Len(s) Step 2
	        Uni2Ansi = Uni2Ansi & Mid(s, i, 1)
	    Next
	End Function

Private Function StringToHex(TextString)
		Dim RetVal, HexNumber, Index
		
		For Index = 1 To Len(TextString)
			HexNumber = Hex(Asc(Mid(TextString,Index,1)))
			If Len(HexNumber) < 2 Then HexNumber = "0" & HexNumber
			RetVal = RetVal &  HexNumber
		Next
	
		StringToHex = RetVal
	End Function
	
	Private Function HexToString(HexNumber)
		'Takes a Hex pair and converts it into a string value
		'REQUIRES FUNCTION: HexToDec
		
		Dim Index, Eval, RetVal, fName, fDesc
		
		'The passed value needs to be a even number so the
		'pairs can be extracted.  If the passed number is
		'not even, raise an error
		If Len(HexNumber) Mod 2 <> 0 Then
			RaiseError "HexToString", "The Hex value passed is not in pairs; ##,##,##"
			Exit Function
		End If
		
		For Index = 1 To Len(HexNumber) Step 2
			Eval = Mid(HexNumber,Index,2)
			Eval = Chr(HexToDec(Eval))	'!!!!!!  Req. 2nd Function
			RetVal = RetVal & Eval
		Next
		
		HexToString = RetVal
	End Function
	
	Private Function GetProfileRoot()
		Dim strProfileRoot
		
		Select Case strComputerOS
			Case WV, W2008, W7
				strProfileRoot = objFSO.BuildPath(objShell.ExpandEnvironmentStrings("%SYSTEMDRIVE%"), "\Users")
			Case WNT4, W2000, WXP, W2003
				strProfileRoot = objFSO.BuildPath(objShell.ExpandEnvironmentStrings("%SYSTEMDRIVE%"), "\Documents And Settings")
			Case Else
				RaiseError "GetProfileRoot1", "Win 9x platforms do not support profiles"
		End Select
		
		If objFSO.FolderExists(strProfileRoot) = False Then
			RaiseError "GetProfileRoot2", "Could not locate profile root"
		Else
			GetProfileRoot = strProfileRoot
		End If
	End Function
	
	Private Function LoadDefaultUserRegistry(strProfileRoot)
		On Error Resume Next: Err.Clear
		
		If bDUOpen = True Then
			LoadDefaultUserRegistry = True
			Exit Function
		End If
		
		objShell.Run "%WinDir%\system32\reg.exe LOAD HKEY_USERS\DefU " & Chr(34) & objFSO.BuildPath(strProfileRoot, "\Default User\ntuser.dat") & Chr(34),0,True
		If Err.Number <> 0 Then
			RaiseError "LoadDefaultUserRegistry", "Unable to load in the default user's registry hive."
			LoadDefaultUserRegistry = False
			bDUOpen = False
		Else
			LoadDefaultUserRegistry = True
			bDUOpen = True
		End If
	End Function
	
	Private Function UnloadDefaultUserRegistry(bIgnoreErrors)
		On Error Resume Next: Err.Clear
		
		If bDUPreLoad = True Then
			UnloadDefaultUserRegistry = True
			Exit Function
		End If
	
		objShell.Run "%WinDir%\system32\reg.exe UNLOAD HKEY_USERS\DefU",0,True
		If Err.Number <> 0 Then
			If Not bIgnoreErrors Then RaiseError "UnloadDefaultUserRegistry", "Unable to unload default users registry hive."
			UnloadDefaultUserRegistry = False
			bDUOpen = True
		Else
			UnloadDefaultUserRegistry = True
			bDUOpen = False
		End If
	End Function
	
	Private Function RaiseError(strFunctionName, strMessage)
		'Generate Error Number
		Dim intErrorNumber, intIndex
		For intIndex = 1 To Len(strFunctionName)
			intErrorNumber = intErrorNumber + Asc(Mid(strFunctionName,intIndex,1))
		Next
		
		'Raise Error
		Err.Raise intErrorNumber, "clsRegEdit", strMessage
	End Function
	
	'---------------------------------------------------------------------------------
	'Public Functions
			   
	Public Function CreateRegKey(dblHive, strPath)
		On Error Resume Next: Err.Clear
				   
		objWMI.CreateKey dblHive, strPath
		CreateRegKey = (Err.Number = 0)
	End Function
 
	Public Function DeleteRegEntry(dblHive, strPath, strKey)
		Dim intRetVal
			   
		On Error Resume Next: Err.Clear
				   
		intRetVal = objReg.DeleteValue(dblHive, strPath, strKey)
		DeleteRegEntry = ((intRetVal = 0) And (Err.number=0))
		Err.Clear
	End Function	 
			   
	Public Function DeleteRegKey(dblHive, strPath)
		DeleteRegKey = DelKeyEnum(dblHive, strPath)
	End Function
				
	Public Function RegEntryExists(dblHive, strPath, strKey, dblType)
		Dim vRetVal: vRetVla = ReadRegEntry(dblHive, strPath, strKey, dblType)
		RegReadEntry = (vRetVal <> vbNull)
	End Function
				   
	Public Function ReadRegEntry(dblHive, strPath, strKey, dblType)			 				   
		Dim RetVal, Index
		
		'Check for Win9x Info Only
		If dblHive = HKEY_DYN_DATA Then
			If Not(strComputerOS = W95 Or strComputerOS = W98 Or strComputerOS = W98SE) Then
				RaiseError "ReadRegEntry1", "HKEY_DYN_DATA not supported on your current OS Platform"
				Exit Function
			End If
		End If
			   
		'Determine type to Read
		Select Case dblType
			Case REG_EXPAND_SZ
				objWMI.GetExpandedStringValue dblHive, strPath, strKey, RetVal
				
			Case REG_BINARY
				objWMI.GetBinaryValue dblHive, strPath, strKey, RetVal
				
				If TypeName(RetVal) <> "Null" Then
					If bConvertToHex = True Then
						For Index = 0 To UBound(RetVal)
							RetVal(Index) = Hex(RetVal(Index))
							If Len(RetVal(Index)) = 1 Then RetVal(Index) = "0" & RetVal(Index)
						Next
					End If
				End If
				
			Case REG_DWORD
				objWMI.GetDWORDValue dblHive, strPath, strKey, RetVal
				
			Case REG_MULTI_SZ
				objWMI.GetMultiStringValue dblHive, strPath, strKey, RetVal
				
			Case REG_QWORD												'http://msdn.microsoft.com/en-us/library/aa390461(VS.85).aspx
				If Not (strComputerOS = WV Or strComputerOS = W2008 Or strComputerOS = W7) Then
					'QWord value - not avail. on less than vista/2008/Win 7
					RaiseError "ReadRegEntry2", "Reading QWORD values not supported on current OS Platform"
				Else
					'OK
					objWMI.GetQWORDValue dblHive, strPath, strKey, RetVal
				End If
				
			Case Else
				objWMI.GetStringValue dblHive, strPath, strKey, RetVal
		End Select
				   
		If TypeName(RetVal) = "Null" Then RetVal = Null
			   
		ReadRegEntry = RetVal
	End Function
			   
	Public Function WriteRegEntry(dblHive, strPath, strKey, strValue, dblType)				   
		Dim intRetVal, intCount
		Dim arrBIN, bHEX
		
		'Check for Win9x Info Only
		If dblHive = HKEY_DYN_DATA Then
			If Not(strComputerOS = W95 Or strComputerOS = W98 Or strComputerOS = W98SE) Then
				RaiseError "WriteRegEntry1", "HKEY_DYN_DATA not supported on your current OS Platform"
				Exit Function
			End If
		End If
				   
		'Writes can fail if the key is not present - verify the key
		If CreateRegKey(dblHive, strPath) =False Then
			RaiseError "WriteRegEntry2", "Unable to create / verify base registry path"
			WriteRegEntry = False
			Exit Function
		End If
			   
		Select Case dblType
			Case REG_SZ
				'String Value
				intRetVal = objWMI.SetStringValue(dblHive, CStr(strPath), CStr(strKey), CStr(strValue))
			Case REG_EXPAND_SZ
				'Expanded String
				intRetVal = objWMI.SetExpandedStringValue(dblHive, CStr(strPath), CStr(strKey), CStr(strValue))
			Case REG_BINARY
				'Binary Value - The data must be passed as a numeric array
				'We assume the data will be passed as integers or HEX values
				'We also assume the separation character to be a "|"
				
				arrBIN = Split(strValue, "|")
				
				'This is a bit dirty, assume HEX if all values are 2 characters and at least one has A-F
				bHEX = True
				For intRetVal = 0 To UBound(arrBIN)
					If NOT IsNumeric(arrBIN(intRetVal)) Then Exit For
					
					If Len(arrBIN(intRetVal)) = 3 Then
						bHEX = False
						Exit For
					End If
				Next
				
				'Convert to HEX if integer
				If bHEX Then
					For intCount = 0 To UBound(arrBIN)
						arrBIN(intCount) = CInt(HexToDec(arrBIN(intCount)))
					Next
				End If
			   
				intRetVal = objWMI.SetBinaryValue(dblHive, CStr(strPath), CStr(strKey), arrBIN)
				Erase arrBIN
			Case REG_DWORD
				'DWord Value
				'Might be HEX - convert to INT if it is
				If Not IsNumeric(strValue) Then strValue = HexToDec(strValue)
				
				intRetVal = objWMI.SetDWORDValue(dblHive,CStr(strPath), CStr(strKey), CLng(strValue))
			Case REG_MULTI_SZ
				'Multi-String Value
				'We assume the seperation character to be a |
				arrBIN = Split(strValue, "|")
			   
				intRetVal = objWMI.SetMultiStringValue(dblHive,CStr(strPath), CStr(strKey), arrBIN)
				Erase arrBIN
			Case REG_QWORD												'http://msdn.microsoft.com/en-us/library/aa393590(VS.85).aspx
				If Not (strComputerOS = WV Or strComputerOS = W2008 Or strComputerOS = W7) Then
					'QWord value - not avail. on less than vista/2008/Win 7
					RaiseError "WriteRegEntry3", "Writing QWORD values not supported on current OS Platform"
				Else
					'OK
					intRetVal = objWMI.SetQWORDValue(dblHive,CStr(strPath), CStr(strKey), CLng(strValue))
				End If
		End Select
			   
		WriteRegEntry = (intRetVal = 0)
	End Function
			
	Public Function GetSecurityDescriptor(strHiveAndPath)
		CONST ADS_PATH_REGISTRY = 3
		CONST ADS_SD_FORMAT_IID = 1

'Only available on Windows Vista, 2008, Windows 7
		If Not(strComputerOS = WV Or strComputerOS = W2008 Or strComputerOS = W7) Then
			GetSecurityDescriptor = vbNull
		Else
			'http://www.scriptinganswers.com/forum2/forum_posts.asp?TID=1278
			Dim oRegSD, oADsSecurityUtility, sddl
			Set oADsSecurityUtility = CreateObject("ADsSecurityUtility")
			Set oRegSD = oADsSecurityUtility.GetSecurityDescriptor(strHiveAndPath, ADS_PATH_REGISTRY, ADS_SD_FORMAT_IID)
			
			sddl = ConvertSDOptionsToSDDL(oRegSD)
			sddl = sddl & SDControlCOnvertToSDDL(oRegSD.control)
			sddl = sddl & ACEConvertToSDDL(oRegSD.SystemAcl)
			sddl = sddl & ACEConvertToSDDL(oRegSD.DiscretionaryAcl)
			
			Set oADsSecurityUtility = Nothing
			Set oRegSD = Nothing
			
			GetSecurityDescriptor = sddl
		End If
	End Function
	
	Public Function CheckAccess(dblHive, strPath, dblAccessType)
		'http://msdn.microsoft.com/en-us/library/aa384911(VS.85).aspx
		Dim bHasAccessRight

objWMI.CheckAccess dblHive, strPath, dblAccessType, bHasAccessRight
		CheckAccess = bHasAccessRight		
	End Function
	
	Public Function EnumValues(dblHive, strPath, intIndex, ByRef vValueData)
		'http://msdn.microsoft.com/en-us/library/aa390388(VS.85).aspx
		Dim aryNames(), aryTypes()
		Dim index, ReturnValue
		
		ReturnValue = objWMI.EnumValues(dblHive, strPath, aryNames, aryTypes)
		If ReturnValue <> 0 Then 
			vValueData = Null
			EnumValues = Null
			Exit Function
		End If
			
		If intIndex > UBound(aryNames) Then 
			EnumValues = Null
			Exit Function
		End If
		
		vValueData = ReadRegEntry(dblHive,strPath,aryNames(intIndex),aryTypes(intIndex))
		
		EnumValues = aryNames(intIndex)
		
		Erase aryNames
		Erase aryTypes		
	End Function
	
	Public Function SubkeyValueCount(dblHive, strPath)
		Dim aryNames(), aryTypes()
		Dim index, ReturnValue
		
		ReturnValue = objWMI.EnumValues(dblHive, strPath, aryNames, aryTypes)
		If ReturnValue <> 0 Then 
			SubkeyValueCount = 0
			Exit Function
		End If
		
		SubkeyValueCount = UBound(aryNames)+1
		
		Erase aryNames
		Erase aryTypes	
	End Function
	
	Public Function EnumKey(dblHive, strPath, intIndex)
		'http://msdn.microsoft.com/en-us/library/aa390387(VS.85).aspx
		Dim aryKeys(), ReturnValue
		ReturnValue = objWMI.EnumKey(dblHive, strPath, aryKeys)
		If ReturnValue <> 0 Then
			EnumKey = Null
			Exit Function
		End If
		
		If intIndex > UBound(aryKeys) Then 
			EnumKey = Null
			Exit Function
		End If
		
		EnumKey = aryKeys(intIndex)
		Erase aryKeys
	End Function
	
	Public Function SubkeyCount(dblHive, strpath)
		Dim aryKeys(), ReturnValue
		ReturnValue = objWMI.EnumKey(dblHive, strPath, aryKeys)
		If ReturnValue <> 0 Then
			SubkeyCount = 0
			Exit Function
		End If
		
		SubkeyCount = UBound(aryKeys)+1
		Erase aryKeys
	End Function
	
	Public Function WriteStringAsBinary(dblHive, strPath, strKey, strValue)
		Dim strHEX, Index, strBIN
		strHEX = StringToHex(strValue)
		For Index = 1 To Len(strHEX) Step 2
			strBIN = strBIN & Mid(strHEX, Index, 2) & "|"
		Next
		strBIN = Left(strBIN, Len(strBIN)-1)
		WriteStringAsBinary = WriteRegEntry(dblHive, strPath, strKey, strBIN, REG_BINARY)
	End Function
	
	Public Function ReadStringFromBinary(dblHive, strPath, strKey)
		Dim strBIN, strData, Index
		strBIN = ReadRegEntry(dblHive, strPath, strKey, REG_BINARY)
		If IsNull(strBIN) Then
			ReadStringFromBinary = Null
			Exit Function
		End If
		For Index = 0 To UBound(strBIN)
			If bConvertToHex = False Then
				strData = strData & Chr(strBIN(Index))
			Else
				strData = strData & Chr(HexToDec(strBIN(Index)))
			End If
		Next
		
		ReadStringFromBinary = strData	
	End Function
	
	Public Function ReadDefaultUserValue(strPath, strKey, dblType, bIgnoreUnloadErrors)
		Dim vRetVal
		If Left(strPath,1) <> "\" Then strPath = "\" & strPath
		strpath = "DefU" & strPath
		
		If ComputerName <> "." Then
			RaiseError "ReadDefaultUserValue", "You can only read a Default User value when connected to the local computer."
			Exit Function
		End If
		
		Dim strProfileRoot: strProfileRoot = GetProfileRoot
		LoadDefaultUserRegistry strProfileRoot
		
		vRetVal = ReadRegEntry(HKEY_USERS, strpath, strKey, dblType)
		ReadDefaultUserValue = vRetVal		
		
		UnloadDefaultUserRegistry bIgnoreUnloadErrors		
	End Function
	
	Public Function WriteDefaultUserEntry(strPath, strKey, strValue, dblType,bIgnoreUnloadErrors)
		Dim vRetVal
		If Left(strPath,1) <> "\" Then strPath = "\" & strPath
		strpath = "DefU" & strPath
		
		If ComputerName <> "." Then
			RaiseError "WriteDefaultUserEntry", "You can only write a Default User value when connected to the local computer."
			Exit Function
		End If
		
		Dim strProfileRoot: strProfileRoot = GetProfileRoot
		LoadDefaultUserRegistry strProfileRoot
		
		vRetVal = WriteRegEntry(HKEY_USERS, strPath, strKey, strValue, dblType)
		WriteDefaultUserEntry = vRetVal
		
		UnloadDefaultUserRegistry bIgnoreUnloadErrors		
	End Function
	'*********************************************************************************
	'
	'////////////////////////////////////////////////////
	'Copyright © 2005, 2009 Dx21, LLC
	'			   a Washingtion Limited Liability Company
	'			   All Rights Reserved
	'
	'Use of this script is subject to the terms and conditions
	'as listed in our public Copyright and Disclamer statments.
	'Those statements must be agreed to prior to use of this
	'script:
	'
	'http://dx21.com/home/tos.aspx
	'////////////////////////////////////////////////////
	'
	'VERSION HISTORY:
	'
	'1.0.0	 - 9/1/2005
	'			   Initial Release
	'
	'1.1.1	 - 04/25/2009
	'			   Revised connection to WMI Namespace to only happen once per unique destination specification
	'			   Added support for QWORD read/write
	'			   Added WriteStringAsBinary & ReadStringFromBinary functions
	'			   Added user visible CreateRegKey function
	'			   Added RegEntryExists function
	'			   Added GetSecurityDescriptor function - don't love it, but OK start
	'			   Added CheckAccess function
	'			   Added EnumValues, SubkeyValueCount, EnumKey and SubkeyCount functions
	'			   Added Read/Write property ComputerName
	'			   Added Read property ComputerOSVersion
	'			   Changed RegReadEntry to return Null when no data was read from registry
	'			   Removed property clsVersion
	'			   Fixed error with REB_BINARY write where passed data was incorrectly identified and converted to integer
	'
	'1.1.2	- 04/28/2009
	'				Added ReadDefaultUserValue and WriteDefaultUserValue functions
	'				Added KeepDefaultUserProfileOpen Property
	'				Fixed incorrect identification of Windows Vista
	'				Changed WriteRegEntry's DWord handler to accept HEX values passed as strings as well as standard HEX and INT
	'				Changed how internal errors are generated 'cause I lost track of numbering
End Class

Unless otherwise noted, this code is licensed according to the terms and conditions listed in our copyright notice.

Last Modification:
5/26/2009

	FAQs \| Terms Of Use \| Privacy Policy \| Contact Us
	Copyright © 1997 - 2010 Dx21, LLC. All rights reserved. Dx21, LLC a Washington Limited Liability Company Page Rendered at: 9/2/2010 8:11:07 PM for Unknown