批量增加User的VBScript

最新推荐文章于 2018-12-13 16:53:59 发布

yanbeifei

最新推荐文章于 2018-12-13 16:53:59 发布

阅读量578

点赞数

文章标签： user vbscript microsoft exchange authentication hex

本文链接：https://blog.csdn.net/yanbeifei/article/details/1667502

版权

CONST C_DCDOMAIN        = "LDAP://192.168.1.2"
CONST C_LOGIN_USER        = "administrator"
CONST C_LOGIN_PWD         = "123456"

CONST ADS_SECURE_AUTHENTICATION = 1

Const ADS_PROPERTY_CLEAR     = 1
Const ADS_PROPERTY_UPDATE     = 2
Const ADS_PROPERTY_APPEND     = 3
Const ADS_PROPERTY_DELETE     = 4

CONST C_USER_TYEP        = "user"
CONST C_DEPT_TYEP        = "msExchDepartment"


'Main関数を実行する。
call sMain()

'=====【メイン関数】=====
sub sMain()
    Dim strADObjectID
    Dim strADObjectType
    Dim strADContainerPath
    Dim strProperty
    Dim strValueApp
    Dim strValueUPd
    Dim strValueDel

    'エラーをフックする。
    On Error Resume Next

    '----=======CreateObject Test========----
    strADObjectID = "CN=TestUser_"
    strADContainerPath = "CN=Users,DC=OM,DC=local"
    strADObjectType = C_USER_TYEP

    'strADObjectID = "CN=vb4"
    'strADContainerPath = "CN=All Departments,CN=Address Lists Container,CN=OM,CN=Microsoft Exchange,CN=Services,CN=Configuration,DC=OM,DC=local"
    'strADObjectType = C_DEPT_TYEP

    call CreateObject(strADObjectID,strADContainerPath,strADObjectType)
    '----=======CreateObject Test OK!!!========----

    '----=======MutilValued Property Test========----
    strADObjectID = "CN=testOU_99"
    strADContainerPath = "CN=All Departments,CN=Address Lists Container,CN=OM,CN=Microsoft Exchange,CN=Services,CN=Configuration,DC=OM,DC=local"
    strProperty = "msExchHABChildDepartmentsLink"

    'strValueUPd = Array("CN=vb1,CN=All Departments,CN=Address Lists Container,CN=OM,CN=Microsoft Exchange,CN=Services,CN=Configuration,DC=OM,DC=local", _
    '    "CN=vb3,CN=All Departments,CN=Address Lists Container,CN=OM,CN=Microsoft Exchange,CN=Services,CN=Configuration,DC=OM,DC=local")
    'strValueApp = Array("CN=vb2,CN=All Departments,CN=Address Lists Container,CN=OM,CN=Microsoft Exchange,CN=Services,CN=Configuration,DC=OM,DC=local", _
    '    "CN=vb4,CN=All Departments,CN=Address Lists Container,CN=OM,CN=Microsoft Exchange,CN=Services,CN=Configuration,DC=OM,DC=local")
    'strValueDel = Array("CN=vb3,CN=All Departments,CN=Address Lists Container,CN=OM,CN=Microsoft Exchange,CN=Services,CN=Configuration,DC=OM,DC=local", _
    '    "CN=vb4,CN=All Departments,CN=Address Lists Container,CN=OM,CN=Microsoft Exchange,CN=Services,CN=Configuration,DC=OM,DC=local")

    'strValueUPd = Array("CN=vb1,CN=All Departments,CN=Address Lists Container,CN=OM,CN=Microsoft Exchange,CN=Services,CN=Configuration,DC=OM,DC=local;CN=vb3,CN=All Departments,CN=Address Lists Container,CN=OM,CN=Microsoft Exchange,CN=Services,CN=Configuration,DC=OM,DC=local")
    '----NG

    'call ModifyObject(strADObjectID,strADContainerPath,strProperty,vbNullString,ADS_PROPERTY_CLEAR)
    'call ModifyObject(strADObjectID,strADContainerPath,strProperty,strValueUpd,ADS_PROPERTY_UPDATE)
    'call ModifyObject(strADObjectID,strADContainerPath,strProperty,strValueApp,ADS_PROPERTY_APPEND)
    'call ModifyObject(strADObjectID,strADContainerPath,strProperty,strValueDel,ADS_PROPERTY_DELETE)
    '----=======MutilValued Property Test OK!!! ========----

    '----=======SingleValued Property Test========----
    'strADObjectID = "CN=アウトルック　テスト1"
    'strADContainerPath = "CN=Users,DC=OM,DC=local"
    'strProperty = "displayName"

    'strValueUPd = Array("test name")
    'strValueApp = Array("Will case error because isSingleValued")
    'strValueDel = Array("test name")

    'call ModifyObject(strADObjectID,strADContainerPath,strProperty,vbNullString,ADS_PROPERTY_CLEAR)
    'call ModifyObject(strADObjectID,strADContainerPath,strProperty,strValueUpd,ADS_PROPERTY_UPDATE)
    'call ModifyObject(strADObjectID,strADContainerPath,strProperty,strValueApp,ADS_PROPERTY_APPEND)
    'call ModifyObject(strADObjectID,strADContainerPath,strProperty,strValueDel,ADS_PROPERTY_DELETE)
    '----=======SingleValued Property Test OK!!!========----

