'   Chris Bennett
'   Technical Consultant
'   Processing and Storage Project
'   2010-03-11
'     Building Process for Prestaging Domain User Accounts to use existing
'     Local Profiles
'   2010-04-01
'     Got it just pulling the FQDN and Domain out of the Local Machine
'     Settings. Removed as much Hard Coded constants as necessary

Const HKEY_LOCAL_MACHINE = &H80000002
ADFQDN = GetDomainFQDN()
ADDomain = GetDomainShortName()

If ADFQDN <> "" Then
    ret = StageAllUsers(ADFQDN,ADDomain)
End If

'**************************************************************************************************
' Function stages all Local User accounts
' 
Function StageAllUsers(DomainFQDN, strDomain)
	' Enumerate all users that are Local and not built in accounts.
	strComputer = "."
	Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
	'Enumerate users where the User Domain is the Local Machine and the username matches the Supplied Name
	Set colItems = objWMIService.ExecQuery _
		("Select * from Win32_UserAccount  Where Domain = '" & GetComputerName & "' And Disabled = FALSE And Name <> 'Administrator'")
	' Stage each user
	For Each objItem In colItems
		' Ensure the account actually has a profile (otherwise we can ignore it)
	    If GetLocalUserProfile(objItem.Name) <> "" Then
			ret = StageUser(objItem.Name, DomainFQDN, strDomain)
		End If
	Next
End Function

