查找域中用户并重置密码

On Error Resume Next
Const ADS_SCOPE_SUBTREE = 2
Set objConnection = CreateObject("ADODB.Connection")
Set objCommand = CreateObject("ADODB.Command")
objConnection.Provider = "ADsDSOObject"
objConnection.Open "Active Directory Provider"
Set objCommand.ActiveConnection = objConnection
objCommand.Properties("Page Size") = 1000
objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE
'***
Const ForReading = 1
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Set cnvt=CreateObject("ADs.ArrayConvert")
'*****
Set objTextFile = objFSO.OpenTextFile("D:\zn\cscript\20090310\reset_password.txt", ForReading)
Password="Password@1"
setAcount=0
'*****
Do Until objTextFile.AtEndOfStream
strNextLine = objTextFile.Readline
'--------------Start--------------
'If trim(strNextLine)<>"" Then
' arrUserInfo=Split(strNextLine,",")
'End If
'********
objCommand.CommandText = _
"SELECT Name,ADsPath FROM 'LDAP://dc=test,dc=com' WHERE objectCategory='user' " & _
"AND sAMAccountName='" & strNextLine & "'"
'Wscript.Echo objCommand.CommandText
Set objRecordSet = objCommand.Execute
objRecordSet.MoveFirst
Do Until objRecordSet.EOF
If objRecordSet.RecordCount>0 Then
ComDNPath= objRecordSet.Fields("ADsPath")
Wscript.Echo objRecordSet.Fields("Name")
'Set objUser = GetObject(ComDNPath)
'objUser.SetPassword Password
'objUser.SetInfo
setAcount=setAcount+1
End If
objRecordSet.MoveNext
Loop
'********
'--------------End----------------
Loop
Wscript.Echo "Update Account Users:" & setAcount
objTextFile.Close
set objTextFile = Nothing

导出加入域的计算机信息脚本(计算机名、最后登录时间)

CONST ForWriting = 2
CONST ForAppending = 8
CONST CONST_ERROR = 0
CONST CONST_WSCRIPT = 1
CONST CONST_CSCRIPT = 2
CONST CONST_SHOW_USAGE = 3
CONST CONST_LIST = 4
Const ADS_SCOPE_SUBTREE = 2
Const ADS_UF_DONT_EXPIRE_PASSWD = 65536
Const ADS_UF_PASSWORD_EXPIRED = 8388608
Const E_ADS_PROPERTY_NOT_FOUND = &h8000500D
Const ONE_HUNDRED_NANOSECOND = .000000100
Const SECONDS_IN_DAY = 86400

Dim lastLogin
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
Set objShell = Nothing
'''''''''''''''''''''''''
Outputfile= strDCName1 & "计算机列表"
Set FSO = CreateObject("Scripting.FileSystemObject")
Set fLog = fso.OpenTextFile(Outputfile & ".csv", ForWriting,TRUE)
fLog.WriteLine "机器名,最后登陆时间"
Set rootDSE = GetObject("LDAP://rootDSE")
BaseDN = rootDSE.Get("defaultNamingContext")
DC= replace(BaseDN,"DC=",",")
DC= replace(DC,",,",".")
DC=right(DC,len(DC)-1)
TARGET_OU= "Machines"
inputOU=inputbox("请输入所需查询计算机的OU,该OU必须位于Machines的下一层,不输入为查询所有计算机","输入信息")
if inputOU<>"" then
TARGET_OU= inputOU & ",OU=" & TARGET_OU
end if
inputdate=0
Set objConnection = CreateObject("ADODB.Connection")
objConnection.Provider = "ADsDSOObject"
objConnection.Open "Active Directory Provider"
Set objCommand = CreateObject("ADODB.Command")
Set objCommand.ActiveConnection = objConnection
Set objCommand1 = CreateObject("ADODB.Command")
Set objCommand1.ActiveConnection = objConnection
'on error resume next
objCommand.CommandText = ";(&(objectclass=organizationalUnit));cn,ADsPath;subtree"
'msgbox ";(&(objectclass=organizationalUnit));cn,ADsPath;subtree"
Set objRecordSet = objCommand.Execute
if err.number<>0 then
msgbox "无法找到:" & TARGET_OU
end if
wscript.echo "Begin:"
If objRecordSet.RecordCount>0 Then
objRecordSet.MoveFirst
i = 0
Do Until objRecordSet.EOF
Set OU = GetObject(objRecordSet.Fields("ADsPath").Value)
OUdistinguishedName=OU.distinguishedName
Set adoCommand = CreateObject("ADODB.Command")
Set adoConnection = CreateObject("ADODB.Connection")
adoConnection.Provider = "ADsDSOObject"
adoConnection.Open "Active Directory Provider"
adoCommand.ActiveConnection = adoConnection
strBase = ""
' Filter on all user objects.
strFilter = "(&(objectcategory=Computer)(objectClass=user))"
' Comma delimited list of attribute values to retrieve.
strAttributes = "distinguishedName,ADsPath,lastLogonTimeStamp"
' Construct the LDAP syntax query.
strQuery = strBase & ";" & strFilter & ";" & strAttributes & ";subtree"
' Run the query.
adoCommand.CommandText = strQuery
adoCommand.Properties("Page Size") = 10000
adoCommand.Properties("Timeout") = 60
adoCommand.Properties("Cache Results") = False
Set adoRecordset = adoCommand.Execute
' Enumerate resulting recordset.
Do Until adoRecordset.EOF
On Error Resume Next
adspath=adoRecordset.Fields("adspath")
ShowMSG adspath
Set objMailbox = GetObject(adspath) lastName=objMailbox.sn
computername=objMailbox.Name
company=objMailbox.company
department=objMailbox.department
Set objDate = adoRecordset.Fields("lastLogonTimeStamp").Value
If (Err.Number <> 0) Then
On Error GoTo 0
dtmDate = #1/1/1601#
Else
On Error GoTo 0
lngHigh = objDate.HighPart
lngLow = objDate.LowPart
If (lngLow < 0) Then
lngHigh = lngHigh + 1
End If
If (lngHigh = 0) And (lngLow = 0 ) Then
dtmDate = #1/1/1601#
Else
dtmDate = #1/1/1601# + (((lngHigh * (2 ^ 32)) _
+ lngLow)/600000000 - lngBias)/1440
End If
End If
lastLogin=dtmDate computername=replace(computername,"CN=","")
fLog.WriteLine computername & "," & lastLogin
adoRecordset.MoveNext
Loop
i=i+1
objRecordSet.MoveNext
Loop
End If
wscript.echo "Count:" & i
Sub ShowMSG(strSubMSG)
Wscript.Echo Time & vbTab & strSubMSG
end sub

