' GenericADO.vbs
' VBScript program to use ADO to query Active Directory.
'
' ----------------------------------------------------------------------
' Copyright (c) 2009-2012 Richard L. Mueller
' Hilltop Lab web site - http://www.rlmueller.net
' Version 1.0 - December 11, 2009
' Version 1.1 - December 12, 2009
' Version 1.2 - December 15, 2009
' Version 1.3 - December 31, 2009
' Version 1.4 - January 27, 2010 - Option to create csv file.
' Version 1.5 - February 6, 2010 - Bug fix.
' Version 1.6 - May 23, 2011 - Convert SID and GUID values.
' Version 1.7 - April 21, 2012 - Handle more SID values.
' Version 1.8 - September 19, 2012 - Handle logonHours.
'
' The program prompts for the DN of the base of the query, the LDAP
' syntax filter, and a comma delimited list of attribute values to be
' retrieved. Displays attribute values for objects matching filter in
' base selected.
'
' You have a royalty-free right to use, modify, reproduce, and
' distribute this script file in any way you find useful, provided that
' you agree that the copyright owner above has no warranty, obligations,
' or liability for such use.

Option Explicit

Dim adoCommand, adoConnection, strBase, strFilter, strAttributes
Dim objRootDSE, strBaseDN, strQuery, adoRecordset
Dim arrAttributes, k, intCount, strValue, strItem, strType
Dim objValue, lngHigh, lngLow, lngValue, strAttr, dtmValue
Dim objShell, lngBiasKey, lngBias, dtmDate, blnCSV, strLine
Dim strMulti, strArg, lngLHBiasKey, lngLHBias

blnCSV = False
If (Wscript.Arguments.Count = 1) Then
    strArg = Wscript.Arguments(0)
    Select Case LCase(strArg)
        Case "/csv"
            blnCSV = True
    End Select
End If

' Obtain local Time Zone bias from machine registry.
Set objShell = CreateObject("Wscript.Shell")
lngBiasKey = objShell.RegRead("HKLM\System\CurrentControlSet\Control\" _
    & "TimeZoneInformation\ActiveTimeBias")
If (UCase(TypeName(lngBiasKey)) = "LONG") Then
    lngBias = lngBiasKey
ElseIf (UCase(TypeName(lngBiasKey)) = "VARIANT()") Then
    lngBias = 0
    For k = 0 To UBound(lngBiasKey)
        lngBias = lngBias + (lngBiasKey(k) * 256^k)
    Next
End If
' Obtain local Time Zone bias for logonHours from machine registry.
' This bias does not change with Daylight Savings Time.
lngLHBiasKey = objShell.RegRead("HKLM\System\CurrentControlSet\Control\" _
    & "TimeZoneInformation\Bias")
If (UCase(TypeName(lngLHBiasKey)) = "LONG") Then
    lngLHBias = lngLHBiasKey
ElseIf (UCase(TypeName(lngLHBiasKey)) = "VARIANT()") Then
    lngLHBias = 0
    For k = 0 To UBound(lngLHBiasKey)
        lngLHBias = lngLHBias + (lngLHBiasKey(k) * 256^k)
    Next
End If
Set objShell = Nothing

' Setup ADO objects.
Set adoCommand = CreateObject("ADODB.Command")
Set adoConnection = CreateObject("ADODB.Connection")
adoConnection.Provider = "ADsDSOObject"
adoConnection.Open "Active Directory Provider"
adoCommand.ActiveConnection = adoConnection

' Prompt for base of query.
strBaseDN = Trim(InputBox("Specify DN of base of query, or blank for entire domain"))
If (strBaseDN = "") Then
    ' Search entire Active Directory domain.
    Set objRootDSE = GetObject("LDAP://RootDSE")
    strBaseDN = objRootDSE.Get("defaultNamingContext")
End If
If (InStr(LCase(strBaseDN), "dc=") = 0) Then
    Set objRootDSE = GetObject("LDAP://RootDSE")
    strBaseDN = strBaseDN & "," & objRootDSE.Get("defaultNamingContext")
    strBaseDN = Replace(strBaseDN, ",,", ",")
End If
strBase = "<LDAP://" & strBaseDN & ">"

' Prompt for filter.
strFilter = Trim(InputBox("Enter LDAP syntax filter"))
If (Left(strFilter, 1) <> "(") Then
    strFilter = "(" & strFilter
End If
If (Right(strFilter, 1) <> ")") Then
    strFilter = strFilter & ")"
End If

