initial move from local

mod_exc_ADGroupsUsers.bas

@@ -0,0 +1,272 @@
+Attribute VB_Name = "mod_exc_ADGroupsUsers"
+Option Explicit
+Option Base 0
+
+' mod_exc_ADGroupsUsers.bas
+
+' 130620.AMG added Prepare_Workbook function to make it self-evident how to use the module
+' 111120.AMG created
+
+Sub Prepare_Workbook_For_AD_Query()
+    With Application.Workbooks.Add
+        .Worksheets(1).Name = "Query"
+        .Worksheets(2).Name = "Results"
+        .Worksheets(3).Delete
+        .Worksheets(1).Cells(1, 1).Value = "QueryType"
+        .Worksheets(1).Cells(2, 1).Value = "Location (e.g. Domain)"
+        .Worksheets(1).Cells(3, 1).Value = "Item"
+        .Worksheets(1).Cells(4, 1).Value = "More item(s)"
+        .Worksheets(1).Cells(5, 1).Value = "..."
+        .Worksheets(1).Cells(1, 2).Validation.Add _
+            Type:=xlValidateList _
+            , Operator:=xlEqual _
+            , Formula1:="ListUsers,ListGroups,ComputerGroups"
+        .Activate
+    End With
+End Sub
+
+
+Sub Execute_AD_Query_And_Overwrite_Results()
+'    Dim wksQuery, wksResults As Worksheet
+'    Set wksQuery = ActiveWorkbook.Sheets("Query")
+'    Set wksResults = ActiveWorkbook.Sheets("Results")
+    With ActiveWorkbook.Sheets("Query")
+        QueryEachItemAndOutputResults _
+              wksResults:=ActiveWorkbook.Sheets("Results") _
+            , strQueryType:=.Cells(1, 2) _
+            , strLocation:=.Cells(2, 2) _
+            , rngItems:=.Range("B3:B1000") _
+
+    End With
+End Sub
+
+Function QueryEachItemAndOutputResults _
+    (ByRef wksResults As Worksheet _
+    , ByVal strQueryType As String _
+    , ByVal strLocation As String _
+    , ByVal rngItems As Range _
+    )
+
+    Dim varItem, varResults
+    Dim strResultList As String
+    Dim lngOutputRow, lngRow, lngCol As Long
+'    Dim lngIndex As Long
+    Dim intColItems, intColResults As Integer
+
+    Dim strColumns() As String
+
+    ' prepare sheet and add titles
+    With wksResults
+        .Cells.Clear
+        .Range("A1").Value = "Item"
+        .Range("B1").Value = "Group"
+
+        lngOutputRow = 2
+
+        For Each varItem In rngItems
+            ' get member list as a comma separated list
+            If varItem <> "" Then
+                ' determine type of query
+                ' obtain results and split into an array
+                ' then determine which column to output what
+                Select Case strQueryType
+                    Case "ListUsers":
+                        varResults = Split(GetGroupUsers(varItem), ",")
+                        intColItems = 2
+                        intColResults = 1
+                    Case "ListGroups":
+                        'strColumns = GetWinntProviderResults(strLocation & "/" & varItem, strQueryType)
+                        varResults = Split(GetUserGroups(varItem), ",")
+                        intColItems = 1
+                        intColResults = 2
+                    Case "ComputerGroups":
+                        strColumns = GetComputerGroups(varItem)
+                        'strColumns = GetWinntProviderResults(varItem, strQueryType)
+                        varResults = Array(Split(strColumns(0), ","), Split(strColumns(1), ","))
+                        intColItems = 1
+                        intColResults = 2
+                End Select
+               ' loop and output results
+                    If strQueryType = "ComputerGroups" Then
+'                        Dim lngResultRows As Long
+'                        If VarType(varResults(0)) > 8192 Then ' so its a multidimension array
+'                            lngResultRows = UBound(varResults(0))
+'                        Else
+'                            lngResultRows = UBound(varResults)
+'                        End If
+'                        For lngRow = 0 To lngResultRows
+                        For lngRow = LBound(varResults(0)) To UBound(varResults(0))
+                            .Cells(lngOutputRow, intColItems).Value = varItem
+                            For lngCol = LBound(varResults) To UBound(varResults)
+                                .Cells(lngOutputRow, intColResults + lngCol).Value = varResults(lngCol)(lngRow)
+                            Next lngCol
+        '                    .Cells(lngOutputRow, intColResults + 1).Value = varResults(1)(lngRow)
+                            lngOutputRow = lngOutputRow + 1
+                        Next lngRow
+                    Else
+
+                For lngRow = LBound(varResults) To UBound(varResults)
+                    .Cells(lngOutputRow, intColItems).Value = varItem
+                    .Cells(lngOutputRow, intColResults).Value = varResults(lngRow)
+                    lngOutputRow = lngOutputRow + 1
+                Next lngRow
+                    End If
+            End If
+        Next varItem
+    End With
+End Function
+
+Function GetGroupUsers(ByVal strGroupName As String) As String
+    ' credit > http://www.excelforum.com/2280511-post12.html
+    Application.StatusBar = "Performing " & "GetGroupUsers" & " on item named: " & strGroupName
+
+    Dim objGroup, objDomain, objMember
+    Dim strMemberList As String, strDomain As String
+    On Error Resume Next
+    Set objDomain = GetObject("LDAP://rootDse")
+    strDomain = objDomain.Get("dnsHostName")
+
+    Set objGroup = GetObject("WinNT://" & strDomain & "/" & strGroupName & ",group")
+
+    ' without the object existing in the calling function it can't enumerate the instances
+    ' so we serialise it as a string, making it possible for the caller to parse
+    For Each objMember In objGroup.Members
+        strMemberList = strMemberList & "," & objMember.Name
+    Next objMember
+    ' strip off the leading comma
+    GetGroupUsers = Mid$(strMemberList, 2)
+    Application.StatusBar = False
+End Function
+
+
+Function GetUserGroups(ByVal strUserName As String) As String
+    Dim objUser, objDomain, objGroup
+    Application.StatusBar = "Performing " & "GetUserGroups" & " on item named: " & strUserName
+
+    Dim strGroupList As String, strDomain As String
+    On Error Resume Next
+    Set objDomain = GetObject("LDAP://rootDse")
+    strDomain = objDomain.Get("dnsHostName")
+
+    Set objUser = GetObject("WinNT://" & strDomain & "/" & strUserName & ",user")
+
+    For Each objGroup In objUser.Groups
+        strGroupList = strGroupList & "," & objGroup.Name
+    Next objGroup
+    ' strip off the leading comma
+    GetUserGroups = Mid$(strGroupList, 2)
+    Application.StatusBar = False
+End Function
+
+
+Function GetComputerGroups(ByVal strComputerName As String) As Variant
+    Dim strResultList(1) As String
+
+    Application.StatusBar = "Performing " & "GetComputerGroups" & " on item named: " & strComputerName
+
+    ' This uses simple GetObject object management, like VBS style - brute, difficult to debug but effective
+    Dim objList, ObjResult, ObjChild
+
+'    Set objList = GetObject("WinNT://" & strComputerName & ",group")
+    Set objList = GetObject("WinNT://" & strComputerName & "")
+    ' credit > http://www.activexperts.com/activmonitor/windowsmanagement/adminscripts/usersgroups/localgroups/
+    objList.Filter = Array("group")
+    ' help > search WinNT in http://blogs.technet.com/b/heyscriptingguy/archive/2004/12/13/how-can-i-run-a-script-under-alternate-credentials.aspx
+
+    ' without the object existing in the calling function it can't enumerate the instances
+    ' so we serialise it as a string, making it possible for the caller to parse
+    ' in VBA it's actually far more efficient to extend a string than it is to perpetually redim an array!
+    For Each ObjResult In objList
+        For Each ObjChild In ObjResult.Members
+            strResultList(0) = strResultList(0) & "," & ObjResult.Name ' this is the specific property required
+            strResultList(1) = strResultList(1) & "," & ObjChild.Name
+        Next
+    Next
+    ' strip off the leading comma as we return the function's result
+    strResultList(0) = Mid$(strResultList(0), 2)
+    strResultList(1) = Mid$(strResultList(1), 2)
+
+    Application.StatusBar = False
+
+    GetComputerGroups = strResultList
+
+End Function
+
+
+
+
+'Function GetWinntProviderResults(ByVal strItemName As String, ByVal strQueryType As String) As Variant
+'    Dim strResultList(1) As String
+'    Application.StatusBar = "Performing " & strQueryType & " on item named: " & strItemName
+'
+'    ' This uses simple GetObject object management, like VBS style - brute, difficult to debug but effective
+'    Dim objResponse, objEnumerate1, objInstance1, objEnumerate2, objInstance2
+'    Dim intEnumerations, intEnum As Integer
+'
+'    Dim strFilter
+'
+'    Select Case strQueryType
+'        Case "ListUsers":
+''            varResults = Split(GetGroupUsers(varItem), ",")
+''            intColItems = 2
+''            intColResults = 1
+'        Case "ListGroups":
+'            strFilter = "user"
+'            intEnumerations = 1
+'        Case "ComputerGroups":
+'            strFilter = "group"
+'            intEnumerations = 2
+''            varResults = Array(Split(strColumns(0), ","), Split(strColumns(1), ","))
+''            intColItems = 1
+''            intColResults = 2
+'    End Select
+'
+''    'location (e.g. domain) is now passed as a prefix on ItemName
+''    Set objDomain = GetObject("LDAP://rootDse")
+''    strDomain = objDomain.Get("dnsHostName")
+'
+'    'Set objResponse = GetObject("WinNT://" & strItemName & "")
+'    Set objResponse = GetObject("WinNT://" & strItemName & "," & strFilter)
+'    ' credit > http://www.activexperts.com/activmonitor/windowsmanagement/adminscripts/usersgroups/localgroups/
+'    'objResponse.Filter = Array(strFilter)
+'    ' help > search WinNT in http://blogs.technet.com/b/heyscriptingguy/archive/2004/12/13/how-can-i-run-a-script-under-alternate-credentials.aspx
+'
+'
+'    Select Case strQueryType
+'        Case "ListUsers":
+'        Case "ListGroups":
+'            Set objEnumerate1 = objResponse.Groups
+'        Case "ComputerGroups":
+'            Set objEnumerate1 = objResponse
+'    End Select
+'    For Each objInstance1 In objEnumerate1
+'
+'        Select Case strQueryType
+'            Case "ListUsers":
+'            Case "ListGroups":
+'                Set objEnumerate2 = objInstance1
+'            Case "ComputerGroups":
+'                Set objEnumerate2 = objInstance1.Members
+'        End Select
+''        For Each objInstance2 In objEnumerate2
+'
+'            ' without the object existing in the calling function it can't enumerate the instances
+'            ' so we serialise it as a string, making it possible for the caller to parse
+'            ' in VBA it's actually far more efficient to extend a string than it is to perpetually redim an array!
+'
+'            strResultList(0) = strResultList(0) & "," & objInstance1.Name ' this is the specific property required
+'            If intEnumerations = 2 Then
+'                strResultList(1) = strResultList(1) & "," & objInstance2.Name
+'            End If
+''        Next
+'    Next
+'    ' strip off the leading comma as we return the function's result
+'    For intEnum = LBound(strResultList) To UBound(strResultList)
+'        strResultList(intEnum) = Mid$(strResultList(intEnum), 2)
+'    Next intEnum
+'
+'    Application.StatusBar = False
+'
+'    GetWinntProviderResults = strResultList
+'
+'End Function

