'*************************************************************************************************
' Name: Active Directory Shadow Groups Script
' File: ShadowGroups.vbs
' Description: Creates and maintains security groups based on OU members
'
' Created by Sole Viktor - sole@sole.dk - www.sole.dk
' http://creativecommons.org/licenses/by-sa/3.0/
'
' On Error Resume Next ' uncomment this to see errors that werent supposed to happen
Dim LogFileName
'
' Set constants - EDIT THIS!
'
Const str_Domain = "dc=my,dc=domain,dc=local"
Const str_BaseOU = "ou=Departments," ' limit where to look for ShadowGroup OU/Groups
Const str_DefaultGroupPrefix = "Prefix SHADOWGROUP" ' default prefix to use for shadow groups
Const str_Default_ObjectCategory = "(objectCategory=user)" ' default objects to include in a shadow group
Const str_Default_Scope = "OneLevel" ' OneLevel current ou, SubTree recursive ou search
Const const_DefaultGroupDescription = "Autogenerated shadowgroup - do not edit members manually" ' default description for auto created shadow groups
LogFileName = "\\fileserver.my.domain.local\logshare\logfolder\logfile-" & Date & ".log" ' daily log file
Const boolDebug = False ' Logs all OU and Group members, increases run time considerably
'
' SECURITY SETTINGS - EDIT THIS! (ensures script can not do anything bad)
'
' Impportant if user running script has access to more than shadowgroups, ensure you set below to restrict access!
'

' Enter word that must be present in shadowgroup name
Const sec_GroupName_MustContain = "SHADOWGROUP" ' avoids pointing a shadowgroup destination to an existing security group, thereby controlling its members, i.e. Domain Admins

' Only allow shadowgroup destination in or below source OU
Const sec_GroupOU_equal_targetOU = True

''
'' Aditional information
''
'' To use this script, run it with a scheduled process,
'' it will use Description fields in OU and Group objects to automatically create Shadow Groups
'' Be carefull to avoid duplicate group names, i.e. in auto named groups, with sub OU's having same names
''
'' Notice hardcoded limit on 1000 objects (dictionary and ldap searches for shadowgroup OU/Group)
'' Notice do not run this script in a loop, it is likely to memory leak. Restart the script instead.
'' Notice special characters used in Active Directory objects, may interfere with the scripts ability to successfully run.
''
'' Shadow Groups can be created by adding parameters to the description field of an existing security group
'' or by using the description field of an OU. The description field must begin with SHADOWGROUP,
'' additional parameters may be given comma seperated after the SHADOWGROUP word, with name=value.
'' Parameter = Values
''
'' "Scope" = "OneLevel" (default), only gets members of the targeted OU
''           "SubTree" gets targeted OU and all sub OU's members
''
'' "OU" = "OU/OU/OU" the OU Path to target, a full dn of LDAP://ou=A,ou=B,dc=mydomain,dc=local,
'' must be written as "A/B", notice only real OU's may be in path, no builtin OU's, also no domain.
''
'' "GroupOU" = "OU/OU/OU" the path to the OU where the shadow group is to be placed, same format as "OU"
''
'' "GroupName" = "SHADOWGROUP Department Sales" the full custom name for the shadow group
''
'' "GroupPrefix" = "SHADOWGROUP Department" group prefix, will be appended with the source OU name
''
'' "OBJ" = "CUG" A combination of letters designating what objects to include in the Shadow Group
'' C = Computers, U = Users, G = Groups
''
'' "#" = "Description text" this parameter is ignored, but can be used to add description text to the OU/Group for other uses.
'' 
'' SCRIPT START - DO NOT EDIT BELOW THIS LINE ----------------------------------------------------
'' -----------------------------------------------------------------------------------------------

' Script constants, dont edit this
Const ScriptVersion = "0.2"
Const ADS_GROUP_TYPE_GLOBAL_GROUP = &h2
Const ADS_GROUP_TYPE_SECURITY_ENABLED = &h80000000
Const ADS_PROPERTY_APPEND = 3
Const ADS_PROPERTY_DELETE = 4

' setting time of script start for logging purposes
Dim startTime, endTime
startTime = Timer

