none
Listar usuários do Active Directory exportando para Excel RRS feed

  • Pergunta

  • Olá!
    Boa tarde!

    Alguém poderia me ajudar com o script abaixo?

    Preciso listar todos os usuários do AD exportando para excel.

    Ao chamar a função novamente ele perde-se o valor da varíavel intRow, com isso não consigo continuar inserindo os usuários do ponto que parou.

    Alguém teria alguma solução?

    Se for colocar um arquivo comum é simples, pois não precisa marcar posição, porém no Excel estou tendo trabalho.

    Alguém poderia me ajudar?

    Option Explicit 
     
    Dim StartTime,EndTime: StartTime = Now
    Dim objShell 
    Set objShell = WScript.CreateObject("WScript.Shell") 
    Wscript.Echo "StartTime = " & StartTime 
    
    ' ***************************************************************** ' 
    
    Dim objRootDSE 
    Dim objDomain 
    Dim objContainer 
    Dim objOrganizationalUnit 
    Dim strExcelPath, objExcel, objSheet, Sheet, intRow
    
    'Bind to the Excel object
    Set objExcel = CreateObject("Excel.Application")
    
    'Create a new workbook.
    objExcel.Workbooks.Add
    
    'Select the first sheet
    Sheet = 1
    
    'Bind to worksheet.
    Set objSheet = objExcel.ActiveWorkbook.Worksheets(Sheet)
    
    'Name the worksheet
    objSheet.Name = "users"
    
    'Set the save location
    strExcelPath = "c:\temp\users.xlsx"
    
    ' Add header row.
    objSheet.Cells(1, 1).Value = "Login"
    objSheet.Cells(1, 2).Value = "Name"
    objSheet.Cells(1, 3).Value = "Location"
    objSheet.Cells(1, 4).Value = "Email"
    objSheet.Cells(1, 5).Value = "CC"
    objSheet.Cells(1, 6).Value = "Function"
    
    Set objRootDSE = GetObject("LDAP://RootDSE") 
    Set objDomain = GetObject("LDAP://" & objRootDSE.Get("DefaultNamingContext")) 
    
    intRow = 2
    
    Call Sub_EnumOUs(objDomain.ADsPath) 
     
    Sub Sub_EnumOUs(sADsPath)
    	Set objContainer = GetObject(sADsPath) 
        objContainer.Filter = Array("OrganizationalUnit") 
        For Each objOrganizationalUnit in objContainer
            Sub_EnumUsers(objOrganizationalUnit.ADsPath) 
            Sub_EnumOUs(objOrganizationalUnit.ADsPath) 
        Next 
    End Sub 
    
    Sub Sub_EnumUsers(sADsPath) 
        Dim objADobject
        Set objContainer = GetObject(sADsPath) 
        objContainer.Filter = Array("User") 
        For Each objADobject in objContainer 
            If objADobject.Class = "user" Then 
    			objSheet.Cells(intRow, 1).Value = objADobject.sAMAccountName
    			objSheet.Cells(intRow, 2).Value = objADobject.DisplayName
    			objSheet.Cells(intRow, 3).Value = objADobject.physicalDeliveryOfficeName
    			objSheet.Cells(intRow, 4).Value = objADobject.mail
    			objSheet.Cells(intRow, 5).Value = objADobject.Department
    			objSheet.Cells(intRow, 6).Value = objADobject.Description
    			intRow = intRow + 1
            End If
        Next 
    End Sub
    
    objExcel.ActiveWorkbook.SaveAs strExcelPath
    objExcel.ActiveWorkbook.Close
    
    objExcel.Application.Quit
    
    Set objSheet = Nothing
    Set objExcel = Nothing
    
    ' ***************************************************************** ' 
    EndTime = Now 
    Wscript.Echo vbCrLf & "EndTime = " & EndTime 
    Wscript.Echo "Seconds Elapsed: " & DateDiff("s", StartTime, EndTime) 
    Wscript.Echo "Script Complete" 
    Wscript.Quit(0) 
    ' ***************************************************************** '

    quarta-feira, 30 de outubro de 2013 16:11

