Consolidating Logon Scripts

Const ADS_NAME_TYPE_1779                =  1
Const ADS_NAME_TYPE_NT4                 =  3
Const ADS_NAME_INITTYPE_DOMAIN          =  1
sDomain = Replace(Replace(UCase(GetObject("LDAP://rootDSE").Get("defaultNamingContext")), "DC=", ""), ",", "")

Set oWShell = CreateObject("WScript.Shell")
Set oNetwork = CreateObject( "WScript.Network")
Set oTranslate = CreateObject("NameTranslate")

bForceDisconnect = True        ' True/False - Force disconnect of existing drive mappings before mapping new drives
bPersistentMappings = True      ' True/False - Drive mappings will remain at next logon, even if not connected to network

Do While oNetwork.UserName = ""
    WScript.Sleep 250
Loop
sUserName = oNetwork.UserName

oTranslate.Init ADS_NAME_INITTYPE_DOMAIN, sDomain
oTranslate.Set ADS_NAME_TYPE_NT4, sDomain & "\" & sUserName
Set oADUser = GetObject("LDAP://" & oTranslate.Get(ADS_NAME_TYPE_1779))

Set oGroupMembership = CreateObject("Scripting.Dictionary")
oGroupMembership.CompareMode = vbTextCompare
For Each oGroup In oADUser.Groups
    RecurseGroup(oGroup.ADsPath)
Next

Set dMappedDrives = CreateObject("Scripting.Dictionary")
dMappedDrives.CompareMode = vbTextCompare
Call BuildMappedDrivesDictionary()

If CheckGroup("My Test Group") Then _
    MapDrive "Z:", "\\myserver\myfolder"

Function CheckGroup(sGroup)
    On Error Resume Next
    CheckGroup = oGroupMembership.Exists(sGroup)
End Function

Function RecurseGroup(sADsPath)
    On Error Resume Next

    Set oRGroup = GetObject(sADsPath)
    oGroupMembership.Add Replace(oRGroup.Name,"CN=",""), True
    oRGroup.GetInfo
    Err.Clear
    cMemberOf = oRGroup.GetEx("memberOf")
    If Err.Number <> 0 Then Exit Function
    For Each sMemberOf In cMemberOf
        RecurseGroup("LDAP://" & sMemberOf)
    Next
End Function

Sub MapDrive(sDrive, sNewShare)
    On Error Resume Next
    '
    ' Check to see if the path is already mapped to the requested location
    '
    If dMappedDrives.Exists(sNewShare) Then
         If dMappedDrives.Item(sNewShare) = UCase(sDrive) Then
             Exit Sub
         Else
             If bForceDisconnect = True Then
                 oNetwork.RemoveNetworkDrive dMappedDrives.Item(sNewShare), True, True
                 dMappedDrives.Remove(dMappedDrives.Item(sNewShare))
                 dMappedDrives.Remove(sNewShare)
             End If
             Err.Clear
         End If
    End If
    '
    ' Loop through drives to check if there is an existing mapping
    '
    If dMappedDrives.Exists(UCase(sDrive)) Then
        If UCase(dMappedDrives.Item(sDrive)) = UCase(sNewShare) Then
            Exit Sub
        Else
            If bForceDisconnect = True Then
                Err.Clear
                oNetwork.RemoveNetworkDrive sDrive, True, True
                If Err.Number <> 0 Then Exit Sub
                dMappedDrives.Remove(dMappedDrives.Item(sDrive))
                dMappedDrives.Remove(sDrive)
            Else
                Exit Sub
            End If
        End If
    End If
    '
    ' Now the drive letter is free, so map the drive
    '
    oNetwork.MapNetworkDrive UCase(sDrive), sNewShare, bPersistentMappings
End Sub

Sub BuildMappedDrivesDictionary()
    On Error Resume Next
    Const HKEY_CURRENT_USER = &H80000001
    Set oRegistry = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
 
    oRegistry.EnumKey HKEY_CURRENT_USER, "Network\", aSubKeys
 
    For Each oSubKey In aSubKeys
        sTempPath = oShell.RegRead("HKCU\Network\" & oSubKey & "\RemotePath")
        If Not dMappedDrives.Exists(sTempPath) Then dMappedDrives.Add sTempPath, UCase(oSubKey & ":")
        dMappedDrives.Add UCase(oSubKey & ":"), sTempPath
    Next
    Set oRegistry = Nothing
End Sub

Select allOpen in new window