vbs修改注册表 添加IE浏览器信任站点

Windows xp系统可以通过以下脚本来添加域名地址到IE浏览器信任站点
On Error Resume Next
Const HKEY_CURRENT_USER = &H80000001
strUrl_base = "google.com"
strUrl = strUrl_base & "\www"
strComputer = "."
Set objReg = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}\\" & strComputer & _
"\root\default:StdRegProv")
strKeyPath = "Software\Microsoft\Windows\CurrentVersion\Internet Settings\" _
& "ZoneMap\Domains\" & strUrl_base
objReg.CreateKey HKEY_CURRENT_USER,strKeyPath
strKeyPath = "Software\Microsoft\Windows\CurrentVersion\Internet Settings\" _
& "ZoneMap\Domains\" & strUrl
objReg.CreateKey HKEY_CURRENT_USER,strKeyPath
strValueName = "http"
dwValue = 2
objReg.SetDWORDValue HKEY_CURRENT_USER,strKeyPath,strValueName,dwValue
Wscript.Echo "Added http://www.google.com to Trusted sites Zone successfully."
如果是Windows 2003操作系统则需要把注册表路径Domains修改为EscDomains即可。

'**************************************************
Windows xp系统可以通过以下脚本来添加IP地址到IE浏览器信任站点
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set WSHShell = CreateObject("WScript.Shell")
on Error resume next
WshShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Internet Settings\ZoneMap\Ranges\Range111\",""
WshShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Internet Settings\ZoneMap\Ranges\Range111\http","2","REG_DWORD"
WshShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Internet Settings\ZoneMap\Ranges\Range111\:Range","192.168.2.11"
Wscript.Echo "Added http://192.168.2.11 to Trusted sites Zone successfully."
如果是Windows 2003操作系统则需要把注册表路径Ranges修改为EscRanges即可。

使用vbs脚本通过SMTP服务批量发送邮件

