[原创] VBS源码-LDAP查询器命令行版

yu2n

VBS源码-LDAP查询器
功能：查询域用户信息
环境：WinXP域内主机、WinXP域外主机、Win2003
作者：yu2n
简介：很小众的东西，因为一般人用不上就不多说了，知道的人自然知道。

提示：注意需要域用户账号验证的部分

GetADInfo("hkadmin", "hk123456", "hkHeXie.com", sColumnName, sQuery, CInt(sPageSize), CInt(sThisPage))
复制代码

    ' 使用其他域用户验证-开始
    objConnection.Properties("User ID") = sADUserName
    objConnection.Properties("Password") = sADPassword
    objConnection.Properties("Encrypt Password") = TRUE
    objConnection.Properties("ADSI Flag") = 1
    ' 使用其他域用户验证-结束
复制代码

代码如下：

'On Error Resume Next

CmdMode "LDAP查询", "1f"

Main
Sub Main
    Dim sQuery, sInfo
    sQuery = "(Department='*采购部*' And samAccountName='*CG*' And DisplayName='**')"
    sQuery = "(samAccountName='*CG001*')"
    sQuery = "(Department='*料*' And DisplayName='*min*')"
    Do
        sInfo = ""
        ' 取得輸入的SQL 命令
        sQuery = InputBox(  "請輸入以下查询字段：" & vbCrLf & vbCrLf & _
                            "　登陸名(samAccountName)" & vbCrLf & _
                            "　用戶名(Name)" & vbCrLf & _
                            "　姓名(DisplayName)" & vbCrLf & _
                            "　部门(Department)" & vbCrLf & vbCrLf & _
                            "SQL 命令:", _
                            "LDAP 查詢", _
                            sQuery)
        If sQuery = "" Then
            Exit Do
        Else
            ' 取得姓名(displayName)、郵箱地址(mail)信息
            ' physicalDeliveryOfficeName,Department,Title,CN,givenName,sn,samAccountName,DisplayName,Mail
            ' cn,givenName,sn,samAccountName,
            ' name,samAccountName, userPrincipalName, distinguishedName
            sPageSize = 50
            sThisPage = 1
            sColumnName = "physicalDeliveryOfficeName,department,title,samAccountName,DisplayName,Mail"
            arrTable = GetADInfo("hkadmin", "hk123456", "hkHeXie.com", sColumnName, sQuery, CInt(sPageSize), CInt(sThisPage))
            If IsArray(arrTable) Then
                sTable = TableFormat_Arr2String(arrTable, Split(sColumnName,","))
                sTable = "  +----------------------------------------------------------------------------+" & vbCrLf & sTable & vbCrLf
                sTable = sTable & "  +----------------------------------------------------------------------------+" & vbCrLf
                WScript.Echo sTable
                EchoLog sTable
            End If
         End If
    Loop
End Sub



' 使用域用户来查找其他域用户信息
' 示例：GetADInfo("hkadmin", "hk123456", "dc1.demo.com", "samAccountName,Name,DisplayName,Mail", "samAccountName='*He*'")
' 参数1=域用户名，参数2=域用户密码，参数3=网域名，参数4=查询的字段，参数5=查询条件
Function GetADInfo(ByVal sADUserName, ByVal sADPassword, ByVal sDC, ByVal sColumnName, ByVal sConditional, ByVal sPageSize, ByVal sThisPage)
    On Error Resume Next
    Const ADS_SCOPE_SUBTREE = 2
    Dim objConnection, objCommand, strSQL, sInfo
    
    ' 創建 ADODB 連接查詢
    Set objConnection = CreateObject("ADODB.Connection")
    Set objCommand =   CreateObject("ADODB.Command")
    objConnection.Provider = "ADsDSOObject"
    ' 使用其他域用户验证-开始
    objConnection.Properties("User ID") = sADUserName
    objConnection.Properties("Password") = sADPassword
    objConnection.Properties("Encrypt Password") = TRUE
    objConnection.Properties("ADSI Flag") = 1
    ' 使用其他域用户验证-结束
    objConnection.Open "Active Directory Provider"
    ' 查询信息限制（分页、排序）
    Set objCommand.ActiveConnection = objConnection
    objCommand.Properties("Page Size") = CInt(sPageSize)
    objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE 
    objCommand.Properties("Sort On") = "Name"
    
    ' 执行 SQL 搜索
    strSQL = " SELECT " & sColumnName & _
            " FROM 'LDAP://" & sDC & "' " & _
            " WHERE objectCategory='user' AND (" & sConditional & ")"
    objCommand.CommandText = Trim(strSQL)
    WScript.Echo "SQL: " & vbCrLf & strSQL & vbCrLf
    
    ' 在返回的搜索結果中提取
    Dim objRecordSet, rsCount
    Set objRecordSet = objCommand.Execute
    objRecordSet.MoveFirst
    rsCount = objRecordSet.RecordCount
    If Not rsCount = 0 Then
        If Not objRecordSet.Eof Then
            objRecordSet.PageSize = CInt(sPageSize)
            sPageCount = objRecordSet.PageCount
            If sThisPage = "" Or sThisPage =< 1 Then sThisPage = 1
            If sThisPage > sPageCount Then  sThisPage = sPageCount 
            objRecordSet.AbsolutePage = CInt(sThisPage)
            sLastPageSize = objRecordSet.RecordCount - (objRecordSet.PageCount - 1) * CInt(sPageSize)
            ' 当前页面的记录数
            If CInt(sPageCount) = CInt(sThisPage) Then
                sThisPageRecordCount = sLastPageSize
            Else
                sThisPageRecordCount = CInt(sPageSize)
            End If
            WScript.Echo "页数：  " & "  第 " & sThisPage & " 页 / 共 " & sPageCount & " 页"
            WScript.Echo "记录：  " & "显示 " & sThisPageRecordCount & " 条 / 共 " & rsCount & " 条"
        End If
        ' 要搜索的字段(列)
        Dim arrColumnName, arrColumnValue, arrRS(), x, y
        arrColumnName = Split(sColumnName, ",")
        ' 定义二维数组记录
        ReDim Preserve arrRS(sThisPageRecordCount -1, Ubound(arrColumnName))
        'Do Until objRecordSet.EOF
        ' 遍历记录数(行)
        For x = 0 To sThisPageRecordCount -1
            ' If objRecordSet.EOF Then Exit For
            ' 遍历记录条目(列)
            For y = 0 To UBound(arrColumnName)
                'sTmp = objRecordSet(y)  '
                sTmp = objRecordSet.Fields( Trim(arrColumnName(y)) ).Value
                If IsNull(sTmp) Then
                    arrRS(x,y) = ""
                ElseIf IsArray(sTmp) Then
                    arrRS(x,y) = Join(sTmp,"|")
                Else
                    arrRS(x,y) = sTmp
                End If
            Next
            objRecordSet.MoveNext
        Next
        GetADInfo = arrRS
    Else
        Exit Function
    End If
