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 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 = _ ";(&(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 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 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 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 <> "Select a group" 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 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 = "" & sTitle _ & "