' Prompt for attributes.
strAttributes = InputBox("Enter comma delimited list of attribute values to retrieve")
strAttributes = Replace(strAttributes, " ", "")
strAttr = strAttributes
If (strAttributes = "") Then
    strAttributes = "distinguishedName"
Else
    strAttributes = "distinguishedName" & "," & strAttributes
End If
arrAttributes = Split(strAttributes, ",")

' Construct the LDAP syntax query.
strQuery = strBase & ";" & strFilter & ";" & strAttributes & ";subtree"
adoCommand.CommandText = strQuery
adoCommand.Properties("Page Size") = 200
adoCommand.Properties("Timeout") = 30
adoCommand.Properties("Cache Results") = False

If (blnCSV = False) Then
    Wscript.Echo "Base of query: " & strBaseDN
    Wscript.Echo "Filter: " & strFilter
    Wscript.Echo "Attributes: " & strAttr
Else
    ' Output header line for csv.
    strLine = "DN"
    For k = 1 To UBound(arrAttributes)
        strLine = strLine & "," & arrAttributes(k)
    Next
    Wscript.Echo strLine
End If

' Run the query.
' Trap possible errors.
On Error Resume Next
Set adoRecordset = adoCommand.Execute
If (Err.Number <> 0) Then
    Select Case Err.Number
        Case -2147217865
            Wscript.Echo "Table does not exist. Base of search not found."
        Case -2147217900
            Wscript.Echo "One or more errors. Filter syntax error."
        Case -2147467259
            Wscript.Echo "Unspecified error. Invalid attribute name."
        Case Else
            Wscript.Echo "Error: " & Err.Number
            Wscript.Echo "Description: " & Err.Description
    End Select
    Wscript.Quit
End If
On Error GoTo 0

