'********************
' Copyright (c) 2008
'         by
'   Kenneth Sweet
'********************

'********************
' Copyright (c) 2008
'         by
'   Kenneth Sweet
'********************
On Error Resume Next

'Constants for Registry Functions
Const HKCU = &H80000001
Const HKLM = &H80000002
Const HKROOT = &H80000000
Const HKUSERS = &H80000003
Const HKCC = &H80000005

Const REG_SZ = 1
Const REG_EXPAND_SZ = 2
Const REG_BINARY = 3
Const REG_DWORD = 4
Const REG_MULTI_SZ = 7
Const REG_DELVAL = -1
Const REG_DELKEY = -2

'Constants for Text Files
Const ForReading = 1
Const ForWriting = 2
Const ForAppending = 8

'******************************************************************************
' Sample command line
'******************************************************************************
'WScript.exe SetHKCU.vbs" /CN:"RemotePC" /RK:"registry Test 3" /RN:"REG_SZ|REG_EXPAND_SZ|REG_BINARY|REG_DWORD|REG_MULTI_SZ|REG_SZ|Null" /RV:"Value|Value|0,1|0|Value1,Value2|Null|Null" /DT:"S|E|B|D|M|DK|DV" /IF:"C:\ImportReg.txt"

'/CN: Computer Name, Optional, Only needed if you are setting registry keys on a remote system, can be used with any of the available options to set registry values. (VB Code, Command Line, and/or Import File)

' The following 4 options must either be all used together or not at all. You cannot use just some of them.
'/RK: Registry Key
'/RN: Registry Vale Names
'/RV: Registry vales
'/DT: Data Types

'/IF: Import file, Must have a previously created text file with registry settings in it (see below)
'******************************************************************************
'Format of Import File (follows same rules as command line options)
'******************************************************************************
'Line1 = Registry Key
'Line2 = Value Names
'Line3 = Values
'Line4 = Data Types
' Date Type Vales
'  S = REG_SZ
'  E = REG_EXPAND_SZ
'  B = REG_BINARY
'  D = REG_DWORD
'  M = REG_MULTI_SZ
'  DV = REG_DELVAL
'  DK = REG_DELKEY
'******************************************************************************
'registry Test 4
'REG_SZ|REG_EXPAND_SZ|REG_BINARY|REG_DWORD|REG_MULTI_SZ|REG_SZ|Null
'Value|Value|0,1|0|Value1,Value2|Null|Null
'S|E|B|D|M|DV|DK
'******************************************************************************
'Rem set CompName value.
' Can be passed via command line option whenrunning the script
'  /CN:NameofPC
' Must be "." if setting values on the local PC
Set MyArguments = WScript.Arguments.Named
MyCompName = MyArguments.Item("CN")
If IsEmpty(MyCompName) Or IsNull(MyCompName) Then
  MyCompName = "."
Else
  Set LocalComputer = CreateObject("Shell.LocalMachine")
  If LCase(MyCompName) = LCase(LocalComputer.MachineName) Then
    MyCompName = "."
  End If
End If

'Get Registry key if passed on the command line
'/RK:"registry Test 3"
CLRegKey = MyArguments.Item("RK")

'Get Names of value to be set, can pass multiple values separated by |'s
'/RN:"REG_SZ|REG_EXPAND_SZ|REG_BINARY|REG_DWORD|REG_MULTI_SZ|REG_SZ|Null"
CLNames = Split(MyArguments.Item("RN"), "|", - 1, 1)

'Get values to be set, can pass multiple values separated by |'s
'Binary and MultiSting values need to be separated by ,'s
'/RV:"Value|value|0,1|0|Value1,Value2|Null|Null"
CLValues = Split(MyArguments.Item("RV"), "|", - 1, 1)

'Get Type of data to be set, can pass multiple values separated by |'s
'/DT:"S|E|B|D|M|DV|DK"
' Date Type Vales
'  S = REG_SZ
'  E = REG_EXPAND_SZ
'  B = REG_BINARY
'  D = REG_DWORD
'  M = REG_MULTI_SZ
'  DV = REG_DELVAL
'  DK = REG_DELKEY
CLDType = Split(MyArguments.Item("DT"), "|", - 1, 1)
If UBound(CLDType) > - 1 Then
  FixDType CLDType, CLValues
End If

'Name of File to import Registry settings from
'/IF:"C:\ImportReg.txt"
ImportFile = MyArguments.Item("IF")


