An error has occurred in the script on this page

regsvr32 msscript.ocx
regsvr32 dispex.dll
regsvr32 vbscript.dll

Performs an LDAP Search Based on Given Criteria

'********************************************************************
'*
'* File:        SEARCH.VBS
'* Created:     August 1998
'* Version:     1.0
'*
'* Main Function: Performs an LDAP search based on given criteria.
'* Usage: SEARCH.VBS adspath [/C:criteria] [/S:scope] [/P:properties]
'*        [/O:outputfile] [/U:username] [/W:password] [/Q]
'*
'* Copyright (C) 1998 Microsoft Corporation
'*
'********************************************************************

OPTION EXPLICIT
ON ERROR RESUME NEXT

'Define constants
CONST CONST_ERROR                   = 0
CONST CONST_WSCRIPT                 = 1
CONST CONST_CSCRIPT                 = 2
CONST CONST_SHOW_USAGE              = 3
CONST CONST_PROCEED                 = 4

'Declare variables
Dim strOutputFile, intOpMode, blnQuiet, i
Dim strADsPath, strCriteria, strProperties,  strScope, strUserName, strPassword
ReDim strArgumentArray(0)

'Initialize variables
strArgumentArray(0) = ""
blnQuiet = False
strADsPath = ""
strCriteria = "ObjectCategory=*"
strProperties = "ADsPath;"
strScope = "OneLevel"
strUserName = ""
strPassword = ""
strOutputFile = ""

'Get the command line arguments
For i = 0 to Wscript.arguments.count - 1
    ReDim Preserve strArgumentArray(i)
    strArgumentArray(i) = Wscript.arguments.Item(i)
Next

'Check whether the script is run using CScript
Select Case intChkProgram()
    Case CONST_CSCRIPT
        'Do Nothing
    Case CONST_WSCRIPT
        WScript.Echo "Please run this script using CScript." & vbCRLF & _
            "This can be achieved by" & vbCRLF & _
            "1. Using ""CScript SEARCH.vbs arguments"" for Windows 95/98 or" & vbCRLF & _
            "2. Changing the default Windows Scripting Host setting to CScript" & vbCRLF & _
            "    using ""CScript //H:CScript //S"" and running the script using" & vbCRLF & _
            "    ""SEARCH.vbs arguments"" for Windows NT."
        WScript.Quit
    Case Else
        WScript.Quit
End Select


'Parse the command line
intOpMode = intParseCmdLine(strArgumentArray, strADsPath, strCriteria, strProperties, _
            strScope, blnQuiet, strUserName, strPassword, strOutputFile)
If Err.Number then
    Print "Error 0x" & CStr(Hex(Err.Number)) & " occurred in parsing the command line."
    If Err.Description <> "" Then
        Print "Error description: " & Err.Description & "."
    End If
    WScript.Quit
End If

Select Case intOpMode
    Case CONST_SHOW_USAGE
        Call ShowUsage()
    Case CONST_PROCEED
        Call Search(strADsPath, strCriteria, strProperties, _
             strScope, strUserName, strPassword, strOutputFile)
    Case CONST_ERROR
        'Do nothing.
    Case Else                    'Default -- should never happen
        Print "Error occurred in passing parameters."
End Select

'********************************************************************
'*
'* Function intChkProgram()
'* Purpose: Determines which program is used to run this script.
'* Input:   None
'* Output:  intChkProgram is set to one of CONST_ERROR, CONST_WSCRIPT,
'*          and CONST_CSCRIPT.
'*
'********************************************************************