' Set vars used for counting what changes where made and logging
Dim count_GroupCreated, count_GroupProcessed, count_GroupAborted, count_MemberAdded, count_MemberRemoved, str_LogText
count_GroupCreated = 0
count_GroupProcessed = 0
count_GroupAborted = 0
count_MemberAdded = 0
count_MemberRemoved = 0

WriteLog "Script started - version " & ScriptVersion & " - " & Date & " " & Time

'Setting global dictionaries for ou and group objects
Dim dictOUObjects, dictGroupObjects
Set dictOUObjects = CreateObject("Scripting.Dictionary")
dictOUObjects.CompareMode = TextMode
Set dictGroupObjects = CreateObject("Scripting.Dictionary")
dictGroupObjects.CompareMode = TextMode


' Find shadow groups to create/update
' Find OU's with shadow group enabled
Start_Update_OU Find_OU_ShadowGroup()
WriteLog "Done getting ShadowGroup OU's"

' Find Group's that are shadow group enabled
Start_Update_Group Find_Group_ShadowGroup()
WriteLog "Done getting ShadowGroup Groups"

'' Script finished
WriteLog ""
WriteLog "Groups processed:          " & vbTab & count_GroupProcessed
WriteLog "Groups created:            " & vbTab & count_GroupCreated
WriteLog "Groups aborted:            " & vbTab & count_GroupAborted
WriteLog "Members added to group:    " & vbTab & count_MemberAdded
WriteLog "Members removed from group:" & vbTab & count_MemberRemoved

WriteLog "Script finished - version " & ScriptVersion & " - " & Date & " " & Time
WriteLogFile
WScript.Quit