'Rem set staring check value
MyReturn = True

'******************************************************************************
' Start of sample code
'******************************************************************************
'******************************************************************************
' To set a single value under a registry key
'******************************************************************************
' REG_SZ
MyReturn = MyReturn And SetHKUser(MyCompName, "REG_SZ", "Value", REG_SZ, "registry Test 1")
' REG_EXPAND_SZ
MyReturn = MyReturn And SetHKUser(MyCompName, "REG_EXPAND_SZ", "Value", REG_EXPAND_SZ, "registry Test 1")
' REG_BINARY - Must pass an array as the value to be set
  Dim BValues1(1)
  BValues1(0) = 0
  BValues1(1) = 1
MyReturn = MyReturn And SetHKUser(MyCompName, "REG_BINARY", BValues1, REG_BINARY, "registry Test 1")
' REG_DWORD
MyReturn = MyReturn And SetHKUser(MyCompName, "REG_DWORD", 0, REG_DWORD, "registry Test 1")
' REG_MULTI_SZ - Must pass an array as the value to be set
  Dim MValues1(1)
  MValues1(0) = "Value1"
  MValues1(1) = "Value2"
MyReturn = MyReturn And SetHKUser(MyCompName, "REG_MULTI_SZ", MValues1, REG_MULTI_SZ, "registry Test 1")
'Delete a Registry Value
MyReturn = MyReturn And SetHKUser(MyCompName, "REG_SZ", Null, REG_DELVAL, "registry Test 1")
'Delete a Registry Key
MyReturn = MyReturn And SetHKUser(MyCompName, Null, Null, REG_DELKEY, "registry Test 1")

'******************************************************************************
' To set multiple values under a registry key
'******************************************************************************
Dim MyNames(6), MyValue(6), MyDType(6)
' REG_SZ
MyNames(0) = "REG_SZ"
MyValue(0) = "Value"
MyDType(0) = REG_SZ
' REG_EXPAND_SZ
MyNames(1) = "REG_EXPAND_SZ"
MyValue(1) = "Value"
MyDType(1) = REG_EXPAND_SZ
' REG_BINARY - Must pass an array as the value to be set
MyNames(2) = "REG_BINARY"
  Dim BValues2(1)
  BValues2(0) = 0
  BValues2(1) = 1
  MyValue(2) = BValues2
MyDType(2) = REG_BINARY
' REG_DWORD
MyNames(3) = "REG_DWORD"
MyValue(3) = 0
MyDType(3) = REG_DWORD
' REG_MULTI_SZ - Must pass an array as the value to be set
MyNames(4) = "REG_MULTI_SZ"
  Dim MValues2(1)
  MValues2(0) = "Value1"
  MValues2(1) = "Value2"
MyValue(4) = MValues2
MyDType(4) = REG_MULTI_SZ
'Delete a Registry Value
MyNames(5) = "REG_SZ"
MyValue(5) = Null
MyDType(5) = REG_DELVAL
'Delete a Registry Key
MyNames(6) = Null
MyValue(6) = Null
MyDType(6) = REG_DELKEY

MyReturn = MyReturn And SetHKUser(MyCompName, MyNames, MyValue, MyDType, "registry Test 2")

'******************************************************************************
' To set multiple values under a registry key via the command line options
'******************************************************************************
MyReturn = MyReturn And SetHKUser(MyCompName, CLNames, CLValues, CLDType, CLRegKey)

'******************************************************************************
' To set multiple values under a registry key via Inport File option
'******************************************************************************
MyReturn = MyReturn And DoImportFile(ImportFile)

'******************************************************************************
' End of sample code
'******************************************************************************

'******************************************************************************
' Exit Script with error code if any errors
'******************************************************************************
If MyReturn Then
  WScript.Quit 0
Else
  WScript.Quit 10001
End If

