'\\\\\\
'\\
'\\ Filter AD groups, select a AD group and make a list of its users
'\\ Frans Erich 16-02-06
'\\
'\\         Sub : CheckForUser and GetUserAccount taken from "ADuser" script from Ralph E Montgomery
'\\         Function : SelectBox taken from script from T. Lavedas
'\\
'\\ Script only works in a domain environment
'\\
'\\\\\\\


Dim objGroup, objUser, WshShell, strMessage, strDomain, strUserMail, strRootDSE, strGetUserName, Ouser, fso
Dim objNet, major, minor, ver, strMail, strLogonName, strValue, strDisplayDescription, strDisplayDepartment, strDN
Dim strSearch, strMostRecentIP, aOpt(), intOpt, oGroup, sGroup, txtFile, objComputer
Dim objRootDSE, strTemp, strADsConfPath, strFormat, strFile, i, objConnection, objCommand, objRecordSet, objectRecordSet
Dim strKey, strKeyValue, rval, strBCC, oMailApp, olMailItm, olMailItem, intSize, strDelegateCount

Set WshShell = WScript.CreateObject("WScript.Shell")
Set objNet = CreateObject("WScript.Network")
Set objRootDSE = GetObject("LDAP://rootDSE")
strADsConfPath = "LDAP://" & objRootDSE.Get("configurationNamingContext")
strRootDSE = objRootDSE.Get("defaultNamingContext")
strDomain = UCase(objNet.UserDomain)
strSearch = LCase(InputBox("Give an optional value up on which you want filter groups."))
ListGroups (strDomain)
intOpt = 1
sGroup = SelectBox("Select a group", aOpt)
' Change the value of variable "strFormat" to Outlook to generate a new mail containing all email addresses of the mebers in the BCC box.
strFormat = "Excel"


Set oGroup = GetObject("WinNT://" & strDomain & "/" & sGroup & ",group")
If sGroup <> "Aborted" Then
    If sGroup <> "Selecteer een groep" Then
        If strFormat = "Excel" Then
            'strTemp = WshShell.ExpandEnvironmentStrings("%temp%")
            strTemp = "C:\Temp_C"
            strFile = strTemp & "\Member List " & sGroup & ".csv"
            Set fso = CreateObject("Scripting.FileSystemObject")
            If fso.FileExists(strFile) Then
                fso.DeleteFile (strFile)
            End If
            Set txtFile = fso.CreateTextFile(strFile)
            i = 0
            For Each Ouser In oGroup.Members
                i = i + 1
                strGetUserName = ""
                strDN = ""
                strMail = ""
                strGetUserName = UCase(Ouser.Name)
                While strDN = ""
                    CheckForUser()
                Wend
                GetUserAccount (strDN)
                txtFile.Write (Ouser.Name & ";" & strDisplayDepartment & ";" & strMail & vbCrLf)
            Next
            txtFile.Close
            Set txtFile = Nothing
            Set fso = Nothing
            strKey = "HKLM\Software\Microsoft\Windows\CurrentVersion\App Paths\Excel.exe\path"
            If KeyExists(strKey) = True Then
                strKeyValue = WshShell.regRead(strKey)
                rval = WshShell.Run(Chr(34) & strKeyValue & "excel.exe" & Chr(34) & " " & Chr(34) & strFile & Chr(34), 1, True)
            Else
               rval = WshShell.Run("notepad.exe" & " " & strFile, 1, True)
            End If
        Else
            For Each Ouser In oGroup.Members
                i = i + 1
                strGetUserName = ""
                strDN = ""
                strMail = ""
                strGetUserName = UCase(Ouser.Name)
                While strDN = ""
                    Call CheckForUser
                Wend
                GetUserAccount (strDN)
                strBCC = strBCC & strMail & "; "
            Next
            Set oMailApp = CreateObject("Outlook.Application")
            Set olMailItm = oMailApp.CreateItem(olMailItem)
            olMailItm.BCC = strBCC
            olMailItm.Display
        End If
    End If
End If

Sub CheckForUser()
    Set objConnection = CreateObject("ADODB.Connection")
    objConnection.Provider = ("ADsDSOObject")
    objConnection.Open
    Set objCommand = CreateObject("ADODB.Command")
    objCommand.ActiveConnection = objConnection
    objCommand.CommandText = _
    "<LDAP://" & strRootDSE & ">;(&(objectCategory=User)" & _
                             "(samAccountName=" & strGetUserName & "));distinguishedName,sAMAccountName,name;subtree"
    Set objRecordSet = objCommand.Execute
    strDN = objRecordSet.Fields("distinguishedName")
    Set objectRecordSet = Nothing
    objConnection.Close
    Set objConnection = Nothing