mod_exc_ADlookup.bas

@@ -0,0 +1,103 @@
+Attribute VB_Name = "mod_exc_ADlookup"
+' References
+' ==========
+'
+' This module uses the following references (paths and GUIDs may vary)
+'
+' Active DS Type Library (C:\WINDOWS\system32\activeds.tlb) {97D25DB0-0363-11CF-ABC4-02608C9E7553}
+' Microsoft ActiveX Data Objects 2.8 Library (C:\Program Files\Common Files\System\ADO\msado15.dll) {2A75196C-D9EB-4129-B803-931327F72D5C}
+
+Option Explicit
+
+Public Enum AdObjectType
+    AdUser
+    AdComputer
+End Enum
+
+' credit > http://www.freevbcode.com/ShowCode.Asp?ID=710
+Public Function GetAdAttributeFrom(strObjectName As String, strAttributeName As String, Optional objType As AdObjectType = AdObjectType.AdUser) As String
+
+Dim oRoot As ActiveDs.IADs
+Dim oDomain As ActiveDs.IADs
+
+Dim strQuery As String
+Dim strValue As String
+
+On Error GoTo ErrHandler:
+
+'Get user Using LDAP/ADO.  There is an easier way
+'to bind to a user object using the WinNT provider,
+'but this way is a better for educational purposes
+Set oRoot = GetObject("LDAP://rootDSE")
+''''''''work in the default domain
+' sDomain = oRoot.Get("defaultNamingContext")
+' Set oDomain = GetObject("LDAP://" & sDomain)
+Set oDomain = GetObject("LDAP://" & oRoot.Get("defaultNamingContext"))
+
+' add the base to the query
+strQuery = "<" & oDomain.ADsPath & ">;"
+
+Select Case objType
+    Case AdObjectType.AdUser
+        strQuery = strQuery _
+            & "(&" _
+            & "(objectCategory=person)" _
+            & "(objectClass=user)" _
+            & "(sAMAccountName=" & strObjectName & ")" _
+            & ");"
+    Case AdObjectType.AdComputer
+        strQuery = strQuery _
+            & "(&" _
+            & "(objectCategory=computer)" _
+            & "(objectClass=computer)" _
+            & "(name=" & strObjectName & ")" _
+            & ");"
+End Select
+
+' Add the attribute name
+strQuery = strQuery & strAttributeName & ";"
+' this was for the old object-based version
+'strQuery = strQuery & "adsPath;"
+
+' set the query depth to check the whole domain tree
+strQuery = strQuery & "subTree"
+
+
+
+Dim cnn As New ADODB.Connection
+Dim rst As ADODB.Recordset
+
+cnn.Open "Data Source=Active Directory Provider;Provider=ADsDSOObject"
+
+Set rst = cnn.Execute(strQuery)
+
+If Not rst.EOF Then
+On Error Resume Next
+    strValue = rst(0)
+    If strValue = "" Then strValue = rst(0).Value(0)
+    ' this was the old object based version
+'    Dim user As ActiveDs.IADsUser
+'    Set user = GetObject(rst("adsPath"))
+'    strValue = user.ADsPath
+End If
+
+GetAdAttributeFrom = strValue
+
+
+' cleanup
+ErrHandler:
+On Error Resume Next
+If Not rst Is Nothing Then
+    If rst.State <> 0 Then rst.Close
+    Set rst = Nothing
+End If
+
+If Not cnn Is Nothing Then
+    If cnn.State <> 0 Then cnn.Close
+    Set cnn = Nothing
+End If
+
+Set oRoot = Nothing
+Set oDomain = Nothing
+
+End Function