' *****************************************************************************
' Function to call to set / delete either single of multiple registry values
' Returns True if there were no errors
' *****************************************************************************
Function SetHKUser(ByVal MyCompName, ByVal MyNames, ByVal MyValue, ByVal MyDType, ByVal MyRegKey)
  On Error Resume Next
  TempReturn = False
  If ConnectREG(MyCompName, MyStdRegProv) Then
    If GetHKCUser(MyStdRegProv, HKUSubkey) Then
      If CreateSubKeys(MyStdRegProv, HKUSERS, HKUSubkey, MyRegKey) Then
        HKURegKey = HKUSubkey & "\" & MyRegKey
        TempReturn = True
        If IsArray(MyNames) Then
          For ZLoop = LBound(MyNames) To UBound(MyNames)
            Select Case MyDType(ZLoop)
              Case REG_SZ : TempReturn = TempReturn And SetRegString(MyStdRegProv, HKUSERS, HKURegKey, MyNames(ZLoop), MyValue(ZLoop))
              Case REG_EXPAND_SZ : TempReturn = TempReturn And SetRegExpanded(MyStdRegProv, HKUSERS, HKURegKey, MyNames(ZLoop), MyValue(ZLoop))
              Case REG_BINARY : TempReturn = TempReturn And SetRegBinary(MyStdRegProv, HKUSERS, HKURegKey, MyNames(ZLoop), MyValue(ZLoop))
              Case REG_DWORD : TempReturn = TempReturn And SetRegDWord(MyStdRegProv, HKUSERS, HKURegKey, MyNames(ZLoop), MyValue(ZLoop))
              Case REG_MULTI_SZ : TempReturn = TempReturn And SetRegMString(MyStdRegProv, HKUSERS, HKURegKey, MyNames(ZLoop), MyValue(ZLoop))
              Case REG_DELVAL : TempReturn = TempReturn And DelRegValue(MyStdRegProv, HKUSERS, HKURegKey, MyNames(ZLoop))
              Case REG_DELKEY : TempReturn = TempReturn And DelRegKey(MyStdRegProv, HKUSERS, HKURegKey)
            End Select
          Next
        Else
          Select Case MyDType
            Case REG_SZ : TempReturn = TempReturn And SetRegString(MyStdRegProv, HKUSERS, HKURegKey, MyNames, MyValue)
            Case REG_EXPAND_SZ : TempReturn = TempReturn And SetRegExpanded(MyStdRegProv, HKUSERS, HKURegKey, MyNames, MyValue)
            Case REG_BINARY : TempReturn = TempReturn And SetRegBinary(MyStdRegProv, HKUSERS, HKURegKey, MyNames, MyValue)
            Case REG_DWORD : TempReturn = TempReturn And SetRegDWord(MyStdRegProv, HKUSERS, HKURegKey, MyNames, MyValue)
            Case REG_MULTI_SZ : TempReturn = TempReturn And SetRegMString(MyStdRegProv, HKUSERS, HKURegKey, MyNames, MyValue)
            Case REG_DELVAL : TempReturn = TempReturn And DelRegValue(MyStdRegProv, HKUSERS, HKURegKey, MyNames)
            Case REG_DELKEY : TempReturn = TempReturn And DelRegKey(MyStdRegProv, HKUSERS, HKURegKey)
          End Select
        End If
      End If
    End If
  End If
  SetHKUser = TempReturn
End Function
' *****************************************************************************
' *****************************************************************************

Sub FixDType(ByRef CLDType, ByRef CLValues)
  On Error Resume Next
  For ZLoop = 0 To UBound(CLDType)
    Select Case LCase(CLDType(ZLoop))
      Case "s" : CLDType(ZLoop) = REG_SZ
      Case "e" : CLDType(ZLoop) = REG_EXPAND_SZ
      Case "b"
        CLDType(ZLoop) = REG_BINARY
        TempArray = Split(CLValues(ZLoop), ",", - 1, 1)
        If UBound(TempArray) > - 1 Then
          CLValues(ZLoop) = TempArray
        End If
      Case "d" : CLDType(ZLoop) = REG_DWORD
      Case "m"
        CLDType(ZLoop) = REG_MULTI_SZ
        TempArray = Split(CLValues(ZLoop), ",", - 1, 1)
        If UBound(TempArray) > - 1 Then
          CLValues(ZLoop) = TempArray
        End If
      Case "dv" : CLDType(ZLoop) = REG_DELVAL
      Case "dk" : CLDType(ZLoop) = REG_DELKEY
    End Select
  Next
End Sub

' *****************************************************************************
' Connects to Registry
' *****************************************************************************
Function ConnectREG(ByVal MyCompName, ByRef MyStdRegProv)
  On Error Resume Next
  Set WSNetwork = CreateObject("Wscript.Network")
  If LCase(MyCompName) = LCase(WSNetwork.ComputerName) Then
    MyCompName = "."
  End If
  Set MyStdRegProv = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & MyCompName & "\root\default:StdRegProv")
  If Err.number = 0 Then
    ConnectREG = True
  Else
    Err.Clear
    ConnectREG = False
  End If