End Function

' 将二维数组输出成字符串
' arrTable 二维数组表，arrColumnName 一维数组列名
Function TableFormat_Arr2String(ByVal arrTable, ByVal arrColumnName)
    arr2string = ""
    If IsArray(arrTable) Then
        ' 添加列到首行
        Dim arrTableText()
        ReDim Preserve arrTableText(UBound(arrTable, 1) +1, Ubound(arrTable,2))
        For i = 0 To UBound(arrTable, 2)
            arrTableText(0, i) = arrColumnName(i)
        Next
        ' 重新定义二维数组
        Dim x, y
        For x = 0 To UBound(arrTable, 1)
            For y = 0 To UBound(arrTable, 2)
                arrTableText(x +1, y) = arrTable(x, y)
            Next
        Next
        ' 等列宽，不足补充空格
        Dim sTable, sTableLine, arrLength()
        For y = 0 To UBound(arrTableText, 2)
            ReDim Preserve arrLength(y)
            For x = 0 To UBound(arrTableText, 1)
                If arrLength(y) = "" Then arrLength(y) = 0
                If arrLength(y) < strLength(arrTableText(x, y)) Then
                    arrLength(y) = strLength(arrTableText(x, y))
                End If
            Next
        Next
        For x = 0 To UBound(arrTableText, 1)
            sTableLine = ""
            For y = 0 To UBound(arrTableText, 2)
                sTableLine = sTableLine & arrTableText(x, y) & Space(arrLength(y) - strLength(arrTableText(x, y))) & ","
            Next
            sTableLine = Left(sTableLine, Len(sTableLine)-Len(","))
            If x = 0 Then
                sNo = " "
            Else
                sNo = x
            End If
            sNo = Space(Len(UBound(arrTableText, 1)+1) - Len(sNo)) & sNo
            sTableLine = sNo & "| " & sTableLine
            sTable = sTable & sTableLine & vbCrLf
        Next
        sTable = Left(sTable, Len(sTable)-Len(vbCrLf))
        TableFormat_Arr2String = sTable
    End If
End Function
Function strLength(ByVal str)
    On Error Resume Next
    Dim WINNT_CHINESE
    WINNT_CHINESE = (Len("论坛") = 2)
    If WINNT_CHINESE  Then
        Dim l,t,c
        Dim i
        l = Len(str)
        t = l
        For i = 1  To  l
            c = Asc(Mid(str,i,1))
            If  c < 0  Then  c = c + 65536
            If  c > 255  Then
                t = t + 1
            End If
        Next
        strLength = t
    Else
        strLength = Len(str)
    End If
    If Err.Number <> 0 Then Err.Clear
End Function

Function CmdMode(ByVal title,ByVal color)   '强制以命令行模式运行
    If LCase(Right(WScript.FullName,11))="wscript.exe" Then
        With CreateObject("Wscript.Shell")
            .Run "cmd /c mode con: cols=200&title "&title&"&color "&color&"&Cscript //Nologo """ & WScript.ScriptFullName & """"
            '.Run "taskkill /f /im cmd.exe",0
        End With
        WScript.Quit
    End If
End Function


Function EchoLog(str)
	On Error Resume  Next
	str = str & vbCrLf
    'sFileDir = Left(sFilePath, InStrRev(sFilePath, "\")-1)
    file = WScript.ScriptFullName & ".log"
	Dim fso, wtxt
	Const ForAppending = 8		'ForReading = 1 (只读不写), ForWriting = 2 (只写不读), ForAppending = 8 (在文件末尾写)
	Const Create = True			'Boolean 值，filename 不存在时是否创建新文件。允许创建为 True，否则为 False。默认值为 False。
	Const TristateTrue = -1		'TristateUseDefault = -2 (SystemDefault), TristateTrue = -1 (Unicode), TristateFalse = 0 (ASCII)
	Set fso = CreateObject("Scripting.filesystemobject")
	set wtxt = fso.OpenTextFile(file, ForAppending, Create, TristateTrue)
	wtxt.Write str      :     wtxt.Close()
	set fso = Nothing      :     set wtxt = Nothing     :     WriteLog = True
End Function
复制代码

ShadowFiend

楼主给力啊