'从数据库用户表中取出邮件信息循环发送
set cndb=CreateObject("ADODB.Connection")
cndb.open "Provider=SQLOLEDB.1;Password=[密码];Persist Security Info=True;User ID=[数据库用户名];Initial Catalog=test;Data Source=[数据库]"
on error resume next
sql="select * from [数据表]"
set rs=createobject("adodb.recordset")
rs.open sql,cndb,1,1
servername=""
do until rs.eof
Wscript.Echo trim(rs.Fields("mailbox"))
sendmail "发送人邮箱",trim(rs.Fields("mailbox")),"关于停止使用旧邮件系统的通知","",txt
rs.movenext
loop
msgbox "ok"
function sendmail(mailfrom,mailto,mailsubject,mailcc,mailtext)
ON ERROR RESUME NEXT
sendmail=0
Dim msg
Dim iConf
Dim Flds
set msg =CreateObject ("cdo.message")
set iconf =CreateObject ("cdo.configuration")
set Flds = iConf.Fields
ExpiredTime = 172800
' Set the configuration for Network Send
with flds
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
'可用的SMTP服务器[测试开通] telnet inner.chinaXXX.com 25
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "inner.chinaXXX.com"
.Item("cdoSMTPServerPort") = 25
.Item("cdoSMTPConnectionTimeout") = 30
.Item("cdoSMTPAccountName") = mailfrom
.Item("cdoSendUserReplyEmailAddress") = mailfrom
.Item("cdoSendEmailAddress") = mailfrom
.Update
end with
Set msg.Configuration = iConf
With msg
.From = mailfrom
.To = mailto
.CC = mailcc
.Subject = mailsubject
'.TextBody = mailtext
.CreateMHTMLBody "http://localhost/SendMail.htm", cdoSuppressNone
'添加附件
.AddAttachment "d:\zn\手册.doc"
'.BodyFormat = 0
.Send
End With
if err.number<>0 then
Wscript.Echo "False--" & trim(rs.Fields("mailbox"))
err.number=0
end if
set iConf = nothing
Set msg = Nothing
set flds = nothing
end function

AD某OU目录下用户信息操作vbscript脚本

'CONST ForReading = 1
CONST ForWriting = 2
CONST ForAppending = 8
CONST CONST_ERROR = 0
CONST CONST_WSCRIPT = 1
CONST CONST_CSCRIPT = 2
CONST CONST_SHOW_USAGE = 3
CONST CONST_LIST = 4
Const ADS_SCOPE_SUBTREE = 2
Const ADS_UF_DONT_EXPIRE_PASSWD = 65536
Const ADS_UF_PASSWORD_EXPIRED = 8388608
Const E_ADS_PROPERTY_NOT_FOUND = &h8000500D
Const ONE_HUNDRED_NANOSECOND = .000000100
Const SECONDS_IN_DAY = 86400

Dim lastLogin
'''''''''''''''''''''''''
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
Set objShell = Nothing

'''''''''''''''''''''''''
inputOU=inputbox("请输入查询的OU,该OU必须位于" & TARGET_OU & "的下一层,不输入为查询此OU下所有帐号","输入信息")

Outputfile= strDCName1 & "账号列表" & inputOU
Set FSO = CreateObject("Scripting.FileSystemObject")
Set fLog = fso.OpenTextFile(Outputfile & ".csv", ForWriting,TRUE)
fLog.WriteLine "帐号,姓名,工号,公司,部门,最后登陆时间,是否有邮箱,是否停用"

Set rootDSE = GetObject("LDAP://rootDSE")
BaseDN = rootDSE.Get("defaultNamingContext")
DC= replace(BaseDN,"DC=",",")
DC= replace(DC,",,",".")
DC=right(DC,len(DC)-1)

TARGET_OU = "Employee"

if inputOU<>"" then
TARGET_OU=inputOU & ",OU=" & TARGET_OU
end if


Set objConnection = CreateObject("ADODB.Connection")

objConnection.Provider = "ADsDSOObject"
objConnection.Open "Active Directory Provider"
Set objCommand = CreateObject("ADODB.Command")
Set objCommand.ActiveConnection = objConnection
Set objCommand1 = CreateObject("ADODB.Command")
Set objCommand1.ActiveConnection = objConnection
'on error resume next

objCommand.CommandText = ";(&(objectclass=organizationalUnit));cn,ADsPath;subtree"
Set objRecordSet = objCommand.Execute
if err.number<>0 then
msgbox "无法找到:" & TARGET_OU
end if
wscript.echo "Begin:"
If objRecordSet.RecordCount>0 Then
i = 0
Set OU = GetObject(objRecordSet.Fields("ADsPath").Value)
OUdistinguishedName=OU.distinguishedName
Wscript.Echo OUdistinguishedName
Set adoCommand = CreateObject("ADODB.Command")
Set adoConnection = CreateObject("ADODB.Connection")
adoConnection.Provider = "ADsDSOObject"
adoConnection.Open "Active Directory Provider"
adoCommand.ActiveConnection = adoConnection

strBase = ""
' Filter on all user objects.
strFilter = "(&(objectCategory=person)(objectClass=user))"
' Comma delimited list of attribute values to retrieve.
strAttributes = "distinguishedName,ADsPath,lastLogonTimeStamp" & ";subtree"
' Construct the LDAP syntax query.
strQuery = strBase & ";" & strFilter & ";" & strAttributes
' Run the query.
adoCommand.CommandText = strQuery
adoCommand.Properties("Page Size") = 10000
adoCommand.Properties("Timeout") = 60
adoCommand.Properties("Cache Results") = False
Set adoRecordset = adoCommand.Execute