Private Function intChkProgram()

    ON ERROR RESUME NEXT

    Dim strFullName, strCommand, i, j

    'strFullName should be something like C:\WINDOWS\COMMAND\CSCRIPT.EXE
    strFullName = WScript.FullName
    If Err.Number then
        Print "Error 0x" & CStr(Hex(Err.Number)) & " occurred."
        If Err.Description <> "" Then
            If Err.Description <> "" Then
                Print "Error description: " & Err.Description & "."
            End If
        End If
        intChkProgram =  CONST_ERROR
        Exit Function
    End If

    i = InStr(1, strFullName, ".exe", 1)
    If i = 0 Then
        intChkProgram =  CONST_ERROR
        Exit Function
    Else
        j = InStrRev(strFullName, "\", i, 1)
        If j = 0 Then
            intChkProgram =  CONST_ERROR
            Exit Function
        Else
            strCommand = Mid(strFullName, j+1, i-j-1)
            Select Case LCase(strCommand)
                Case "cscript"
                    intChkProgram = CONST_CSCRIPT
                Case "wscript"
                    intChkProgram = CONST_WSCRIPT
                Case Else       'should never happen
                    Print "An unexpected program is used to run this script."
                    Print "Only CScript.Exe or WScript.Exe can be used to run this script."
                    intChkProgram = CONST_ERROR
            End Select
        End If
    End If

End Function

'********************************************************************
'*
'* Function intParseCmdLine()
'* Purpose: Parses the command line.
'* Input:   strArgumentArray    an array containing input from the command line
'* Output:  strADsPath          ADsPath of the root of the search
'*          strCriteria         the search criteria
'*          strProperties       properties to be retrieved
'*          strScope            the search scope
'*          strUserName         name of the current user
'*          strPassword         password of the current user
'*          strOutputFile       an output file name
'*          blnQuiet            specifies whether to suppress messages
'*          intParseCmdLine     is set to one of CONST_ERROR, CONST_SHOW_USAGE, CONST_PROCEED.
'*
'********************************************************************

Private Function intParseCmdLine(strArgumentArray, strADsPath, strCriteria, _
        strProperties, strScope, blnQuiet, strUserName, strPassword, strOutputFile)

    ON ERROR RESUME NEXT

    Dim strFlag, i

    strFlag = strArgumentArray(0)

    If strFlag = "" then                'No arguments have been received
        Print "Arguments are required."
        intParseCmdLine = CONST_ERROR
        Exit Function
    End If

    If (strFlag="help") OR (strFlag="/h") OR (strFlag="\h") OR (strFlag="-h") _
        OR (strFlag = "\?") OR (strFlag = "/?") OR (strFlag = "?") OR (strFlag="h") Then
        intParseCmdLine = CONST_SHOW_USAGE
        Exit Function
    End If

    strADsPath = FormatProvider(strFlag)    'The first parameter must be the ADsPath.

    For i = 1 to UBound(strArgumentArray)
        strFlag = LCase(Left(strArgumentArray(i), InStr(1, strArgumentArray(i), ":")-1))
        If Err.Number Then            'An error occurs if there is no : in the string
            Err.Clear
            If LCase(strArgumentArray(i)) = "/q" Then
                blnQuiet = True
            Else
                Print strArgumentArray(i) & " is not recognized as a valid input."
                intParseCmdLine = CONST_ERROR
                Exit Function
            End If
        Else
            Select Case strFlag
                Case "/c"
                    strCriteria = Right(strArgumentArray(i), Len(strArgumentArray(i))-3)
                Case "/p"
                    strProperties = Right(strArgumentArray(i), Len(strArgumentArray(i))-3) & ";"
                Case "/s"
                    strScope = Right(strArgumentArray(i), Len(strArgumentArray(i))-3)
                Case "/u"
                    strUserName = Right(strArgumentArray(i), Len(strArgumentArray(i))-3)
                Case "/w"
                    strPassword = Right(strArgumentArray(i), Len(strArgumentArray(i))-3)
                Case "/o"
                    strOutputFile = Right(strArgumentArray(i), Len(strArgumentArray(i))-3)
                Case else
                    Print "Invalid flag " & """" & strFlag & """" & "."
                    Print "Please check the input and try again."
                    intParseCmdLine = CONST_ERROR
                    Exit Function
                End Select
        End If
    Next

    intParseCmdLine = CONST_PROCEED

End Function

'********************************************************************
'*
'* Sub ShowUsage()
'* Purpose: Shows the correct usage to the user.
'* Input:   None
'* Output:  Help messages are displayed on screen.
'*
'********************************************************************

Private Sub ShowUsage()

    Wscript.Echo ""
    Wscript.Echo "Performs an LDAP search based on a given criteria." & vbCRLF
    Wscript.Echo "SEARCH.VBS adspath [/C:criteria] [/S:scope] [/P:properties]"
    Wscript.Echo "[/O:outputfile] [/U:username] [/W:password] [/Q]"
    Wscript.echo "   /C, /S, /P, /O, /U, /W"
    Wscript.Echo "                 Parameter specifiers."
    Wscript.echo "   adspath       ADsPath of a user object container."
    Wscript.echo "   criteria      Criteria of the search."
    Wscript.echo "   scope         Sope of the search."
    Wscript.echo "   properties    Properties to be retrieved."
    Wscript.Echo "   outputfile    The output file name."
    Wscript.echo "   username      Username of the current user."
    Wscript.echo "   password      Password of the current user."
    Wscript.echo "   /Q            Suppresses all output messages." & vbCRLF
    Wscript.Echo "DEFAULT VALUES:"
    Wscript.Echo "   If /C is not specified the default is ObjectCategory=*."
    Wscript.Echo "   If /S is not specified the default is OneLevel."
    Wscript.Echo "   If /P is not specified the default is ADsPath." & vbCRLF
    Wscript.Echo "EXAMPLE:"
    Wscript.Echo "SEARCH.VBS ""LDAP://DC=FooFoo,DC=Foo,DC=Com"""
    Wscript.Echo "   /C:""&(ObjectCategory=user)(cn=b*)"" /P:Name /S:SubTree"
    Wscript.Echo "   lists names of all users in domain FooFoo with"
    Wscript.Echo "   cn starting with ""b""." & vbCRLF
    Wscript.Echo "NOTE:"
    Wscript.Echo "   This script requires an LDAP provider."

End Sub

'********************************************************************
'*
'* Sub Search()
'* Purpose: Performs an LDAP search based on a given criteria.
'* Input:   strADsPath      ADsPath of the root of the search
'*          strCriteria     the search criteria
'*          strProperties   properties to be retrieved
'*          strScope        the search scope
'*          strUserName     name of the current user
'*          strPassword     password of the current user
'*          strOutputFile   an output file name
'* Output:  Results of the search are either printed on screen or saved in strOutputFile.
'*
'********************************************************************

Private Sub Search(strADsPath, strCriteria, strProperties, _
    strScope, strUserName, strPassword, strOutputFile)

    ON ERROR RESUME NEXT

    Dim strProvider, strSearchPath, objConnect, objCommand
    Dim  objFileSystem, objOutputFile, objRecordSet, intResult

    'Make sure that the provide is LDAP
    strProvider = Left(strADsPath, InStr(1, strADsPath, ":"))
    If strProvider <> "LDAP:" then
        Print "The provider is not LDAP:."
        Wscript.Quit
    End If

    If strOutputFile = "" Then
        objOutputFile = ""
    Else
        'Create a filesystem object
        set objFileSystem = CreateObject("Scripting.FileSystemObject")
        If Err.Number then
            Print "Error 0x" & CStr(Hex(Err.Number)) & " opening a filesystem object."
            If Err.Description <> "" Then
                Print "Error description: " & Err.Description & "."
            End If
            Exit Sub
        End If
        'Open the file for output
        set objOutputFile = objFileSystem.OpenTextFile(strOutputFile, 8, True)
        If Err.Number then
            Print "Error 0x" & CStr(Hex(Err.Number)) & " opening file " & strOutputFile
            If Err.Description <> "" Then
                Print "Error description: " & Err.Description & "."
            End If
            Exit Sub
        End If
    End If

    strSearchPath =  "<" & strADsPath & ">;"
    strCriteria = "(" & strCriteria & ");"

    Set objConnect = CreateObject("ADODB.Connection")
    If Err.Number then
        Print "Error 0x" & CStr(Hex(Err.Number)) & " ocurred in opening a connection."
        If Err.Description <> "" Then
            Print "Error description: " & Err.Description & "."
        End If
        Exit Sub
    End If

    Set objCommand = CreateObject("ADODB.Command")
    If Err.Number then
        Print "Error 0x" & CStr(Hex(Err.Number)) & " ocurred in creating the command object."
        If Err.Description <> "" Then
            Print "Error description: " & Err.Description & "."
        End If
        Exit Sub
    End If

    objConnect.Provider = "ADsDSOObject"
    If strUserName = "" then
        objConnect.Open "Active Directory Provider"
    Else
        objConnect.Open "Active Directory Provider", strUserName, strPassword
    End If
    If Err.Number then
        Print "Error 0x" & CStr(Hex(Err.Number)) & " ocurred opening a provider."
        If Err.Description <> "" Then
            Print "Error description: " & Err.Description & "."
        End If
        Exit Sub
    End If

    Set objCommand.ActiveConnection = objConnect

    'Set the query string and other properties
    objCommand.CommandText  = strSearchPath & strCriteria & strProperties & strScope
    objCommand.Properties("Page Size") = 100000                    'reset search properties
    objCommand.Properties("Timeout") = 300000 'seconds
'    objCommand.Properties("SearchScope") = 2

    'After setting all the parameter now execute the search and display the results.
    intResult = intExecuteSearch(objRecordSet, objCommand, objOutputFile)

    If strOutputFile <> "" Then
        objOutputFile.Close
        If intResult > 0 Then
            Wscript.Echo "Results are saved in file " & strOutputFile & "."
        End If
    End If

End Sub

'********************************************************************
'*
'* Function intExecuteSearch()
'* Purpose: Performs an LDAP search based on given criteria
'* Input:   objRecordSet    a recordset to store the info returned
'*          objCommand      the query command object
'*          objOutputFile   an output file object
'* Output:  Results of the search are either printed on screen or saved in objOutputFile.
'*          intExecuteSearch is set to -1 if the search failed or the number of objects
'*          found if succeeded.
'*
'********************************************************************

Private Function intExecuteSearch(objRecordSet, objCommand, objOutputFile)

    ON ERROR RESUME NEXT

    Dim  intNumObjects, i, j , k, intUBound, strMessage

    intNumObjects = 0
    intUBound = 0
    intExecuteSearch = 0

    'Let the user know what is going on
    Print objCommand.CommandText

    'Execute the query
    Set objRecordSet = objCommand.Execute
    Print "Finished the query."
    If Err.Number then
        Print "Error 0x" & CStr(Hex(Err.Number)) & " ocurred during the query."
        If Err.Description <> "" Then
            Print "Error description: " & Err.Description & "."
        End If
        Err.Clear
        intExecuteSearch = -1        'failed
        Exit Function
    End If

    'Get the total number of objects found.
    objRecordSet.MoveLast
    intNumObjects = objRecordSet.RecordCount
    intExecuteSearch = intNumObjects    'Succeeded

    If intNumObjects Then                'If intNumObjects is not zero
        Wscript.Echo "Found " & intNumObjects & " objects."
        objRecordSet.MoveFirst
        k = 1
        While Not objRecordSet.EOF
            For i = 0 To objRecordSet.Fields.Count - 1
                intUBound = UBound(objRecordSet.Fields(i).Value)

                If Err.Number Then
                    'This means that it is a single valued property.
                    Err.Clear
                    strMessage = objRecordSet.Fields(i).Name & " " & k & " = " _
                        & objRecordSet.Fields(i).Value
                Else                            'It is a multivalued property.
                    If intUBound = 0 Then        'There is only one implemented
                        strMessage = objRecordSet.Fields(i).Name & " " & k & " = " _
                            & objRecordSet.Fields(i).Value(0)
                    Else                        'It is truely multivalued.
                        strMessage = objRecordSet.Fields(i).Name & " " & k
                        For j = 0 to intUBound
                            strMessage = strMessage & vbCRLF & "     " & j+1 & " " _
                                & objRecordSet.Fields(i).Value(j)
                        Next
                    End If
                End If
                WriteLine strMessage, objOutputFile
            Next
            objRecordSet.MoveNext
            k = k + 1
        Wend
    Else
        Wscript.Echo "No object satisfying the criteria has been found within " _
            & strADsPath & "."
    End If

End Function

'********************************************************************
'*
'* Sub WriteLine()
'* Purpose: Writes a text line either to a file or on screen.
'* Input:   strMessage  the string to print
'*          objFile     an output file object
'* Output:  strMessage is either displayed on screen or written to a file.
'*
'********************************************************************

Sub WriteLine(ByRef strMessage, ByRef objFile)

    If IsObject(objFile) then        'objFile should be a file object
        objFile.WriteLine strMessage
    Else
        Wscript.Echo  strMessage
    End If

End Sub

'********************************************************************
'*
'* Sub Print()
'* Purpose: Prints a message on screen if blnQuiet = False.
'* Input:   strMessage      the string to print
'* Output:  strMessage is printed on screen if blnQuiet = False.
'*
'********************************************************************

Sub Print(ByRef strMessage)
    If Not blnQuiet then
        Wscript.Echo  strMessage
    End If
End Sub

'********************************************************************
'*
'* Function FormatProvider
'* Purpose: Formats Provider so it is not case sensitive
'* Input:   Provider    a string
'* Output:  FormatProvider is the Provider with the correct Case
'*
'********************************************************************

Private Function FormatProvider(Provider)
    FormatProvider = ""
    I = 1
    Do Until Mid(Provider, I, 1) = ":"
        If I = Len(Provider) Then
            'This Provider is Probabaly not valid, but we'll let it pass anyways.
            FormatProvider = Provider
            Exit Function
        End If
        I = I + 1
    Loop

    Select Case LCase(Left(Provider, I - 1))
        Case "winnt"
            FormatProvider = "WinNT" & Right(Provider,Len(Provider) - (I - 1))
        Case "ldap"
            FormatProvider = "LDAP" & Right(Provider,Len(Provider) - (I - 1))   
    End Select


End Function


'********************************************************************
'*                                                                  *
'*                           End of File                            *
'*                                                                  *
'********************************************************************

'********************************************************************
'*
'* Procedures calling sequence: SEARCH.VBS
'*
'*    intParseCmdLine
'*    ShowUsage
'*    Search
'*        intExecuteSearch
'*            WriteLine
'*
'********************************************************************

'********************************************************************

DACL : Set Filesystem and Registry ACL

Option Explicit

' Set Filesystem and Registry ACL
' ===============================
'
' Author: Tobias Oetiker  
'         based on code by Nick Pearce, Craig Paterson and Rich Ellis
'
' Version: 1.2 -- 2001/05/08
'
' Changes: 1.1 Handle non-existing registry keys gracefully.
' Changes: 1.2 Added "K" option for simulating 1777 permission
'
' The purpose of this script is to allow ACL maniputlations
' to be performed by Microsoft Installer Packages (.msi)
'
' Add your ACL modification instructions to this script
' and integrate it as a Custom Action into the MSI.
'
' SETUP
' =====
'
' Note aclfix needs ADsSecurity.dll and RegObj.dll to work. 
' You can get ADsSecurity from ADSI SDK 2.5 under (/ResourceKit/ADsSecurity.dll)
'
' Get the sdk from
' http://msdownload.microsoft.com:80/msdownload/adsi/2.5/sdk/x86/en/Sdk.zip
' copy the dll to a place in your path and run 
'
' RegObj.dll is included in Office 2000 SR2 or also available directly from
' MS for registered VB users.
'
' regsvr32 regobj.dll
' regsvr32 adssecurity.dll 
'
' Usage with WISE for Windows Installer
' =====================================
' * add a copy of the two dlls to the package and install them somewhere
'   below the INSTALLDIR of the package. Make sure you click Self register in
'   the file property dialog
'
' * customize the dacl.vbs according to the needs of the application and add it
'   to the msi somewhere below INSTALLDIR. Maybe next to the dlls
' 
' * Add a custom action: Type:    Call Exe File
'                        Source:  File on destination machine
'                        Name:    DACL
'                        InstDir: SystemFolder
'                        Exe Cmd: wscript.exe "[!dacl.vbs]"  
'                        Sequenc: Install Execute Sequence (Before InstallFinalize)'                        
'    Condition: NOT REMOVE~="ALL"
'                        I-S Opt: System Context
'                        Process: Asynch, Wait at end of sequence
'
' TODO
' ====
' Using Add with the Registry creates working results, but somehow the ACEs are
' not in the proper order, and regedt32 complains when you look at them ...
' it also seems that maybe I am not adding all the reg entries necessary ...
' lack of docu ... sorry ... help appreciated. I guess it has something todo
' with inheritance ... 
'
' USAGE
' -----
'
' DACL function, url, "ace, ace, ..."
'
' function -- Add, Rm, Set
'
' url -- FILE://....       change this File/Folder
'        FILE://c:\home\   change this Folder and everything below
'        FILE://c:\home\\  change this Folder and Folders below
'        RGY://\HKEY_LOCAL_MACHINE\SOFTWARE    change this property
'        RGY://...\  and RGY://\...\\ are the same as indiviual
'                    registry values have no acls assigned
'
' ace -- account:rights
'
' account -- user or group
'
' rights (file) --  F - Full, C - Change, R - Read + Execute, 
'                   S - Read + Write + Execute, L - List
'                   K - Special Case, like 1777. Create file and work with your own only
' rights (registry) --  F - Full, R - Read
'
' EXAMPLES
' --------
' DACL "Add", "FILE://w:\hello.txt", "users:F,moetiker:F"
' DACL "Add", "FILE://w:\hello\",    "users:R,oetiker:F,moetiker:F"
' DACL "Rm",  "FILE://w:\oops.txt",  "user"   'remove whatever is there under user
' DACL "Add",  "FILE://w:\oops.txt",  "user:F" ' add Full control for user
' DACL "Add", "RGY://\HKEY_CURRENT_USER\SOFTWARE\ipswitch\ws_ftp\", "users:F"
'=============================================================================
DumpAcl "FILE://C:"
DACL "Rm", "FILE://C:", "users,CREATOR OWNER"
DACL "Add", "FILE://C:", "users:R"
DACL "Add", "FILE://C:", "users:K"
DumpAcl "FILE://C:"
'=============================================================================
' Implementation
' --------------
Sub DumpAcl (url)
    Dim sd, dacl, ace, sec
    Print url
    Set sec = Wscript.CreateObject("ADsSecurity")
    Set sd = sec.GetSecurityDescriptor( CStr(url) )
    Set dacl = sd.DiscretionaryAcl
    For Each ace In dacl
        Print "   " & ace.trustee & _
              " Type: " & ace.AceType & _
              " Mask: " & ace.AccessMask & _
              " AceFlags: " & ace.AceFlags & _
              " Flags: " & ace.Flags & _
       " OType: " & ace.ObjectType & _
       " IOTyp: " & ace.InheritedObjectType

    Next

    set sec = Nothing
    set sd = Nothing
    set dacl = Nothing
    
End Sub

Sub AclEdit( action, url, acl, UType )
    Dim acls, dacl, dummy, sec, sd, ace, acea, usera, user, perm, acsplit
    Const ADS_ACETYPE_ACCESS_ALLOWED = 0
    Const ADS_ACETYPE_ACCESS_DENIED = 1
    Const ADS_ACEFLAG_INHERIT_ACE = 2
    Const ADS_ACEFLAG_INHERIT_ONLY_ACE         = 8
    Const ADS_ACEFLAG_SUB_NEW = 9

    Print "Edit: " & action & " " & url & " " & acl & " " & utype
    acls = split(acl,",")
    
    Set sec = Wscript.CreateObject("ADsSecurity")
    on error resume Next

    ' without cstr this will break ... !!!
    Set sd = sec.GetSecurityDescriptor( CStr(url) )

    If ErrHandler("Get SD for " & url ) Then
        On Error GoTo 0
        Exit Sub
    End If

    Set dacl = sd.DiscretionaryAcl
    dummy = dacl.AceCount ' this will throw an error if there is no DACL    
    If ErrHandler("Get DACL for " & url ) Then
        On Error GoTo 0
        Exit Sub
    End If

    ' DumpAcl url

'    If action = "Rm" Or action = "Add" Then
    If action = "Rm" Then
        ' for Add we remove the ACEs for the folks for whoom need new ones
        For Each ace In dacl
            acea = split (LCase(ace.trustee & "\" & ace.trustee),"\")
            If acea(0) <> "nt authority" Then
                For Each user In acls
                    usera = split (LCase(user),":")        
                    If acea(1) = usera(0) Then
                        Print "Remove ACE: " & ace.trustee
                        dacl.RemoveACE ace                    
                        ErrHandler("Remove ACE for " & ace.trustee & _
                                   " from " & url)
                    End If
                Next
            End if
        Next

    ElseIf action = "Set" Then
        For Each ace In dacl
            acea = split (LCase(ace.trustee & "\" & ace.trustee),"\")
            If acea(0) <> "nt authority" Then
                dacl.RemoveACE ace
                ErrHandler("Remove ACE for " & ace.Trustee & " from " & url)
                Print "Remove ACE: " & ace.trustee
            End if
        Next    
    Elseif action <> "Add" Then
        Wscript.Echo "Unknown Action: " & action
    End If
    
    If action = "Set" Or action = "Add" Then
        For Each dummy In acls
            acsplit = split (dummy,":")
            user = acsplit(0)
            perm = acsplit(1)
            Print action & " " & utype & " " & user & " " & perm
            Select Case UType
                Case "DIRECTORY"
                    ' folders require 2 aces for user (to do with inheritance)
                    AddFileAce dacl, user, perm, _
                               ADS_ACETYPE_ACCESS_ALLOWED, _
                               ADS_ACEFLAG_SUB_NEW
      if ucase(perm) <> "K" then
                        AddFileAce dacl, user, perm, _
                               ADS_ACETYPE_ACCESS_ALLOWED, _
                               ADS_ACEFLAG_INHERIT_ACE
                    end if
                case "FILE"
                    AddFileAce dacl, user, perm, _
                               ADS_ACETYPE_ACCESS_ALLOWED,0
                case "REGISTRY"
                    AddRegAce dacl, user, perm, _
                              ADS_ACETYPE_ACCESS_ALLOWED, _
                              ADS_ACEFLAG_INHERIT_ACE
            End Select
        Next

    End If

    
    sd.DiscretionaryAcl = dacl
    If ErrHandler("Get SD for " & url ) Then    
        On Error GoTo 0
        Exit Sub
    End If

    sec.SetSecurityDescriptor sd    
   
    If ErrHandler("Get SD for " & url ) Then
        On Error GoTo 0
        Exit Sub
    End If
    
    Set sd = Nothing
    Set dacl = Nothing
    Set sec = Nothing

    ' DumpAcl url

    On Error GoTo 0  
End Sub

Sub AddRegACE(dacl, user, perm , acetype, aceflags)
    ' Add registry ACE
    Dim ace
    
    Const ADS_ACETYPE_ACCESS_ALLOWED = 0
    Const RIGHT_REG_READ = &H20019
    Const RIGHT_REG_FULL = &HF003F

    
    Set ace = CreateObject("AccessControlEntry")
    ace.Trustee = user
    
    Select Case UCase(perm)
        ' specified rights so far only include FC & R. Could be expanded though
        Case "F"
            ace.AccessMask = RIGHT_REG_FULL
        Case "R"
            ace.AccessMask = RIGHT_REG_READ
    End Select
    
    ace.AceType = acetype
    ace.AceFlags = aceflags
    dacl.AddAce ace
    ErrHandler("Add Ace for " & user )

    set ace=Nothing

End Sub

Sub AddFileAce(dacl,user, perm, acetype, aceflags)
    ' add ace to the specified dacl
    Dim ace
    
    Const RIGHT_LIST = &H4
    Const RIGHT_READ = &H80000000
    Const RIGHT_EXECUTE = &H20000000
    Const RIGHT_WRITE = &H40000000
    Const RIGHT_DELETE = &H10000
    Const RIGHT_FULL = 2032127 ' &H10000000
    Const RIGHT_CHANGE_PERMS = &H40000
    Const RIGHT_TAKE_OWNERSHIP = &H80000

    
    Set ace = CreateObject("AccessControlEntry")
    ace.Trustee = user
    
    select case ucase(perm)
        ' specified rights so far only include FC & R. Could be expanded though
        case "F"
            ace.AccessMask = RIGHT_FULL
        case "C"
            ace.AccessMask = RIGHT_READ or RIGHT_WRITE Or _
               RIGHT_EXECUTE or RIGHT_DELETE
        case "R"
            ace.AccessMask = RIGHT_READ or RIGHT_EXECUTE
        case "S" 'Special
            ace.AccessMask = RIGHT_READ or RIGHT_WRITE or RIGHT_EXECUTE
        case "L" 'List
            ace.AccessMask = RIGHT_LIST
        case "K" ' User can Create and work files in the dir specified and nothing else
            ace.AceType = 0
            ace.AccessMask = 1048582 ' create files
     ace.AceFlags = 0
            dacl.AddAce ace
            set ace=Nothing
            Set ace = CreateObject("AccessControlEntry")    
            ace.Trustee = "CREATOR OWNER"
            ace.AccessMask = RIGHT_FULL
            acetype=0
            aceflags=9
    end select
    
    ace.AceType = acetype
    ace.AceFlags = aceflags
    dacl.AddAce ace
    ErrHandler("Add Ace for " & user )

    set ace=Nothing

End Sub
   
Sub DACL(action,url,acl)
    Dim argarry, utype, upath, walk, ftype, fs, rfldr, file, sfldr
    Dim ro, rk, regval,skey
    argarry = split(url,"://")
    utype = argarry(0)
    upath = argarry(1)

    Print "Action: " & action & " " & utype & "--" & upath & " " & acl

    If Right(upath,2) = "\\" Then
        walk = "\\" ' folders only 
        upath = Left(upath, Len(upath)-2)
    ElseIf Right(upath,1) = "\" Then
        walk = "\" ' files and folders
        upath = left(upath, len(upath)-1)      
    End If
    
    If utype = "FILE" Then
        
        Set fs=Wscript.CreateObject("Scripting.FileSystemObject")
        Print "---" & upath
        If fs.FileExists(upath) Then
            Set rfldr=fs.GetFile(upath)
            ftype = "FILE" 'directory
        ElseIf fs.FolderExists(upath) Then
            Set rfldr=fs.GetFolder(upath)
            ftype = "DIRECTORY" 'file
        Else
            ' its neither file nor folder ... maybe it does not exist ...
            wscript.echo "Can't find " & upath
            Exit Sub
        End If
        
        AclEdit action, "FILE://" & rfldr.path, acl, ftype

        If ftype = "FILE" Then 'if this is a file our work is done
            Exit Sub
        End If
        
        If walk = "\" then
            For Each file In rfldr.files
                AclEdit action, "FILE://" & file , acl, "FILE"
            Next
        End If
        
        if walk = "\" or walk = "\\" then 
            for each sfldr in rfldr.subfolders
                DACL action, "FILE://" & sfldr & walk, acl
            next
        end if
        
    elseif utype = "RGY" Then

        Set ro = CreateObject("RegObj.Registry")
        on error resume Next
        Set rk = ro.RegKeyFromString( upath )
        If ErrHandler("Get Registry Key " & upath ) Then
            On Error GoTo 0
            Exit Sub
        End If
        
        AclEdit action, "RGY://" & rk.FullName, acl,"REGISTRY"  
                        
        if walk = "\" or walk = "\\" then
            for each skey in rk.Subkeys
                DACL action,"RGY://" &  skey.FullName & walk, acl
            next
        end If
        
    else
        Wscript.Echo "Unsupported URL Type: " & utype
    end If
    On Error GoTo 0
    
End Sub

Function ErrHandler(what)
    If Err.Number > 0 Then
        WScript.Echo what & " Error " & Err.Number & ": " & Err.Description
        Err.Clear
        Return True
    End If
    ErrHandler = False
End Function

Sub Print(Str)
    'strip when debugging
    'wscript.echo Str
End Sub

Delete Windows Patch Install Folders

Const WINDOWS = &H24&

Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(WINDOWS)
Set objFolderItem = objFolder.Self
' Wscript.Echo objFolderItem.Path

Set FSO = CreateObject("Scripting.FileSystemObject")
ShowSubfolders FSO.GetFolder(objFolderItem.Path)

Sub ShowSubFolders(Folder)
    For Each Subfolder in Folder.SubFolders
        If Right(Subfolder.Name,1) = "$" AND Left(Subfolder.Name,1) = "$" Then
            ' Wscript.Echo Subfolder.Name
            Subfolder.Delete
        End If
        ' Wscript.Echo Subfolder.Path
        ' ShowSubFolders Subfolder
    Next
End Sub

Configure Computer Rights in Active Directory

'**********************************************************************
'
'  Configure Computer Rights in AD
'
'**********************************************************************

'**********************************************************************
'Connecting to the default naming context
'**********************************************************************
Set oRootDSE = GetObject("LDAP://RootDSE")
strNamingContext = oRootDSE.Get("defaultNamingContext")
set oSubscription = GetObject("LDAP://"&strNamingContext)


'**********************************************************************
'Getting the security descriptor of the domain root
'**********************************************************************
on error resume next
set oSecDesc = oSubscription.Get("ntSecurityDescriptor")
set oACL = oSecDesc.DiscretionaryACL
if err.number<>0 then
 wscript.echo "Error : "&error.number&" "&error.description
 wscript.quit(1)
end if


'**********************************************************************
'Create a new ACE giving write access to the comment field of computer objects
'********************************************************************** 
Set objACE = CreateObject("accessControlEntry")
objACE.Trustee = "Domain Computers"
objACE.AccessMask = 32
objACE.AceType = 5
objACE.AceFlags = 10
objACE.Flags = 3
objAce.ObjectType="{BF967A6A-0DE6-11D0-A285-00AA003049E2}"
objACE.InheritedObjectType="{BF967A86-0DE6-11D0-A285-00AA003049E2}"

oACL.AddAce(objACE)
oSecDesc.DiscretionaryACL = oACL


'**********************************************************************
'Write back the security descriptor
'**********************************************************************
oSubscription.Put "ntSecurityDescriptor",oSecDesc
oSubscription.SetInfo
if err.number<>0 then
 wscript.echo "Error : "&error.number&" "&error.description
 wscript.quit(1)
end if

Print Queue Logging

Option Explicit

Dim PrintJobSet, fso, WriteLogFile

On Error Resume Next
Set PrintJobSet = GetObject("winmgmts:").InstancesOf("Win32_PrintJob")
Set fso = CreateObject("Scripting.FileSystemObject")
Set WriteLogFile = fso.OpenTextFile("C:\PrintJobLog.txt", 8)
If Err <> 0 Then
    WriteLogFile.Write "Test Admin Print Queues Failed  " & Err.Description & " " & Err.Number & " " & Now & vbNewLine
ElseIf Err = 0 Then
    WriteLogFile.Write "Test Admin Print Queues Passed  " & Now & vbNewLine
    If (PrintJobSet.Count = 0) Then
        WriteLogFile.Write "No print jobs!" & vbNewLine
    Else  
 WriteLogFile.Write "Number of Jobs are " & PrintJobSet.Count & vbNewLine  
    End If

   For Each PrintJob In PrintJobSet
    WriteLogFile.Write "Name" & vbTab & "JobId" & vbTab & "Status" & vbTab & "TotalPages " & vbNewLine
    WriteLogFile.Write PrintJob.Name & vbTab & PrintJob.JobId & vbTab & PrintJob.Status & vbTab & PrintJob.TotalPages & vbNewLine
    Next
End If

Directory Scan

' Given a root directory, this script will scan for
' subdirectories and will output the size of each subdirectory.

On Error Resume Next

Dim RootDir, FileSystem, RootFolder, SubFolders, Folder
Dim FolderSize, Tmp

If Wscript.Arguments.Count <> 1 Then
 Wscript.Echo "USAGE: dirscan.vbs  [root directory]"
 Wscript.Echo ""
 Wscript.Echo " Given a root directory, dirscan will scan"
 Wscript.Echo " all subdirectories and output the size of"
 Wscript.Echo " each subdirectory."
 Wscript.Quit 0
Else
 RootDir = Wscript.Arguments(0)
 Wscript.Echo "Root directory is: " & RootDir
 Wscript.Echo ""
End If

Set FileSystem = CreateObject("Scripting.FileSystemObject")
Set RootFolder = FileSystem.GetFolder(RootDir)
If Err.Number <> 0 Then
 ' Display the error that occurred
 Wscript.Echo "(" & Err.Number & ") " & Err.Description
 Wscript.Echo ""
 Wscript.Echo "The path that you entered is invalid, please " & _
  "select a different path."
 Wscript.Quit Err.Number
End If

Set SubFolders = RootFolder.SubFolders

For Each Folder In SubFolders
 FolderSize = Folder.Size
 Tmp = FormatNumber(FolderSize, 0, 0, 0, -1)
 Tmp = Right(Space(20) & Tmp, 20)
 Wscript.Echo Tmp & " " & Folder.Path
Next

Print Server Migration

Dim strComputer, sPrinterPath, sPrinterName, sOldPrntSrv, sNewPrntSrv

sOldPrntSrv = "OldPrintServer"
sNewPrntSrv = "NewPrintServer"

Set WshNetwork = CreateObject("WScript.Network")

strComputer = "."
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
Set colInstalledPrinters = objWMIService.ExecQuery("Select * from Win32_Printer")

For Each objPrinter in colInstalledPrinters
  sPrinterPath = UCase(objPrinter.Name)
  Length = Len(sPrinterPath)
  sPrinterName = Right(sPrinterPath,Length - InStrRev(sPrinterPath,"\"))

  If Instr(sPrinterPath, sNewPrntSrv) Then
    If Length > 27 Then
      WshNetwork.RemovePrinterConnection sPrinterPath
      WshNetwork.AddWindowsPrinterConnection UCase("\\" & sNewPrntSrv & "\" & sPrinterName)
    End If
  End If

  If Instr(sPrinterPath, sOldPrntSrv) Then
    WshNetwork.RemovePrinterConnection sPrinterPath
    WshNetwork.AddWindowsPrinterConnection UCase("\\" & sNewPrntSrv & "\" & sPrinterName)
  End If

Next

VBScript : IfMember and MapNetworkDrive

Set wshnetwork = CreateObject("Wscript.Network")
Set fso = CreateObject("Scripting.FileSystemObject")

Private Function IsMember(groupName)

  Set wshnetwork = CreateObject("WScript.Network")
  domain = wshnetwork.UserDomain
  user = wshnetwork.UserName
  flgIsMember = false
  Set userObj = GetObject("WinNT://" & domain & "/" & user & ",user")
  For Each grp In userObj.Groups
    If grp.Name = groupName Then
      flgIsMember = true
      Exit For
    End If
  Next
  IsMember = flgIsMember
  Set userObj = nothing
  Set wshnetwork = nothing

End Function

strComputer = "."

Set objWMIService = GetObject("winmgmts:" & "!\\" & strComputer & "\root\cimv2")
Set colAdapters = objWMIService.ExecQuery("Select * from Win32_NetworkAdapterConfiguration Where IPEnabled = True")

For Each objAdapter In colAdapters 
  If Not IsNull(objAdapter.IPAddress) Then 
    For i = LBound(objAdapter.IPAddress) To UBound(objAdapter.IPAddress)
      address = objAdapter.IPAddress(i)
      VLANX = instr(address, "10.14.3.")
      If VLANX = 1 Then
        IFM = IsMember("GG-VLS-SEN-CAO")
        Set wshnetwork = CreateObject("Wscript.Network")
        user = wshnetwork.UserName
          If IFM = true then 
            If fso.folderexists("X:\")=False Then
              WshNetwork.MapNetworkDrive "X:", "\\Paris\" & user
            Else
              WshNetwork.RemoveNetworkDrive "X:"
              WshNetwork.MapNetworkDrive "X:", "\\Paris\" & user
            End If
          End If
      End If
    Next
  End If
Next

M1 = IsMember("GG-HelpDesk")
Set wshnetwork = CreateObject("Wscript.Network")
user = wshnetwork.UserName
If M1 = true then 
  If fso.folderexists("R:\")=False Then
    WshNetwork.MapNetworkDrive "R:", "\\Tokyo\HelpDesk"
  Else
    WshNetwork.RemoveNetworkDrive "R:"
    WshNetwork.MapNetworkDrive "R:", "\\Tokyo\HelpDesk"
  End If
End If

M2 = IsMember("GG-Project")
Set wshnetwork = CreateObject("Wscript.Network")
user = wshnetwork.UserName
If M2 = true then 
  If fso.folderexists("F:\")=False Then
    WshNetwork.MapNetworkDrive "F:", "\\NewYork\project"
  Else
    WshNetwork.RemoveNetworkDrive "F:"
    WshNetwork.MapNetworkDrive "F:", "\\NewYork\project"
  End If
  If fso.folderexists("M:\")=False Then
    WshNetwork.MapNetworkDrive "M:", "\\NewYork\report"
  Else
    WshNetwork.RemoveNetworkDrive "M:"
    WshNetwork.MapNetworkDrive "M:", "\\NewYork\report"
  End If
End If

M3 = IsMember("GG-HR")
Set wshnetwork = CreateObject("Wscript.Network")
user = wshnetwork.UserName
If M3 = true then 
  If fso.folderexists("R:\")=False Then
    WshNetwork.MapNetworkDrive "R:", "\\Hamilton\HR"
  Else
    WshNetwork.RemoveNetworkDrive "R:"
    WshNetwork.MapNetworkDrive "R:", "\\Hamilton\HR"
  End If
  If fso.folderexists("X:\")=False Then
    WshNetwork.MapNetworkDrive "X:", "\\vls-sen-s04\CV"
  Else
    WshNetwork.RemoveNetworkDrive "X:"
    WshNetwork.MapNetworkDrive "X:", "\\vls-sen-s04\CV"
  End If
End If

M4 = IsMember("GG-Director")
Set wshnetwork = CreateObject("Wscript.Network")
user = wshnetwork.UserName
If M4 = true then 
  If fso.folderexists("H:\")=False Then
    WshNetwork.MapNetworkDrive "H:", "\\NewYork\Director"
  Else
    WshNetwork.RemoveNetworkDrive "H:"
    WshNetwork.MapNetworkDrive "H:", "\\NewYork\Director"
  End If
End If