End Function
' *****************************************************************************
' *****************************************************************************

' *****************************************************************************
' Get the name of the registry key for the current logged on user under HKey_Users
' Returns True if there were no errors
' Key name is returned in HKCURegKey
' *****************************************************************************
Function GetHKCUser(ByRef MyStdRegProv, ByRef HKCURegKey)
'Gets the key name for the current logged on user
  On Error Resume Next
  TempReturn = False
  If MyStdRegProv.EnumKey(HKUSERS, "", ArraySubKeys) = 0 Then
    If Not IsNull(ArraySubKeys) Then
      For Each HKUSubkey In ArraySubKeys
        If Len(HKUSubkey) > 8 And InStr(HKUSubkey, "Classes") = 0 Then
          HKCURegKey = HKUSubkey
          TempReturn = True
        End If
      Next
    End If
  End If
  GetHKCUser = TempReturn
End Function
' *****************************************************************************
' *****************************************************************************

' *****************************************************************************
' Write / Create Registry values
' Returns True if there were no errors
' *****************************************************************************
'Set / Create a String Value
Function SetRegString(ByRef MyStdRegProv, ByVal MyHive, ByVal MyRegKey, ByVal MyValueName, ByVal MyValue)
  On Error Resume Next
  TempReturn = False
  If MyStdRegProv.SetStringValue(MyHive, MyRegKey, MyValueName, MyValue) = 0 Then
    TempReturn = True
  End If
  SetRegString = TempReturn
End Function

'Set / Create a DWord Value
Function SetRegDWord(ByRef MyStdRegProv, ByVal MyHive, ByVal MyRegKey, ByVal MyValueName, ByVal MyValue)
  On Error Resume Next
  TempReturn = False
  If MyStdRegProv.SetDWordValue(MyHive, MyRegKey, MyValueName, MyValue) = 0 Then
    TempReturn = True
  End If
  SetRegDWord = TempReturn
End Function

'Set / Create an Expanded Value
Function SetRegExpanded(ByRef MyStdRegProv, ByVal MyHive, ByVal MyRegKey, ByVal MyValueName, ByVal MyValue)
  On Error Resume Next
  TempReturn = False
  If MyStdRegProv.SetExpandedStringValue(MyHive, MyRegKey, MyValueName, MyValue) = 0 Then
    TempReturn = True
  End If
  SetRegExpanded = TempReturn
End Function

Function SetRegMString(ByRef MyStdRegProv, ByVal MyHive, ByVal MyRegKey, ByVal MyValueName, ByVal MyAValue)
  ' Set registry multi string value
  On Error Resume Next
  TempReturn = False
  If IsArray(MyAValue) Then
    If MyStdRegProv.SetMultiStringValue(MyHive, MyRegKey, MyValueName, MyAValue) = 0 Then
      TempReturn = True
    End If
  End If
  SetRegMString = TempReturn
End Function

Function SetRegBinary(ByRef MyStdRegProv, ByVal MyHive, ByVal MyRegKey, ByVal MyValueName, ByVal MyAValue)
  ' Set registry Binary value
  On Error Resume Next
  TempReturn = False
  If IsArray(MyAValue) Then
    If MyStdRegProv.SetBinaryValue(MyHive, MyRegKey, MyValueName, MyAValue) = 0 Then
      TempReturn = True
    End If
  End If
  SetRegBinary = TempReturn
End Function
' *****************************************************************************
' *****************************************************************************

' *****************************************************************************
' Delete Registry values / Keys
' Returns True if there were no errors
' *****************************************************************************
Function DelRegValue(ByRef MyStdRegProv, ByVal MyHive, ByVal MyRegKey, ByVal MyValueName)
'Delete a registry value
  On Error Resume Next
  TempReturn = False
  If MyStdRegProv.DeleteValue(MyHive, MyRegKey, MyValueName) = 0 Then
    TempReturn = True
  End If
  DelRegValue = TempReturn
End Function

Function DelRegKey(ByRef MyStdRegProv, ByVal MyHive, ByVal MyRegKey)
'Delete a registry key
  On Error Resume Next
  TempReturn = False
  If MyStdRegProv.DeleteKey(MyHive, MyRegKey) = 0 Then
    TempReturn = True
  End If
  DelRegKey = TempReturn