'**************************************************************************************************
' Function stages the User account by setting ACLs on required folders
' 
Function StageUser(UserName, DomainFQDN, strDomain)
	Set objShell = CreateObject("WScript.Shell")
	' Not Assuming "C:\Documents and Settings\" & UserName:
	'   Get SDDL of user via WMI interrogation of UserAccount
	'   Get Profile Location of user (from HKLM\Software\Microsoft\Windows NT\CurrentVersion\ProfileList\" & SDDL & "ProfileImagePath"
	strProfile = GetLocalUserProfile(UserName)
	
	' Set ACLs on ProfileLocation
	ret = objShell.Run("subinacl /subdirectories """ & strProfile & """ /grant=""" & UserName & "@" & DomainFQDN & """=F",0,True)
	'ret = objShell.Run("cacls """ & strProfile & """ /T /E /G """ & UserName & "@" & DomainFQDN & """:F",0, True)
	
	' Set ACLs on D:\UserData\%username%
	ret = objShell.Run("subinacl /subdirectories ""D:\UserData\" & UserName & """ /grant=""" & UserName & "@" & DomainFQDN & """=F",0,True)
	'ret = objShell.Run("cacls ""D:\UserData\" & UserName & """ /T /E /G """ & UserName & "@" & DomainFQDN & """:F",0, True)
	
	' Reg load ProfileLocation\NTUSER.DAT into HKU\%username%
	ret = objShell.Run("reg load ""HKU\" & UserName & """ """ & strProfile & "\NTUSER.DAT""" ,0,True)
	' Reg load ProfileLocation\Local Settings\Application Data\Microsoft\Windows\UsrClass.DAT into HKU\%username%_Classes
	ret = objShell.Run("reg load ""HKU\" & UserName & "_Classes"" """ & strProfile & "\Local Settings\Application Data\Microsoft\Windows\UsrClass.DAT""" ,0,True)
	
	'Try both of the following. One should fail, the other should pass.
	' Set ACLs on HKU\%username%
	ret = objShell.Run("subinacl /subkeyreg ""HKEY_USERS\" & UserName & """ /grant=""" & UserName & "@" & DomainFQDN & """=F",0,True)
	' If User is already logged in then the registry will be open at HKU\SDDL
	ret = objShell.Run("subinacl /subkeyreg ""HKEY_USERS\" & GetLocalUserSDDL(UserName) & """ /grant=""" & UserName & "@" & DomainFQDN & """=F",0,True)
	

	'Try both of the following. One should fail, the other should pass.
	' Set ACLs on HKU\%username%
	ret = objShell.Run("subinacl /subkeyreg ""HKEY_USERS\" & UserName & "_Classes"" /grant=""" & UserName & "@" & DomainFQDN & """=F",0,True)
	' If User is already logged in then the registry will be open at HKU\SDDL
	ret = objShell.Run("subinacl /subkeyreg ""HKEY_USERS\" & GetLocalUserSDDL(UserName) & "_Classes"" /grant=""" & UserName & "@" & DomainFQDN & """=F",0,True)

	' Reg unload HKU\%username%
	ret = objShell.Run("reg unload ""HKU\" & UserName & """",0,True)
	' Reg unload HKU\%username%_Classes
	ret = objShell.Run("reg unload ""HKU\" & UserName & "_Classes""",0,True)
	
	' Get Domain User SID from ProfileLocation ACL
	arrSID = GetDomainUserSidFromFolderACL(strProfile, UserName, strDomain)
	
	If UBound(arrSID) > 0 Then
		' Convert Domain User SID to SDDL
		SDDL = ArraySidToStrSid(arrSID)
	
		' Stage Domain User Profile into Registry under HKLM\Software\Microsoft\Windows NT\CurrentVersion\ProfileList\%DomainUserSDDL%
		ret = CreateAndLinkProfile(SDDL, arrSID, strProfile)
	Else
		'Account didn't exist in the domain or ACL failed to set on Folder
	End If
End Function

'**************************************************************************************************
' Creates a Profile and links it to the specified profile path
Function CreateAndLinkProfile(strNewSDDL, strNewSID, strProfilePath)
    On Error Resume Next
    Set objShell = CreateObject("WScript.Shell")
    objShell.RegRead("HKLM\Software\Microsoft\Windows NT\CurrentVersion\ProfileList\" & strNewSDDL & "\ProfileImagePath")
    If Err = 0 Then
        ' Profile already exists, so skip pre-staging
        CreateAndLinkProfile = False
        Exit Function
    End If
    Err.Clear
    On Error Goto 0
    
	'Write Sid to registry
	ret = WriteRegBinaryToRegistry(HKEY_LOCAL_MACHINE,"SOFTWARE\Microsoft\Windows NT\CurrentVersion\ProfileList\" & strNewSDDL,"Sid",strNewSID)
	ret = ret Or WriteRegStringToRegistry(HKEY_LOCAL_MACHINE,"SOFTWARE\Microsoft\Windows NT\CurrentVersion\ProfileList\" & strNewSDDL,"ProfileImagePath",strProfilePath)
	ret = ret Or WriteRegStringToRegistry(HKEY_LOCAL_MACHINE,"SOFTWARE\Microsoft\Windows NT\CurrentVersion\ProfileList\" & strNewSDDL,"CentralProfile","")
	ret = ret Or WriteRegDwordToRegistry(HKEY_LOCAL_MACHINE,"SOFTWARE\Microsoft\Windows NT\CurrentVersion\ProfileList\" & strNewSDDL,"Flags",1)
	ret = ret Or WriteRegDwordToRegistry(HKEY_LOCAL_MACHINE,"SOFTWARE\Microsoft\Windows NT\CurrentVersion\ProfileList\" & strNewSDDL,"State",0)
	CreateAndLinkProfile = ret
End Function

'**************************************************************************************************
' Gets the SDDL (or string Sid) of the Local User passed in UserName
Function GetLocalUserSDDL(UserName)
	strComputer = "."
	Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
	'Enumerate users where the User Domain is the Local Machine and the username matches the Supplied Name
	Set colItems = objWMIService.ExecQuery _
		("Select * from Win32_UserAccount  Where Domain = '" & GetComputerName & "' And Name = '" & UserName & "'")
	GetLocalUserSDDL = ""
    For Each objItem In colItems
    	'Get the first returned SID/SDDL then exit
    	GetLocalUserSDDL = objItem.SID
    	Exit Function
    Next
End Function

'**************************************************************************************************
' Returns the Computer Name
Function GetComputerName()
  Set objNetwork = CreateObject("Wscript.Network")
  GetComputerName = objNetwork.ComputerName
End Function

'**************************************************************************************************
'Gets the Profile Path for the User passed in UserName.
' This requires the profile to exist on the local machine
' Returns an empty string on error
Function GetLocalUserProfile(UserName)
  On Error Resume Next
  GetLocalUserProfile = ""
  SDDL = GetLocalUserSDDL(UserName)
  If SDDL = "" Then
    Exit Function
  End If
  Set objShell = CreateObject("WScript.Shell")
  GetLocalUserProfile = objShell.ExpandEnvironmentStrings(objShell.RegRead("HKLM\Software\Microsoft\Windows NT\CurrentVersion\ProfileList\" & SDDL & "\ProfileImagePath"))
  On Error Goto 0
End Function

'**************************************************************************************************
' Function that gets the Sid of a Domain user from the ACL of a folder
'  The Domain user MUST have already been directly granted permission to the folder
'  for this to work.
Function GetDomainUserSidFromFolderACL(strFolder, strUserName, strUserDomain)
	Dim arrSID(0)
	GetDomainUserSidFromFolderACL = arrSID

	Set objFSO = CreateObject("Scripting.FileSystemObject")
	If Not objFSO.FolderExists(strFolder) Then
		Set objFSO = Nothing
		Exit Function
	End If
	
	' Ensure that strFolder is of the form C:\\Documents and Settings\\UserName
    strFolderName = Replace(strFolder, "\\","\")
    strFolderName = Replace(strFolderName, "\","\\")
    
	Set wmiFileSecSetting = GetObject( _
	   "winmgmts:Win32_LogicalFileSecuritySetting.path='" & strFolderName & "'")
	
	RetVal = wmiFileSecSetting. _
	    GetSecurityDescriptor(wmiSecurityDescriptor)
	If Err <> 0 Then
	    ' Getting Security Descriptor Failed
	    Exit Function
	Else
	    ' Getting Security Descriptor Succeeded
	End If
	
	' Retrieve the DACL array of Win32_ACE objects.
	DACL = wmiSecurityDescriptor.DACL
	
	For each wmiAce in DACL
	
	' Get Win32_Trustee object from ACE 
		Set Trustee = wmiAce.Trustee
		If (StrComp(Trustee.Name, strUserName, vbTextCompare) = 0) And _
		   (StrComp(Trustee.Domain, strUserDomain, vbTextCompare) = 0) Then
			GetDomainUserSidFromFolderACL = Trustee.SID
			Exit Function
		End If
	Next
End Function

'**************************************************************************************************
Function ArraySidToStrSid(arrSid)
    ' Function to convert a Sid stored in an Array (ie from an ACL) to a Decimal string (SDDL) Sid.
    Dim strHex, strDec

    strHex = ArraySidToHexStr(arrSid)
    strDec = HexStrToDecStr(strHex)
    ArraySidToStrSid = strDec
End Function

'**************************************************************************************************
Function ObjSidToStrSid(arrSid)
    ' Function to convert OctetString (byte array) to Decimal string (SDDL) Sid.
    Dim strHex, strDec

    strHex = OctetStrToHexStr(arrSid)
    strDec = HexStrToDecStr(strHex)
    ObjSidToStrSid = strDec
End Function ' ObjSidToStrSid

'**************************************************************************************************
' Function that converts a Sid stored in an Array (ie from an ACL) to a Hex String
Function ArraySidToHexStr(arrSid)
  ArraySidToHexStr = ""
  For Each x In arrSid
    ArraySidToHexStr = ArraySidToHexStr & _
       Right("0" & Hex(x), 2)
  Next
End Function

'**************************************************************************************************
Function OctetStrToHexStr(arrbytOctet)
    ' Function to convert OctetString (byte array) to Hex string.
    Dim k

    OctetStrToHexStr = ""
    For k = 1 To Lenb(arrbytOctet)
        OctetStrToHexStr = OctetStrToHexStr _
            & Right("0" & Hex(Ascb(Midb(arrbytOctet, k, 1))), 2)
    Next
End Function ' OctetStrToHexStr

'**************************************************************************************************
Function HexStrToDecStr(strSid)
    ' Function to convert Hex string Sid to Decimal string (SDDL) Sid.

    ' SID anatomy:
    ' Byte Position
    ' 0   : SID Structure Revision Level (SRL)
    ' 1   : Number of Subauthority/Relative Identifier
    ' 2-7 : Identifier Authority Value (IAV) [48 bits]
    ' 8-x : Variable number of Subauthority or Relative Identifier (RID) [32bits]
    '
    ' Example:
    '
    '   <Domain/Machine>\Administrator
    ' Pos  :    0 |  1 |  2  3  4  5  6  7 |  8  9 10 11 | 12 13 14 15 | 16 17 18 19 | 20 21 22 23 | 24 25 26 27
    ' Value:   01 | 05 | 00 00 00 00 00 05 | 15 00 00 00 | 06 4E 7D 7F | 11 57 56 7A | 04 11 C5 20 | F4 01 00 00
    ' str  : S- 1 |    |                -5 | -21         | -2138918406 | -2052478737 | -549785860  | -500

    Const BYTES_IN_32BITS = 4
    Const SRL_BYTE = 0
    Const IAV_START_BYTE = 2
    Const IAV_END_BYTE = 7
    Const RID_START_BYTE = 8
    Const MSB = 3 'Most significant byte
    Const LSB = 0 'Least significant byte

    Dim arrbytSid, lngTemp, base, offset, i

    ReDim arrbytSid(Len(strSid)/2 - 1)

    ' Convert hex string into integer array
    For i = 0 To UBound(arrbytSid)
        arrbytSid(i) = CInt("&H" & Mid(strSid, 2 * i + 1, 2))
    Next

    ' Add SRL number
    HexStrToDecStr = "S-" & arrbytSid(SRL_BYTE)

    ' Add Identifier Authority Value
    lngTemp = 0
    For i = IAV_START_BYTE To IAV_END_BYTE
        lngTemp = lngTemp * 256 + arrbytSid(i)
    Next
    HexStrToDecStr = HexStrToDecStr & "-" & CStr(lngTemp)

    ' Add a variable number of 32-bit subauthority or
    ' relative identifier (RID) values.
    ' Bytes are in reverse significant order.
    ' i.e. HEX 01 02 03 04 => HEX 04 03 02 01
    ' = (((0 * 256 + 04) * 256 + 03) * 256 + 02) * 256 + 01
    ' = DEC 67305985
    For base = RID_START_BYTE To UBound(arrbytSid) Step BYTES_IN_32BITS
        lngTemp = 0
        For offset = MSB to LSB Step -1
            lngTemp = lngTemp * 256 + arrbytSid(base + offset)
        Next
        HexStrToDecStr = HexStrToDecStr & "-" & CStr(lngTemp)
    Next
End Function ' HexStrToDecStr 

'**************************************************************************************************
' Writes a Binary array to the Registry
Function WriteRegBinaryToRegistry(Hive, strKeyPath, strValueName, ArrValues)
	'strKeyPath = "SOFTWARE\NewKey"
	strComputer = "."
	'iValues = Array(&H01,&Ha2,&H10)
	Set oReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & _
   			   strComputer & "\root\default:StdRegProv")
	oReg.CreateKey Hive,strKeyPath

	oReg.SetBinaryValue Hive, strKeyPath, strValueName,ArrValues
End Function

'**************************************************************************************************
' Writes a Dword to the Registry
Function WriteRegDwordToRegistry(Hive, strKeyPath, strValueName, Value)
	'strKeyPath = "SOFTWARE\NewKey"
	strComputer = "."
	'iValues = Array(&H01,&Ha2,&H10)
	Set oReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & _
   			   strComputer & "\root\default:StdRegProv")
	oReg.CreateKey Hive,strKeyPath

	oReg.SetDwordValue Hive, strKeyPath, strValueName,Value
End Function

'**************************************************************************************************
' Writes a string to the Registry
Function WriteRegStringToRegistry(Hive, strKeyPath, strValueName, Value)
	'strKeyPath = "SOFTWARE\NewKey"
	strComputer = "."
	'iValues = Array(&H01,&Ha2,&H10)
	Set oReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & _
   			   strComputer & "\root\default:StdRegProv")
	oReg.CreateKey Hive,strKeyPath

	oReg.SetStringValue Hive, strKeyPath, strValueName,Value
End Function


'**************************************************************************************************
' Get the Workstations Domain FQDN (if it has one)
' Returns "" if the machine is a not a member of a domain
Function GetDomainFQDN
    GetDomainFQDN = ""
    Set objWMISvc = GetObject( "winmgmts:\\.\root\cimv2" )
    Set colItems = objWMISvc.ExecQuery( "Select * from Win32_ComputerSystem", , 48 )
    For Each objItem in colItems
        strComputerDomain = objItem.Domain
        If objItem.PartOfDomain Then
            GetDomainFQDN = strComputerDomain
        Else
            ' Workgroup Computer, Ignore it
        End If
    Next
End Function


'**************************************************************************************************
' Get the Workstations Domain Short Name (if it has one)
' Returns "" if the machine is a not a member of a domain
Function GetDomainShortName
    GetDomainShortName = ""
    Set objWMISvc = GetObject( "winmgmts:\\.\root\cimv2" )
    Set colItems = objWMISvc.ExecQuery( "Select * from Win32_ComputerSystem", , 48 )
    For Each objItem in colItems
        
        If objItem.PartOfDomain Then
            Set objSystemInfo = CreateObject("ADSystemInfo") 
            GetDomainShortName = objSystemInfo.DomainShortName
        Else
            ' Workgroup Computer, Ignore it
        End If
    Next
End Function


'**************************************************************************************************
' Get the Workstations Workgroup Name (if it has one)
' Returns "" if the machine is a member of a domain
Function GetWorkgroupName
    GetWorkgroupName = ""
    Set objWMISvc = GetObject( "winmgmts:\\.\root\cimv2" )
    Set colItems = objWMISvc.ExecQuery( "Select * from Win32_ComputerSystem", , 48 )
    For Each objItem in colItems
        strComputerDomain = objItem.Domain
        If objItem.PartOfDomain Then
            ' Domain, so Ignore
        Else
            GetWorkgroupName = strComputerDomain
        End If
    Next
End Function