Respostas

  • Olá James,

    Tente este procedimento, depois faça uma importação no excel, parametrizando a importação: http://rotinadeti.wordpress.com/2012/08/23/obter-lista-de-usuarios-de-um-determinado-grupo-do-ad/

    Ou tente esta ferramenta: http://support.microsoft.com/kb/555634/pt-br

    Atenciosamente,

    Edinaldo


    ** FAVOR CLASSIFICAR O POST COMO ÚTIL OU NÃO **

    quarta-feira, 30 de outubro de 2013 16:25
  • James,

    Você está usando um método de leitura do AD que necessita de funções recursivas para ler todos os usuários.

    Sugiro que você use o método ADO, ele faz uma query que já traz todos os usuários e você os lê sem precisar de funções recursivas.

    'Option Explicit 
     
    Dim StartTime,EndTime: StartTime = Now
    Dim objShell 
    Set objShell = WScript.CreateObject("WScript.Shell") 
    Wscript.Echo "StartTime = " & StartTime 
    
    ' ***************************************************************** ' 
    
    Dim objRootDSE 
    Dim objDomain 
    Dim objContainer 
    Dim objOrganizationalUnit 
    Dim strExcelPath, objExcel, objSheet, Sheet, intRow
    
    'Bind to the Excel object
    Set objExcel = CreateObject("Excel.Application")
    
    'Create a new workbook.
    objExcel.Workbooks.Add
    
    'Select the first sheet
    Sheet = 1
    
    'Bind to worksheet.
    Set objSheet = objExcel.ActiveWorkbook.Worksheets(Sheet)
    
    'Name the worksheet
    objSheet.Name = "users"
    
    'Set the save location
    strExcelPath = "c:\temp\users.xlsx"
    
    ' Add header row.
    objSheet.Cells(1, 1).Value = "Login"
    objSheet.Cells(1, 2).Value = "Name"
    objSheet.Cells(1, 3).Value = "Location"
    objSheet.Cells(1, 4).Value = "Email"
    objSheet.Cells(1, 5).Value = "CC"
    objSheet.Cells(1, 6).Value = "Function"
    
    Set objRootDSE = GetObject("LDAP://RootDSE") 
    Set objDomain = GetObject("LDAP://" & objRootDSE.Get("DefaultNamingContext")) 
    
    intRow = 2
    
    ' ALTERACOES =========================================================
    
    Const ADS_SCOPE_SUBTREE = 2
    ' Get domain components
    strDomain = objRootDSE.Get("DefaultNamingContext")
    ' Set ADO connection
    Set objConnection = CreateObject("ADODB.Connection")
    objConnection.Provider = "ADsDSOObject"
    objConnection.Open "Active Directory Provider"
    ' Set ADO command
    Set objCommand = CreateObject("ADODB.Command")
    Set objCommand.ActiveConnection = objConnection
    objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE 
    
    strAtributos="distinguishedName,samAccountName,DisplayName,physicalDeliveryOfficeName,mail,Department,Description"
    objCommand.CommandText = "SELECT " & strAtributos & _
    		" FROM 'LDAP://" & strDomain & _
    		"' WHERE objectCategory='person' AND objectClass='user'"
    		
    ' Set recordset to hold the query result
    Set objRecordSet = objCommand.Execute
    
    
     
    Do Until objRecordSet.EOF
    
        WScript.Echo objRecordSet.Fields("samAccountName").Value 
    	objSheet.Cells(intRow, 1).Value = objRecordSet.Fields("sAMAccountName").Value
    	objSheet.Cells(intRow, 2).Value = objRecordSet.Fields("DisplayName").Value
    	objSheet.Cells(intRow, 3).Value = objRecordSet.Fields("physicalDeliveryOfficeName").Value
    	objSheet.Cells(intRow, 4).Value = objRecordSet.Fields("mail").Value
    	objSheet.Cells(intRow, 5).Value = objRecordSet.Fields("Department").Value
    	objSheet.Cells(intRow, 6).Value = objRecordSet.Fields("Description").Value
    	intRow = intRow + 1
    	
    	'Move para o próximo registro
    	objRecordSet.MoveNext
    
    Loop
    
    ' FIM ALTERACOES ==========================================================
    
    objExcel.ActiveWorkbook.SaveAs strExcelPath
    objExcel.ActiveWorkbook.Close
    
    objExcel.Application.Quit
    
    Set objSheet = Nothing
    Set objExcel = Nothing
    
    
    ' ***************************************************************** ' 
    EndTime = Now 
    Wscript.Echo vbCrLf & "EndTime = " & EndTime 
    Wscript.Echo "Seconds Elapsed: " & DateDiff("s", StartTime, EndTime) 
    Wscript.Echo "Script Complete" 
    Wscript.Quit(0) 
    ' ***************************************************************** '

    Observações:

    1. Comentei a primeira linha (Option Explicit) pois ela obriga a declaração de todas as variáveis, não que isso seja ruim, mas estava me dando trabalho declarar as minha váriaveis, fique a vontade para declarar.

    Adaptei do exemplo abaixo

    Get users distinguished name using ADO and VbScript

    http://www.winfrastructure.net/article.aspx?BlogEntry=Get-users-distinguished-name-using-ADO-and-VbScript


    Fábio de Paula Junior

    quinta-feira, 31 de outubro de 2013 13:13
    Moderador

