批处理之家 - Powered by Discuz! Board

'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