''' MAIN FUNCTIONS

Function Start_Do_Parameters (Parameters, OUName, OUPath, GroupName, GroupCN)
    Dim arr_Parameters, str_Parameters, str_Scope, str_ObjectCategory
    str_ObjectCategory = str_Default_ObjectCategory
    str_Scope = str_Default_Scope
    str_GroupPrefix = str_DefaultGroupPrefix
    ' Go thru parameters
    arr_Parameters = Split(Parameters,",")
    For Each str_Parameter In arr_Parameters
        arr_tmp_parm = Split(str_Parameter, "=")
        Select Case UCase(arr_tmp_parm(0))
            Case "SHADOWGROUP"
            'Ignore			
            Case "#"
            'Ignore			
            Case "SCOPE"
            ' Check if we should search subtree of ou
            If UCase(arr_tmp_parm(1)) = "SUBTREE" Or UCase(arr_tmp_parm(1)) = "SUB" Or UCase(arr_tmp_parm(1)) = "1" Then
                str_Scope = "SubTree"
            End If
            Case "OU"
            ' Check if we have a OU path
            OUPath = "LDAP://ou=" & Replace(arr_tmp_parm(1), "/", ",ou=") & "," & str_Domain
            arr_tmp_ouname = Split(arr_tmp_parm(1), "/")
            OUName = arr_tmp_ouname(0)
            Case "GROUPOU"
            ' Check if we have a OU path
            GroupPath = "LDAP://ou=" & Replace(arr_tmp_parm(1), "/", ",ou=") & "," & str_Domain
            Case "GROUPNAME"
            ' Check if we have a OU path
            GroupName = arr_tmp_parm(1)
            Case "GROUPPREFIX"
            ' Check if we have a OU path
            str_GroupPrefix = arr_tmp_parm(1)
            Case "OBJ"
            str_ObjectCategory = ""
            If InStr(arr_tmp_parm(1), "U") Then str_ObjectCategory = str_ObjectCategory & "(objectCategory=User)"
            If InStr(arr_tmp_parm(1), "C") Then str_ObjectCategory = str_ObjectCategory & "(objectCategory=Computer)"
            If InStr(arr_tmp_parm(1), "G") Then str_ObjectCategory = str_ObjectCategory & "(objectCategory=Group)"
            If Len(arr_tmp_parm(1)) > 1 Then str_ObjectCategory = "(|" & str_ObjectCategory & ")"
            Case Else
            WriteLog "Unknown parameter: " & str_Parameter
        End Select
    Next		
    ' Figure out defaults
    If GroupName = "" Then
        GroupName = str_GroupPrefix & " " & OUName
    End If
    If GroupPath = "" Then
        GroupPath = OUPath
    End If
    If GroupCN = "" Then
        GroupCN = "LDAP://CN=" & GroupName & "," & Right(GroupPath,Len(GroupPath)-7)
    End If
    
    WriteLog "GroupName: " & GroupName
    '    WriteLog "GroupPath: " & GroupPath
    WriteLog "GroupCN: " & GroupCN
    '    WriteLog "OUName: " & OUName
    WriteLog "OUPath: " & OUPath
    WriteLog "Scope: " & str_Scope
    WriteLog "ObjectCategory: " & str_ObjectCategory
    
    ''' SECURITY CHECK IF GROUPNAME CONTAINS
    If InStr(GroupName, sec_GroupName_MustContain) = 0 Or InStr(GroupCN, sec_GroupName_MustContain) = 0 Then
        ' Group name does not contain our security word
        WriteLog "XXX - This group does not contain the security word, this group will not be updated!"
        WriteLog "XXX - This security word must be in all Shadow Group names: " & sec_GroupName_MustContain
        count_GroupAborted = count_GroupAborted + 1
        Exit Function
    End If
    
    ''' SECURITY CHECK IF GroupOU is same as target OU
    If sec_GroupOU_equal_targetOU Then
        ' This means they must be same, otherwise we ignore
        If InStr(GroupCN, Right(OUPath, Len(OUPath)-7)) = 0 Then
            ' target OU is not part of group ou
            WriteLog "XXX - This group is not placed below the target OU, this group will not be updated!"
            count_GroupAborted = count_GroupAborted + 1
            Exit Function
        End If
    End If
    
    '' Start the updating of the defined shadow group
    Start_Update_ShadowGroup OUPath, GroupCN, str_Scope, str_ObjectCategory
End Function

Function Start_Update_ShadowGroup (ByVal dnOU, dnGroup, str_Scope, strObjectCategory)
    count_GroupProcessed = count_GroupProcessed + 1
    dictGroupObjects.RemoveAll
    dictOUObjects.RemoveAll
    WriteLog "Updating group: " & dnGroup
    Find_OU_Objects dnOU, strObjectCategory, str_Scope, dnGroup
    Find_Group_Objects dnGroup
    Add_Group_Objects dnGroup
    Remove_Group_Objects dnGroup
End Function

Function Remove_Group_Objects (ByVal dnGroup)
    For Each removeObject In dictGroupObjects.Items
        If Not dictOUObjects.Exists(removeObject) Then
            ' object is not in OU lets remove it
            Set objGroup = GetObject(dnGroup)
            objGroup.PutEx ADS_PROPERTY_DELETE,"member",Array(removeObject)
            objGroup.SetInfo
            WriteLog vbTab & " - removing object from group: " & removeObject
            count_MemberRemoved = count_MemberRemoved + 1
            Set objGroup = Nothing
        End If
    Next
End Function

Function Add_Group_Objects (ByVal dnGroup)
    For Each addObject In dictOUObjects.Items
        If Not dictGroupObjects.Exists(addObject) Then
            ' object is not in group lets add it
            Set objGroup = GetObject(dnGroup)
            objGroup.PutEx ADS_PROPERTY_APPEND,"member",Array(addObject)
            objGroup.SetInfo
            WriteLog vbTab & " + adding object to group: " & addObject
            count_MemberAdded = count_MemberAdded + 1
            Set objGroup = Nothing
        End If
    Next
End Function

Function Find_OU_Objects (ByVal dnOU, strObjectCategory, str_Scope, dnGroup)
    Set objConnection = CreateObject("ADODB.Connection")
    Set objCommand =   CreateObject("ADODB.Command")
    objConnection.Provider = "ADsDSOObject"
    objConnection.Open "Active Directory Provider"
    Set objCommand.ActiveConnection = objConnection	
    objCommand.Properties("Page Size") = 1000	
    objCommand.CommandText = _
    "<"_
    & dnOU &_
    ">;"_
    & strObjectCategory &_
    ";AdsPath;"_
    & str_Scope
    Set objRecordSet = objCommand.Execute
    If objRecordSet.EOF = False Then objRecordSet.MoveFirst
    Do Until objRecordSet.EOF
        tmp_object = Right(objRecordSet.Fields("AdsPath").Value, Len(objRecordSet.Fields("AdsPath").Value) -7)
        ' we dont want the actual shadow group as a member
        If objRecordSet.Fields("AdsPath").Value <> dnGroup Then
            ' we do not like special chars in names, add more if you find them
            tmp_object = Replace(tmp_object, "\/", "/")
            ' add object to dictionary
            dictOUObjects.Add tmp_object, tmp_object
            If boolDebug Then WriteLog vbTab & "OU member " & tmp_object
        End If
        objRecordSet.MoveNext
    Loop
    Set objCommand = Nothing
    Set objConnection = Nothing
End Function

Function Find_Group_Objects (Byval dnGroup)
    On Error Resume Next ' In case group doesnt exist
    Dim member, arrMemberOf
    
    Set objGroup = GetObject(dnGroup)
    If Err.Number = -2147016656 Then
        ' Group does not exist
        Err.Clear
        '  Create new Group
        arr_tmp_ou = Split ( dnGroup, ",", 2 )
        arr_tmp_cn = Split ( arr_tmp_ou(0), "//", 2)
        arr_tmp_name = Split ( arr_tmp_cn(1), "=", 2)
        WriteLog "Creating group " & arr_tmp_name(1) & " / " & arr_tmp_cn(1) & " in ou " & arr_tmp_ou(1) & " err: " & Err.Number
        Set objOU = GetObject("LDAP://" & arr_tmp_ou(1))
        Set objGroup = objOU.Create("Group", arr_tmp_cn(1))
        objGroup.Put "sAMAccountName", arr_tmp_name(1)
        objGroup.Put "description", Array(const_DefaultGroupDescription)
        objGroup.Put "groupType", ADS_GROUP_TYPE_GLOBAL_GROUP Or ADS_GROUP_TYPE_SECURITY_ENABLED
        Err.Clear
        objGroup.SetInfo
        If Err.Number <> 0 Then
            WriteLog "Problem creating group, possibly allready exists or sam account name used: " & arr_tmp_name(1)
            Err.Clear
        Else
            WriteLog "Created group successfully"
            count_GroupCreated = count_GroupCreated + 1
        End If
    End If
    objGroup.GetInfo
    arrMemberOf = objGroup.GetEx("member")
    If Err.Number = -2147463155 Then
        ' Group has no members
        Err.Clear
        Exit Function
    End If
    For Each member In arrMemberOf
        'Add the user to a dictionary object
        dictGroupObjects.Add member, member
        If boolDebug Then WriteLog vbTab & "Group Member " & member
    Next
    Set objGroup = Nothing
End Function

Function WriteLog (strLog)
    currentTime = Timer - startTime
    If currentTime < 0.1 Then currentTime = "0,0"
    If Len(currentTime) > 5 Then currentTime = Left(currentTime, 5)
    currentTime = currentTime & "s"
    While Len(currentTime) < 6
        currentTime = currentTime & " "
    Wend
    WScript.Echo currentTime & vbTab & strLog
    str_LogText = str_LogText & currentTime & vbTab & strLog & vbCrLf
End Function

Function WriteLogFile ()
    WriteLog "Appending log to file: " & LogFileName
	Set fso = CreateObject("Scripting.FileSystemObject") ' used for file operations
    Set theLog = fso.OpenTextFile(LogFileName, 8, True)
    theLog.WriteLine(str_LogText)
    theLog.Close
    Set theLog = Nothing
    Set fso = Nothing
    str_LogText = ""
End Function


Function Start_Update_OU(arr_OU)
    Dim i
    i = 0
    While arr_OU(i,0) <> ""
        Err.Clear
        WriteLog "SG Object " & arr_OU(i,2)
        WriteLog "SG Parameter " & arr_OU(i,1)
        'Start_Do_Parameters Parameters, OUName, OUpath, GroupName, GroupOU
        Start_Do_Parameters arr_OU(i,1), arr_OU(i,0), arr_OU(i,2), "", ""
        If Err.Number <> 0 Then
            WriteLog "ErrNumber:" & Err.Number
            WriteLog "ErrDescription:" & Err.Description
            WriteLog "ErrSource:" & Err.Source
        End If
        WriteLog ""
        i = i + 1
    Wend
End Function

Function Start_Update_Group(arr_Group)
    Dim i
    i = 0
    While arr_Group(i,0) <> ""
        Err.Clear
        WriteLog "SG Object " & arr_Group(i,2)
        WriteLog "SG Parameter " & arr_Group(i,1)
        'Start_Do_Parameters Parameters, OUName, OUpath, GroupName, GroupOU
        Start_Do_Parameters arr_Group(i,1), "", "", arr_Group(i,0), arr_Group(i,2)
        If Err.Number <> 0 Then
            WriteLog "ErrNumber:" & Err.Number
            WriteLog "ErrDescription:" & Err.Description
            WriteLog "ErrSource:" & Err.Source
        End If
        WriteLog ""
        i = i + 1
    Wend
End Function


' Find OU's with Shadow Group properties
Function Find_OU_ShadowGroup ()
    Dim arr_tmp_object(1000,2)
    On Error Resume Next
    WriteLog "Getting OU's with shadowgroup in description"
    Set objConnection = CreateObject("ADODB.Connection")
    Set objCommand =   CreateObject("ADODB.Command")
    objConnection.Provider = "ADsDSOObject"
    objConnection.Open "Active Directory Provider"
    Set objCommand.ActiveConnection = objConnection	
    objCommand.Properties("Page Size") = 1000	
    objCommand.CommandText = _
    "<LDAP://" & str_BaseOU & str_Domain &_
    ">;(&(objectCategory=OrganizationalUnit)(description=SHADOWGROUP*));Name,AdsPath,description;Subtree"
    Set objRecordSet = objCommand.Execute
    objRecordSet.MoveFirst
    count_obj = 0
    Do Until objRecordSet.EOF
        arr_tmp_object(count_obj,0) = objRecordSet.Fields("Name").Value
        arrDescription = objRecordSet.Fields("description").Value
        arr_tmp_object(count_obj,1) = arrDescription(0)
        arr_tmp_object(count_obj,2) = objRecordSet.Fields("AdsPath").Value
        count_obj = count_obj + 1
        objRecordSet.MoveNext
    Loop
    Find_OU_ShadowGroup = arr_tmp_object
    Set objCommand = Nothing
    Set objConnection = Nothing
End Function

' Find Group's with Shadow Group properties
Function Find_Group_ShadowGroup ()
    Dim arr_tmp_object(1000,2)
    On Error Resume Next
    WriteLog "Getting Groups with shadowgroup in description"
    Set objConnection = CreateObject("ADODB.Connection")
    Set objCommand =   CreateObject("ADODB.Command")
    objConnection.Provider = "ADsDSOObject"
    objConnection.Open "Active Directory Provider"
    Set objCommand.ActiveConnection = objConnection	
    objCommand.Properties("Page Size") = 1000	
    objCommand.CommandText = _
    "<LDAP://" & str_BaseOU & str_Domain &_
    ">;(&(objectCategory=Group)(description=SHADOWGROUP*));Name,AdsPath,description;Subtree"  
    Set objRecordSet = objCommand.Execute
    objRecordSet.MoveFirst	
    count_obj = 0
    Do Until objRecordSet.EOF
        arr_tmp_object(count_obj,0) = objRecordSet.Fields("Name").Value
        arrDescription = objRecordSet.Fields("description").Value
        arr_tmp_object(count_obj,1) = arrDescription(0)
        arr_tmp_object(count_obj,2) = objRecordSet.Fields("AdsPath").Value
        count_obj = count_obj + 1
        objRecordSet.MoveNext
    Loop
    Find_Group_ShadowGroup = arr_tmp_object
    Set objCommand = Nothing
    Set objConnection = Nothing
End Function