Pages

Wednesday, June 29, 2011

Get groups of a specific users from Active Directory

This scrpit will prompt to enter Domain and User name and will export the User groups from Active Directory in Excel File

Option Explicit
Dim objExcel : Set objExcel = CreateObject("Excel.Application")
With objExcel
    .Visible = True
    .DisplayAlerts = False
    Dim objWorkBook : Set objWorkBook = .WorkBooks.Add
    Dim objSheet : Set objSheet = .Worksheets(1)
End With

Dim objNetwork, strDomain, strUser, objUser, objGroup, strGroupMemberships
'Get the domain and username from the WScript.Network object
Set objNetwork = CreateObject("WScript.Network")

strDomain = InputBox("Enter the Domain Name")
strUser = InputBox("Enter the User Name")
if strUSer <> "" then
'Instanciate the user object from the data above
Set objUser = GetObject("WinNT://" & strDomain & "/" & strUser)

'Run through the users groups and put them in the string
Create_Excel_Header(strUser)

Dim intRow : intRow = 2
Dim intColumn : intColumn = 1

For Each objGroup In objUser.Groups
    objSheet.Cells(intRow, 1 ).Value = objGroup.Name
    intRow = intRow  + 1
Next
else
 MSgbox "Error Processing your request",vbCritical,"Preetech Software Solutions"
End If

Format_Excel_File()
Sub Create_Excel_Header(strUser)
    With objSheet
        .Cells(1, 1).Value = "Group(s) of User:" & strUser
    End With

    Dim objRange : Set objRange = objSheet.UsedRange
    objRange.Select

    With objRange
        .Font.Bold = True
        .Font.Name = "Arial"
        .Font.Size = 10
        .WrapText = False
        .HorizontalAlignment = -4108
        .Interior.ColorIndex = 37
        .Cells.RowHeight = 25       
    End With
End Sub

Sub Format_Excel_File()
    Const xlsEdgeBottom = 9
    Const xlsEdgeLeft = 7
    Const xlsEdgeRight = 10
    Const xlsEdgeTop = 8
    Const xlsInsideHorizontal = 12
    Const xlsInsideVertical = 11
    Const xlsContinuous = 1
    Const xlsAutomatic = -4105
    Const xlsMedium = -4138
   
    Dim objRange : Set objRange = objSheet.UsedRange
    objRange.Select
   
    objRange.Columns.AutoFit
   
    Dim arrBorders : arrBorders = Array(xlsEdgeLeft, xlsEdgeTop, xlsEdgeBottom, xlsEdgeRight, xlsInsideVertical, xlsInsideHorizontal)
    Dim intBorder
   
    For Each intBorder in arrBorders
        With objRange.Borders(intBorder)
            .LineStyle = xlsContinuous
            .Weight = xlsMedium
            .ColorIndex = xlsAutomatic
        End With
    Next
End Sub

No comments:

Post a Comment