' Enumerate the resulting recordset.
intCount = 0
Do Until adoRecordset.EOF
    ' Retrieve values and display.
    intCount = intCount + 1
    If (blnCSV = True) Then
        strLine = """" & adoRecordset.Fields("distinguishedName").Value & """"
    Else
        Wscript.Echo "DN: " & adoRecordset.Fields("distinguishedName").Value
    End If
    For k = 1 To UBound(arrAttributes)
        strType = TypeName(adoRecordset.Fields(arrAttributes(k)).Value)
        If (strType = "Object") Then
            Set objValue = adoRecordset.Fields(arrAttributes(k)).Value
            lngHigh = objValue.HighPart
            lngLow = objValue.LowPart
            If (lngLow < 0) Then
                lngHigh = lngHigh + 1
            End If
            lngValue = (lngHigh * (2 ^ 32)) + lngLow
            If (lngValue > 120000000000000000) Then
                dtmValue = #1/1/1601# + (lngValue/600000000 - lngBias)/1440
                On Error Resume Next
                dtmDate = CDate(dtmValue)
                If (Err.Number <> 0) Then
                    On Error GoTo 0
                    If (blnCSV = True) Then
                        strLine = StrLine & ",<Never>"
                    Else
                        Wscript.Echo "  " & arrAttributes(k) _
                            & ": " & FormatNumber(lngValue, 0) _
                            & " <Never>"
                    End If
                Else
                    On Error GoTo 0
                    If (blnCSV = True) Then
                        strLine = strLine & "," & CStr(dtmDate)
                    Else
                        Wscript.Echo "  " & arrAttributes(k) _
                            & ": " & FormatNumber(lngValue, 0) _
                            & " (" & CStr(dtmDate) & ")"
                    End If
                End If
            Else
                If (blnCSV = True) Then
                    strLine = strLine & ",""" & FormatNumber(lngValue, 0) & """"
                Else
                    Wscript.Echo "  " & arrAttributes(k) _
                        & ": " & FormatNumber(lngValue, 0)
                End If
            End If
        Else
            strValue = adoRecordset.Fields(arrAttributes(k)).Value
            Select Case strType
                Case "String"
                    If (blnCSV = True) Then
                        strLine = strLine & ",""" & strValue & """"
                    Else
                        Wscript.Echo "  " & arrAttributes(k) _
                            & ": " & strValue
                    End If
                Case "Variant()"
                    strMulti = ""
                    For Each strItem In strValue
                        If (blnCSV = True) Then
                            If (strMulti = "") Then
                                strMulti = """" & strItem & """"
                            Else
                                strMulti = strMulti & ";""" & strItem & """"
                            End If
                        Else
                            Wscript.Echo "  " & arrAttributes(k) _
                                & ": " & strItem
                        End If
                    Next
                    If (blnCSV = True) Then
                        strLine = strLine & "," & strMulti
                    End If
                Case "Long"
                    If (blnCSV = True) Then
                        strLine = strLine & ",""" & FormatNumber(strValue, 0) & """"
                    Else
                        Wscript.Echo "  " & arrAttributes(k) _
                            & ": " & FormatNumber(strValue, 0)
                    End If
                Case "Boolean"
                    If (blnCSV = True) Then
                        strLine = strLine & "," & CBool(strValue)
                    Else
                        Wscript.Echo "  " & arrAttributes(k) _
                            & ": " & CBool(strValue)
                    End If
                Case "Date"
                    If (blnCSV = True) Then
                        strLine = strLine & "," & CDate(strValue)
                    Else
                        Wscript.Echo "  " & arrAttributes(k) _
                            & ": " & CDate(strValue)
                    End If
                Case "Byte()"
                    If (LCase(arrAttributes(k)) = "logonhours") Then
                        ' The logonHours attribute.
                        If (blnCSV = True) Then
                            strLine = strLine & "," & OctetToHours(strValue)
                        Else
                            Wscript.Echo "  " & arrAttributes(k) _
                                & ": " & OctetToHours(strValue)
                        End If
                    Else
                        strItem = OctetToHexStr(strValue)
                        If (InStr(UCase(arrAttributes(k)), "GUID") > 0) Then
                            ' A GUID value.
                            If (blnCSV = True) Then
                                strLine = strLine & "," & HexGUIDToDisplay(strItem)
                            Else
                                Wscript.Echo "  " & arrAttributes(k) _
                                    & ": " & HexGUIDToDisplay(strItem)
                            End If
                        ElseIf (Left(strItem, 6) = "010100") Or (Left(strItem, 6) = "010200") _
                                Or (Left(strItem, 6) = "010400") Or (Left(strItem, 6) = "010500") Then
                            ' A SID value.
                            If (blnCSV = True) Then
                                strLine = strLine & "," & HexSIDToDec(strItem)
                            Else
                                Wscript.Echo "  " & arrAttributes(k) _
                                    & ": " & HexSIDToDec(strItem)
                            End If
                        Else
                            ' Other OctetString value.
                            If (blnCSV = True) Then
                                strLine = strLine & "," & strItem
                            Else
                                Wscript.Echo "  " & arrAttributes(k) _
                                    & ": " & strItem
                            End If
                        End If
                    End If
                Case "Null"
                    If (blnCSV = True) Then
                        strLine = strLine & ",<no value>"
                    Else
                        Wscript.Echo "  " & arrAttributes(k) _
                            & ": <no value>"
                    End If
                Case Else
                    If (blnCSV = True) Then
                        strLine = strLine & ",<unsupported syntax>"
                    Else
                        Wscript.Echo "  " & arrAttributes(k) _
                            & ": <unsupported syntax " & TypeName(strValue) & " >"
                    End If
            End Select
        End If
    Next
    If (blnCSV = True) Then
        Wscript.Echo strLine
    End If
    adoRecordset.MoveNext
Loop
If (blnCSV = False) Then
    Wscript.Echo "Number of objects found: " & CStr(intCount)
End If

' Clean up.
adoRecordset.Close
adoConnection.Close

Function OctetToHexStr(ByVal arrbytOctet)
    ' Function to convert OctetString (byte array) to Hex string.

    Dim k

    OctetToHexStr = ""
    For k = 1 To Lenb(arrbytOctet)
        OctetToHexStr = OctetToHexStr _
            & Right("0" & Hex(Ascb(Midb(arrbytOctet, k, 1))), 2)
    Next

End Function

Function HexGUIDToDisplay(ByVal strHexGUID)
    ' Function to convert GUID value in hex format to display format.

    Dim TempGUID, GUIDStr

    GUIDStr = Mid(strHexGUID, 7, 2)
    GUIDStr = GUIDStr & Mid(strHexGUID, 5, 2)
    GUIDStr = GUIDStr & Mid(strHexGUID, 3, 2)
    GUIDStr = GUIDStr & Mid(strHexGUID, 1, 2)
    GUIDStr = GUIDStr & Mid(strHexGUID, 11, 2)
    GUIDStr = GUIDStr & Mid(strHexGUID, 9, 2)
    GUIDStr = GUIDStr & Mid(strHexGUID, 15, 2)
    GUIDStr = GUIDStr & Mid(strHexGUID, 13, 2)
    GUIDStr = GUIDStr & Mid(strHexGUID, 17)

    TempGUID = "{" & Mid(GUIDStr, 1, 8) & "-" & Mid(GUIDStr, 9, 4) _
        & "-" & Mid(GUIDStr, 13, 4) & "-" & Mid(GUIDStr, 17, 4) _
        & "-" & Mid(GUIDStr, 21, 15) & "}"

    HexGUIDToDisplay = TempGUID

End Function

Function HexSIDToDec(ByVal strSID)
    ' Function to convert most hex SID values to decimal format.

    Dim arrbytSID, lngTemp, j

    ReDim arrbytSID(Len(strSID)/2 - 1)
    For j = 0 To UBound(arrbytSID)
        arrbytSID(j) = CInt("&H" & Mid(strSID, 2*j + 1, 2))
    Next

    If (UBound(arrbytSID) = 11) Then
        HexSIDToDec = "S-" & arrbytSID(0) & "-" _
            & arrbytSID(1) & "-" & arrbytSID(8)

        Exit Function
    End If

    If (UBound(arrbytSID) = 15) Then
        HexSIDToDec = "S-" & arrbytSID(0) & "-" _
            & arrbytSID(1) & "-" & arrbytSID(8)

        lngTemp = arrbytSID(15)
        lngTemp = lngTemp * 256 + arrbytSID(14)
        lngTemp = lngTemp * 256 + arrbytSID(13)
        lngTemp = lngTemp * 256 + arrbytSID(12)

        HexSIDToDec = HexSIDToDec & "-" & CStr(lngTemp)

        Exit Function
    End If

    HexSIDToDec = "S-" & arrbytSID(0) & "-" _
        & arrbytSID(1) & "-" & arrbytSID(8)

    lngTemp = arrbytSID(15)
    lngTemp = lngTemp * 256 + arrbytSID(14)
    lngTemp = lngTemp * 256 + arrbytSID(13)
    lngTemp = lngTemp * 256 + arrbytSID(12)

    HexSIDToDec = HexSIDToDec & "-" & CStr(lngTemp)

    lngTemp = arrbytSID(19)
    lngTemp = lngTemp * 256 + arrbytSID(18)
    lngTemp = lngTemp * 256 + arrbytSID(17)
    lngTemp = lngTemp * 256 + arrbytSID(16)

    HexSIDToDec = HexSIDToDec & "-" & CStr(lngTemp)

    lngTemp = arrbytSID(23)
    lngTemp = lngTemp * 256 + arrbytSID(22)
    lngTemp = lngTemp * 256 + arrbytSID(21)
    lngTemp = lngTemp * 256 + arrbytSID(20)

    HexSIDToDec = HexSIDToDec & "-" & CStr(lngTemp)

    If (UBound(arrbytSID) > 23) Then
        lngTemp = arrbytSID(27)
        lngTemp = lngTemp * 256 + arrbytSID(26)
        lngTemp = lngTemp * 256 + arrbytSID(25)
        lngTemp = lngTemp * 256 + arrbytSID(24)

        HexSIDToDec = HexSIDToDec & "-" & CStr(lngTemp)
    End If

End Function

Function OctetToHours(ByVal bytLogonHours)
    ' Function to convert Octet Value (byte array) into binary string
    ' representing the logonHours attribute.
    ' Variable lngLHBias must have global scope.

    Dim k, arrbytLogonHours(20), j, bytLogonHour, m
    Dim arrintLogonHoursBits(167), intCounter, intLogonHour

    ' Populate a byte array.
    For k = 1 To LenB(bytLogonHours)
        arrbytLogonHours(k - 1) = AscB(MidB(bytLogonHours, k, 1))
    Next

    ' Populate a bit array, offset by time zone bias.
    j = 0
    For Each bytLogonHour In arrbytLogonHours
        For k = 7 To 0 Step -1
            m = 8*j + k - Round((lngLHBias/60) + 0.1)
            If (m < 0) Then
                m = m + 168
            End If
            If (bytLogonHour And 2^k) Then
                arrintLogonHoursBits(m) = 1
            Else
                arrintLogonHoursBits(m) = 0
            End if
        Next
        j = j + 1
    Next
    OctetToHours = ""
    intCounter = 0
    For Each intLogonHour In arrintLogonHoursBits
        If (intCounter = 24) Then
            OctetToHours = OctetToHours & "-"
            intCounter = 0
        End If
        OctetToHours = OctetToHours & CStr(intLogonHour)
        intCounter = intCounter + 1
        If (intCounter = 8) Or (intCounter = 16) THen
            OctetToHours = OctetToHours & "-"
        End If
    Next
End Function