Attribute VB_Name = "basActiveDirectoryUserList"
Option Compare Database
Option Explicit
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

'\\\\\\
'\\
'\\ 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, strMessage, strDomain
Dim strUserMail, strRootDSE, strGetUserName, Ouser, fso
Dim major, minor, ver, strMail, strLogonName
Dim strValue, strDisplayDescription, strDisplayDepartment, strDN
Dim strSearch, strMostRecentIP, aOpt(), intOpt, oGroup, sGroup, txtFile, objComputer
Dim strTemp, strFormat, strFile, i
Dim objectRecordSet
Dim strKey, strKeyValue, rval, strBCC, oMailApp, olMailItm, olMailItem, intSize
Dim strDelegateCount

Public Sub Main()
'Purpose  : Retrieve list of users in an Active Directory List.
    ' Change the value of variable "strFormat" to Outlook to generate a new mail
    ' containing all email addresses of the mebers in the BCC box.
    Dim WshShell As Object
    Dim objNet As Object
    Dim objRootDSE As Object
    Dim strADsConfPath As String
    
    Set WshShell = 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)
    
    strFormat = "Excel"
'    strformat = "Outlook"


    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%")
                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 = ""
                        Call 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
    
exit_Main:
    'Clean up pointers.
    Set objRootDSE = GetObject("LDAP://rootDSE")
    Set objNet = CreateObject("WScript.Network")
    Set WshShell = CreateObject("WScript.Shell")
    
End Sub

Sub CheckForUser()
    Dim objConnection As ADODB.Connection
    Dim objCommand As ADODB.Command
    Dim objRecordSet As ADODB.Recordset
    
    Set objConnection = New ADODB.Connection
    objConnection.Provider = ("ADsDSOObject")
    objConnection.Open
    Set objCommand = New 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
    Set objCommand = Nothing
    objConnection.Close
    Set objConnection = Nothing

End Sub

Sub GetUserAccount(strDN)
    Dim objAdS
    Dim strDescription
    Dim strDepartment
    
    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
        .FullScreen = True
        .Toolbar = False: .RegisterAsDropTarget = False
        .StatusBar = False: .Navigate ("about:blank")
        Do Until .ReadyState = 4: 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": Sleep 50: Loop
            With .body
                .Scroll = "no"
                .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
                Sleep 100
                If oIE.Visible Then SelectBox = "Aborted"
                If Err.Number <> 0 Then Exit Function
            Loop
            On Error GoTo 0
            With .ParentWindow.entries
                SelectBox = .options(.selectedIndex).Text
            End With
        End With
        .Visible = False
    End With
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:36 UTC 2019 -->