Todas as Respostas

  • Olá James,

    Tente este procedimento, depois faça uma importação no excel, parametrizando a importação: http://rotinadeti.wordpress.com/2012/08/23/obter-lista-de-usuarios-de-um-determinado-grupo-do-ad/

    Ou tente esta ferramenta: http://support.microsoft.com/kb/555634/pt-br

    Atenciosamente,

    Edinaldo


    ** FAVOR CLASSIFICAR O POST COMO ÚTIL OU NÃO **

    quarta-feira, 30 de outubro de 2013 16:25
  • James,

    Você está usando um método de leitura do AD que necessita de funções recursivas para ler todos os usuários.

    Sugiro que você use o método ADO, ele faz uma query que já traz todos os usuários e você os lê sem precisar de funções recursivas.

    'Option Explicit 
     
    Dim StartTime,EndTime: StartTime = Now
    Dim objShell 
    Set objShell = WScript.CreateObject("WScript.Shell") 
    Wscript.Echo "StartTime = " & StartTime 
    
    ' ***************************************************************** ' 
    
    Dim objRootDSE 
    Dim objDomain 
    Dim objContainer 
    Dim objOrganizationalUnit 
    Dim strExcelPath, objExcel, objSheet, Sheet, intRow
    
    'Bind to the Excel object
    Set objExcel = CreateObject("Excel.Application")
    
    'Create a new workbook.
    objExcel.Workbooks.Add
    
    'Select the first sheet
    Sheet = 1
    
    'Bind to worksheet.
    Set objSheet = objExcel.ActiveWorkbook.Worksheets(Sheet)
    
    'Name the worksheet
    objSheet.Name = "users"
    
    'Set the save location
    strExcelPath = "c:\temp\users.xlsx"
    
    ' Add header row.
    objSheet.Cells(1, 1).Value = "Login"
    objSheet.Cells(1, 2).Value = "Name"
    objSheet.Cells(1, 3).Value = "Location"
    objSheet.Cells(1, 4).Value = "Email"
    objSheet.Cells(1, 5).Value = "CC"
    objSheet.Cells(1, 6).Value = "Function"
    
    Set objRootDSE = GetObject("LDAP://RootDSE") 
    Set objDomain = GetObject("LDAP://" & objRootDSE.Get("DefaultNamingContext")) 
    
    intRow = 2
    
    ' ALTERACOES =========================================================
    
    Const ADS_SCOPE_SUBTREE = 2
    ' Get domain components
    strDomain = objRootDSE.Get("DefaultNamingContext")
    ' Set ADO connection
    Set objConnection = CreateObject("ADODB.Connection")
    objConnection.Provider = "ADsDSOObject"
    objConnection.Open "Active Directory Provider"
    ' Set ADO command
    Set objCommand = CreateObject("ADODB.Command")
    Set objCommand.ActiveConnection = objConnection
    objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE 
    
    strAtributos="distinguishedName,samAccountName,DisplayName,physicalDeliveryOfficeName,mail,Department,Description"
    objCommand.CommandText = "SELECT " & strAtributos & _
    		" FROM 'LDAP://" & strDomain & _
    		"' WHERE objectCategory='person' AND objectClass='user'"
    		
    ' Set recordset to hold the query result
    Set objRecordSet = objCommand.Execute
    
    
     
    Do Until objRecordSet.EOF
    
        WScript.Echo objRecordSet.Fields("samAccountName").Value 
    	objSheet.Cells(intRow, 1).Value = objRecordSet.Fields("sAMAccountName").Value
    	objSheet.Cells(intRow, 2).Value = objRecordSet.Fields("DisplayName").Value
    	objSheet.Cells(intRow, 3).Value = objRecordSet.Fields("physicalDeliveryOfficeName").Value
    	objSheet.Cells(intRow, 4).Value = objRecordSet.Fields("mail").Value
    	objSheet.Cells(intRow, 5).Value = objRecordSet.Fields("Department").Value
    	objSheet.Cells(intRow, 6).Value = objRecordSet.Fields("Description").Value
    	intRow = intRow + 1
    	
    	'Move para o próximo registro
    	objRecordSet.MoveNext
    
    Loop
    
    ' FIM ALTERACOES ==========================================================
    
    objExcel.ActiveWorkbook.SaveAs strExcelPath
    objExcel.ActiveWorkbook.Close
    
    objExcel.Application.Quit
    
    Set objSheet = Nothing
    Set objExcel = Nothing
    
    
    ' ***************************************************************** ' 
    EndTime = Now 
    Wscript.Echo vbCrLf & "EndTime = " & EndTime 
    Wscript.Echo "Seconds Elapsed: " & DateDiff("s", StartTime, EndTime) 
    Wscript.Echo "Script Complete" 
    Wscript.Quit(0) 
    ' ***************************************************************** '

    Observações:

    1. Comentei a primeira linha (Option Explicit) pois ela obriga a declaração de todas as variáveis, não que isso seja ruim, mas estava me dando trabalho declarar as minha váriaveis, fique a vontade para declarar.

    Adaptei do exemplo abaixo

    Get users distinguished name using ADO and VbScript

    http://www.winfrastructure.net/article.aspx?BlogEntry=Get-users-distinguished-name-using-ADO-and-VbScript


    Fábio de Paula Junior

    quinta-feira, 31 de outubro de 2013 13:13
    Moderador