End Sub

Sub GetUserAccount(strDN)
    On Error Resume Next
    If InStr(1, strDN, "/") Then strDN = Replace(strDN, "/", "\/")
    Set objUser = GetObject("LDAP://" & strDN & "")
    Set objAdS = GetObject("LDAP://" & strRootDSE & "")

    With objUser
        '.GetInfo
        strMail = .Get("mail")
        strLogonName = .Get("sAMAccountName")
        strUserMail = .Get("mail")
        strDescription = .GetEx("description")
        strDepartment = .GetEx("department")

        strDisplayDepartment = ""
        For Each strValue In strDepartment
            strDisplayDepartment = strDisplayDepartment & strValue
        Next

        For Each strValue In strDescription
            strDisplayDescription = strDisplayDescription & strValue
        Next

    End With

End Sub

Sub ListGroups(strDomain)
    Set objComputer = GetObject("WinNT://" & strDomain)
    objComputer.Filter = Array("Group")
    For Each objGroup In objComputer
        If InStr(LCase(objGroup.Name), strSearch) Then
            ReDim Preserve aOpt(intOpt + 1)
            aOpt(intOpt) = objGroup.Name
            intOpt = intOpt + 1
        End If
    Next
End Sub

Function SelectBox(sTitle, aOptions)
    Dim oIE, s, item
    Set oIE = CreateObject("InternetExplorer.Application")
    With oIE
        'Commented out for IE7
        '.FullScreen = True
        .Toolbar = False 
        .RegisterAsDropTarget = False
        .StatusBar = False 
        .Menubar = False
        .Addressbar = False
        .Navigate ("about:blank")
        Do Until .ReadyState = 4: WScript.Sleep 100: Loop
        .Width = 400: .Height = 200
        With .Document
            With .ParentWindow.Screen
                oIE.Left = (.availWidth - oIE.Width) \ 2
                oIE.Top = (.availheight - oIE.Height) \ 2
            End With
            s = "<html><head><title>" & sTitle _
              & "</title></head><script language=vbs>bWait=true<" & "/script>" _
              & "<body bgColor=Silver><center>" _
              & "<b>" & sTitle & "<b><p>" _
              & "<select id=entries size=1 style='width:325px'>" _
              & " <option selected>" & sTitle & "</option>"
            For Each item In aOptions
                s = s & " <option>" & item & "</option>"
            Next
            s = s & " </select><p>" _
              & "<button id=but0 onclick='bWait=false'>OK</button>" _
              & "</center></body></html>"
            .Open
            .Write (s)
            .Close
            Do Until .ReadyState = "complete": WScript.Sleep 50: Loop
            With .body
                .Scroll = "no"
                'Commented out for IE7
                '.Style.BorderStyle = "outset"
                .Style.BorderWidth = "3px"
            End With
            .all.entries.focus
            oIE.Visible = True
            CreateObject("Wscript.Shell").AppActivate sTitle
            'On Error Resume Next
            Do While .ParentWindow.bWait
                WScript.Sleep 100
                If oIE.Visible Then SelectBox = "Aborted"
                If Err.Number <> 0 Then 
		    set oIE =Nothing
		    Exit Function
		End If
            Loop
            'On Error GoTo 0
            With .ParentWindow.entries
                SelectBox = .options(.selectedIndex).Text
            End With
        End With
        .Visible = False
    End With
    
    set oIE =Nothing

End Function


Function KeyExists(sKeyPath)
    KeyExists = False: If (sKeyPath = "") Then Exit Function
    'On Error Resume Next
    CreateObject("wscript.shell").regRead sKeyPath
    Select Case Err
        Case 0: KeyExists = True
        Case &H80070002: Dim sErrMsg
            sErrMsg = Replace(Err.Description, sKeyPath, "")
            Err.Clear
            CreateObject("wscript.shell").regRead "HKEY_ERROR\"
            KeyExists = Not (sErrMsg = Replace(Err.Description, "HKEY_ERROR\", ""))
        Case Else: KeyExists = False
    End Select
    'On Error GoTo 0
End Function


<!-- neodl2.grp.bf1.yahoo.com Mon Nov 18 02:35:33 UTC 2019 -->