' Enumerate resulting recordset.
adoRecordset.movefirst
Do Until adoRecordset.EOF
On Error Resume Next
adspath=adoRecordset.Fields("adspath")
ShowMSG adspath
Set objMailbox = GetObject(adspath)
lastName=objMailbox.sn
If(objMailbox.legacyExchangeDN="") Then
mailaddress="无邮箱"
Else
mailaddress=objMailbox.mail
End If
statusflag=objMailbox.AccountDisabled
firstName=objmailbox.givenname
mailNickname=objMailbox.samaccountname
company=objMailbox.company
department=objMailbox.department
Set objDate = adoRecordset.Fields("lastLogonTimeStamp").Value
If (Err.Number <> 0) Then
On Error GoTo 0
dtmDate = #1/1/1601#
Else
On Error GoTo 0
lngHigh = objDate.HighPart
lngLow = objDate.LowPart
If (lngLow < 0) Then
lngHigh = lngHigh + 1
End If
If (lngHigh = 0) And (lngLow = 0 ) Then
dtmDate = #1/1/1601#
Else
dtmDate = #1/1/1601# + (((lngHigh * (2 ^ 32)) _
+ lngLow)/600000000 - lngBias)/1440
End If
End If
lastLogin=dtmDate

fLog.WriteLine mailNickname & "," & lastName & "," & firstName & "," & company & "," & department & "," & lastLogin & "," & mailaddress & "," & statusflag

adoRecordset.MoveNext
i=i+1
Loop

End If

wscript.echo "总计输出账号为:" & i

Sub ShowMSG(strSubMSG)
Wscript.Echo Time & vbTab & strSubMSG
end sub

set adoRecordset=nothing
set adoCommand=nothing
adoConnection.close
set adoConnection=nothing

AD用户删除脚本

最近在客户那做一个AD相关的项目，要实现一个批量删除AD用户的需求，可以通过以下的AD脚本+txt文件实现批量功能：（vbs脚本如下）
Const ForReading = 1
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objTextFile = objFSO.OpenTextFile("D:\Test\Book.txt", ForReading)

Do Until objTextFile.AtEndOfStream
strNextLine = objTextFile.Readline
'--------------Start--------------
TARGET_OU = "JT" '删除帐号所在的OU
samAccountName=strNextLine '删除帐号的samAccountName


Set objConnection = CreateObject("ADODB.Connection")
Set objCommand = CreateObject("ADODB.Command")
objConnection.Provider = "ADsDSOObject"
objConnection.Open "Active Directory Provider"
Set objCommand.ActiveConnection = objConnection

Dim rootDSE
Set rootDSE = GetObject("LDAP://rootDSE")
BaseDN = rootDSE.Get("defaultNamingContext")

DC= replace(BaseDN,"DC=",",")
DC= replace(DC,",,",".")
DC=right(DC,len(DC)-1)

objCommand.CommandText = ";(&(objectcategory=person)(objectclass=user)(samAccountName="&samAccountName&"));cn,ADsPath,distinguishedName;subtree"
'MsgBox objCommand.CommandText
Set objRecordSet = objCommand.Execute
If objRecordSet.RecordCount>0 Then
cn=objRecordSet.Fields("cn") '查找要删除帐号的CN名.因为删除的时候要指定CN名，我不知道这里查出来的，带不带“cn“，如果不带，手工加一下
ComDNPath = objRecordSet.Fields("distinguishedName")'得到distinguishedName，并在如下的代码中重新组合成OU的LDAP
End If
'MsgBox ComDNPath
arrDirectoryLocation = Split(ComDNPath,",")
'MsgBox Ubound(arrDirectoryLocation)
For i = 1 to Ubound(arrDirectoryLocation)
If i = 1 Then
strComOU = arrDirectoryLocation(i)
Else
strComOU = strComOU & "," & arrDirectoryLocation(i)
End If
Next
Set objOU = GetObject("LDAP://" & strComOU)
If objRecordSet.RecordCount>0 Then
'MsgBox arrDirectoryLocation(0)
objOU.Delete "user", arrDirectoryLocation(0)
End If
'--------------End----------------
Loop

objTextFile.Close
set objTextFile = Nothing

另外附上两个参考vbs脚本库的地址：http://www.activexperts.com/activmonitor/windowsmanagement/adminscripts/usersgroups/users/
http://www.microsoft.com/china/technet/community/scriptcenter/scripts/ad/default.mspx
微软脚本中心：http://www.microsoft.com/technet/scriptcenter/scripts/default.mspx