End Function
' *****************************************************************************
' *****************************************************************************

' *****************************************************************************
' Create registry keys
' Returns True if there were no errors
' *****************************************************************************
'Split registry key into individual key names and call function to create each one
Function CreateSubKeys(ByRef MyStdRegProv, ByVal MyHive, ByVal MyRegKey, ByVal MyNewSubKeys)
  On Error Resume Next
  TempReturn = False
  AllSubKeys = Split(MyNewSubKeys, "\", -1, 1)
  If UBound(AllSubKeys) > -1 Then
    For ZLoop = 0 To UBound(AllSubKeys)
      If CreateSubKey(MyStdRegProv, MyHive, MyRegKey, AllSubKeys(ZLoop)) Then
        MyRegKey = MyRegKey & "\" & AllSubKeys(ZLoop)
        TempReturn = True
      Else
        CreateSubKeys = False
        Exit Function
      End If
    Next
  End If
  CreateSubKeys = TempReturn
End Function

'Create registry key
Function CreateSubKey(ByRef MyStdRegProv, ByVal MyHive, ByVal MyRegKey, ByVal MyNewSubKey)
  On Error Resume Next
  TempReturn = False
  MyStdRegProv.EnumKey MyHive, MyRegKey, ArraySubKeys
  If Not IsNull(ArraySubKeys) Then
    For Each Subkey In ArraySubKeys
      If SubKey = MyNewSubKey Then
        TempReturn = True
      End If
    Next
  End If
  If Not(TempReturn) Then
    If MyStdRegProv.CreateKey(MyHive, MyRegKey & "\" & MyNewSubKey) = 0 Then
      TempReturn = True
    End If
  End If
  CreateSubKey = TempReturn
End Function
' *****************************************************************************
' *****************************************************************************

' *****************************************************************************
'Import file functions
' *****************************************************************************
Function DoImportFile(ByRef ImportFile)
  On Error Resume Next
  TempReturn = True
  If Not (IsEmpty(ImportFile)) Then
    If FileOpen(ImportFile, ForReading, False, FSObject) Then
      Do Until FSObject.AtEndOFStream
        If FileReadLine(FSObject, IFRegKey) Then
          IFRegKey = Trim(IFRegKey)
        Else
          Exit Do
        End If
        If FileReadLine(FSObject, IFNames) Then
          IFNames = Split(Trim(IFNames), "|", - 1, 1)
        Else
          Exit Do
        End If
        If FileReadLine(FSObject, IFValues) Then
          IFValues = Split(Trim(IFValues), "|", - 1, 1)
        Else
          Exit Do
        End If
        If FileReadLine(FSObject, IFDType) Then
          IFDType = Split(Trim(IFDType), "|", - 1, 1)
        Else
          Exit Do
        End If
        If UBound(IFDType) > - 1 Then
          FixDType IFDType, IFValues
          If UBound(IFnames) > -1 And UBound(IFvalues) > -1 And Len(IFRegKey) > 0 Then
            TempReturn = TempReturn And SetHKUser(MyCompName, IFNames, IFValues, IFDType, IFRegKey)
          End If
        End If
      Loop
      FileClose FSObject
    End If
  End If
  DoImportFile = TempReturn
End Function

Function FileOpen(Byval FileName, ByVal OpenMode, Byval Create, ByRef FSObject)
  On Error Resume Next
  FileOpen = False
  FSObject = Null
  Set FSO = CreateObject("Scripting.FileSystemObject")
  Set TempReturn = FSO.OpenTextFile(FileName, OpenMode, Create)
  If Err.number = 0 Then
    FileOpen = True
    Set FSObject = TempReturn
  End If
End Function

Function FileReadLine(ByRef FSObject, ByRef InputText)
  On Error Resume Next
  InputText = Null
  FileReadLine = False
  If Not (FSObject.AtEndOFStream) Then
    TempReturn = FSObject.ReadLine
    If Err.number = 0 And Not(IsNull( TempReturn)) Then
      InputText = TempReturn
      FileReadLine = True
    End If
  End If
End Function

Function FileClose(ByRef FSObject)
  On Error Resume Next
  FileClose = False
  FSObject.Close
  If Err.number = 0 Then
    FileClose = True
  End If
End Function
' *****************************************************************************
' *****************************************************************************