End Sub

'=====【オブジェクトを作成処理関数】=====
Sub CreateObject(strObjectID,strContainerPath,strObjectType)
    Dim strObjectIDtmp

    'エラーをフックする。
    On Error Resume Next

    set objRoot = Getobject("LDAP:")
    If (Err.Number<>0) Then
        Wscript.echo "GetObject Error 0x" & hex(Err.Number) & ": " & err.description
        wscript.quit
    End If

    Set objDomain =objRoot.OpenDSObject(C_DCDOMAIN & "/" & strContainerPath, C_LOGIN_USER, C_LOGIN_PWD, ADS_SECURE_AUTHENTICATION)
    If (Err.Number<>0) Then
        Wscript.echo "OpenDSObject Error 0x" & hex(Err.Number) & ": " & err.description
        wscript.quit
    End If

    For i = 2 to 1023
    For j = 1 to 10
    strObjectIDtmp = strObjectID & i & "_" & j
        Set objADObject = objDomain.Create(strObjectType, strObjectIDtmp)
        If (Err.Number<>0) Then
            Wscript.echo "Create ADObject Error 0x" & hex(Err.Number) & ": " & err.description
            wscript.quit
        End If

        'IF (strObjectType = C_DEPT_TYEP) Then
        '    objADObject.ou = strObjectID
        'End If
        'If (Err.Number<>0) Then
        '    Wscript.echo "Set OU Error 0x" & hex(Err.Number) & ": " & err.description
        '    wscript.quit
        'End If

        objADObject.displayName = strObjectIDtmp
        If (Err.Number<>0) Then
            Wscript.echo "Set displayName Error 0x" & hex(Err.Number) & ": " & err.description
            wscript.quit
        End If

        objADObject.ShowInDepartments = "CN=TestOU_"& i &",CN=All Departments,CN=Address Lists Container,CN=OM,CN=Microsoft Exchange,CN=Services,CN=Configuration,DC=OM,DC=local"
        If (Err.Number<>0) Then
            Wscript.echo "Set displayName Error 0x" & hex(Err.Number) & ": " & err.description
            wscript.quit
        End If

        objADObject.SetInfo
        If (Err.Number<>0) Then
            Wscript.echo "SetInfo Error 0x" & hex(Err.Number) & ": " & err.description
            wscript.quit
        End If
        Next
    Next
    wscript.echo "OK"
End Sub

'=====【属性変更処理関数】=====
Sub ModifyObject(strObjectID,strContainerPath,strProperty,strValue,numType)

    'エラーをフックする。
    On Error Resume Next

    set objRoot = Getobject("LDAP:")
    If (Err.Number<>0) Then
        Wscript.echo "GetObject Error 0x" & hex(Err.Number) & ": " & err.description
        wscript.quit
    End If

    Set objADObject =objRoot.OpenDSObject(C_DCDOMAIN & "/" & strObjectID & "," & strContainerPath, C_LOGIN_USER, C_LOGIN_PWD, ADS_SECURE_AUTHENTICATION)
    If (Err.Number<>0) Then
        Wscript.echo "OpenDSObject Error 0x" & hex(Err.Number) & ": " & err.description
        wscript.quit
    End If

    objADObject.PutEx numType, strProperty,strValue
    If (Err.Number<>0) Then
        Wscript.echo "Set Property Error 0x" & hex(Err.Number) & ": " & err.description
        wscript.quit
    End If

    objADObject.SetInfo
    If (Err.Number<>0) Then
        Wscript.echo "SetInfo Error 0x" & hex(Err.Number) & ": " & err.description
        wscript.quit
    End If

    wscript.echo "OK"
End Sub