Active Directoryのユーザ管理 (1)

このトピックはExcelのVBAを利用してActive Directoryのユーザ情報を管理するやり方についての記録です。

Excel VBAの参照設定

Active DS Type Library
Microsoft Scription Runtime
Microsoft WMI cripting V1.2 Library

上記を追加する

Active Directoryユーザ管理のためのモジュール

mdlADSI

後のCADSIを使うための構造体TADUserを定義している

Type TADUser
    UserID As String
    FirstName As String
    LastName As String
    Password As String
    DisplayName As String
    UserPrincipalName As String
    Description As String
    ScriptPath As String
    PasswordMustChange As Boolean
    Mail As String
End Type 

CADSI.bas

ADSIでユーザ管理を行うためのクラス

Option Explicit
 
Const LDAP = "LDAP:"
Const USER_NOT_FOUND = -2147016656
 
Private m_ServerBaseDN As String
Private m_ServerAddress As String
Private m_AdminName As String
Private m_AdminPass As String
 
Private Function GetContainer(APath As String) As IADsContainer
    Dim objDSO As IADsOpenDSObject
 
    Set objDSO = GetObject("LDAP:")
    Set GetContainer = objDSO.OpenDSObject( _
        APath, m_AdminName, m_AdminPass, ADS_USE_ENCRYPTION And ADS_SECURE_AUTHENTICATION)
End Function
 
Private Function GetADUser(APath As String) As IADsUser
    Dim objDSO As IADsOpenDSObject
 
    Set objDSO = GetObject("LDAP:")
    Set GetADUser = objDSO.OpenDSObject( _
        APath, m_AdminName, m_AdminPass, ADS_USE_ENCRYPTION And ADS_SECURE_AUTHENTICATION)
End Function
 
Private Function GetADGroup(APath As String) As IADsGroup
    Dim objDSO As IADsOpenDSObject
 
    Set objDSO = GetObject("LDAP:")
    Set GetADGroup = objDSO.OpenDSObject( _
        APath, m_AdminName, m_AdminPass, ADS_USE_ENCRYPTION And ADS_SECURE_AUTHENTICATION)
End Function
 
Private Function GetLDAPPath(AObj As String) As String
    Dim result As String
 
    result = LDAP & "//" & m_ServerAddress & "/"
    If Len(AObj) > 0 Then
        result = result & AObj & ","
    End If
    result = result & m_ServerBaseDN
    GetLDAPPath = result
End Function
 
Private Sub SetUserProperty(AUser As IADsUser, AProperty As String, AValue As String, _
    Optional isNew As Boolean = False)
    If Len(AValue) = 0 Then
        If Not isNew Then
            AUser.PutEx ADS_PROPERTY_CLEAR, AProperty, Null
        End If
    Else
        AUser.Put AProperty, AValue
    End If
End Sub
 
Public Sub OpenDomain(ServerAddress As String, ServerBaseDN As String, _
    AdminName As String, ADMINPASS As String)
    m_ServerBaseDN = ServerBaseDN
    m_ServerAddress = ServerAddress
    m_AdminName = AdminName
    m_AdminPass = ADMINPASS
End Sub
 
Public Function QueryUser(AUserName As String, AContainerName As String) As Boolean
    Dim User As IADsUser
 
    On Error GoTo ERROR_QUERYUSER
    Set User = GetADUser(GetLDAPPath("cn=" & AUserName & "," & AContainerName))
    QueryUser = True
Exit Function
ERROR_QUERYUSER:
    QueryUser = False
End Function
 
 
Public Function GetUser(AUserName As String, AContainerName As String) As TADUser
    Dim objUser As IADsUser
    Dim sPath As String
 
    sPath = GetLDAPPath("cn=" & AUserName & "," & AContainerName)
    Set objUser = GetADUser(sPath)
    On Error Resume Next
    GetUser.UserID = objUser.Get("cn")
    GetUser.LastName = objUser.Get("sn")
    GetUser.FirstName = objUser.Get("givenName")
    GetUser.DisplayName = objUser.Get("displayName")
    GetUser.Description = objUser.Get("description")
    GetUser.PasswordMustChange = objUser.Get("pwdLastSet") = 0
    GetUser.ScriptPath = objUser.Get("scriptPath")
    GetUser.UserPrincipalName = objUser.Get("userPrincipalName")
    GetUser.Mail = objUser.Get("mail")
    Err.Clear
End Function
 
Public Sub ChangePassword(AUserName As String, AContainerName As String, _
    ANewPassword As String)
    Dim objUser As IADsUser
    Dim sPath As String
 
    sPath = GetLDAPPath("cn=" & AUserName & "," & AContainerName)
    Set objUser = GetADUser(sPath)
    objUser.SetPassword ANewPassword
    objUser.SetInfo
End Sub
 
Public Sub ChangePassword2(AUserName As String, ANewPassword As String)
    Dim objUser As IADsUser
    Dim sPath As String
    Dim objDSO As IADsOpenDSObject
 
    sPath = "WinNT://" & m_ServerAddress & "/" & AUserName & ",User"
    Set objDSO = GetObject("WinNT:")
    Set objUser = objDSO.OpenDSObject( _
        sPath, m_AdminName, m_AdminPass, ADS_USE_ENCRYPTION And ADS_SECURE_AUTHENTICATION)
    objUser.SetPassword ANewPassword
    objUser.SetInfo
End Sub
 
Public Sub SetUserEnable(AUserID As String, AContainerName As String, AEnable As Boolean)
    'IDやパスワード以外のプロパティをセットする
    Dim objUser As IADsUser
    Dim sPath As String
 
    sPath = GetLDAPPath("cn=" & AUserID & "," & AContainerName)
    Set objUser = GetADUser(sPath)
    objUser.AccountDisabled = Not AEnable
    objUser.SetInfo
End Sub
 
Public Sub UpdateUser(AUser As TADUser, AContainerName As String)
    'IDやパスワード以外のプロパティをセットする
    Dim objUser As IADsUser
    Dim sPath As String
 
    sPath = GetLDAPPath("cn=" & AUser.UserID & "," & AContainerName)
    Set objUser = GetADUser(sPath)
    SetUserProperty objUser, "sn", AUser.FirstName
    SetUserProperty objUser, "givenName", AUser.LastName
    SetUserProperty objUser, "displayName", AUser.DisplayName
    SetUserProperty objUser, "description", AUser.Description
    SetUserProperty objUser, "scriptPath", AUser.ScriptPath
    SetUserProperty objUser, "mail", AUser.Mail
    If AUser.PasswordMustChange Then
        objUser.Put "pwdLastSet", 0
    Else
        objUser.Put "pwdLastSet", -1
    End If
    objUser.SetInfo
End Sub
 
Public Sub SetHomeFolder(AUserID As String, AContainerName As String, _
    ADrive As String, AHomePath As String)
    'IDやパスワード以外のプロパティをセットする
    Dim objUser As IADsUser
    Dim sPath As String
 
    sPath = GetLDAPPath("cn=" & AUserID & "," & AContainerName)
    Set objUser = GetADUser(sPath)
    SetUserProperty objUser, "homeDrive", ADrive
    SetUserProperty objUser, "homeDirectory", AHomePath
    objUser.SetInfo
End Sub
 
Public Sub AddUser(AUser As TADUser, AContainerName As String)
    Dim objCont As IADsContainer
    Dim objUser As IADsUser
 
    Dim sPath As String
 
    sPath = GetLDAPPath(AContainerName)
    Set objCont = GetContainer(sPath)
    Set objUser = objCont.Create("User", "cn=" & AUser.UserID)
    SetUserProperty objUser, "sAMAccountName", AUser.UserID, True
    SetUserProperty objUser, "sn", AUser.LastName, True
    SetUserProperty objUser, "givenName", AUser.FirstName, True
    SetUserProperty objUser, "displayName", AUser.DisplayName, True
    SetUserProperty objUser, "description", AUser.Description, True
    SetUserProperty objUser, "scriptPath", AUser.ScriptPath, True
    SetUserProperty objUser, "userPrincipalName", AUser.UserPrincipalName, True
    SetUserProperty objUser, "mail", AUser.Mail, True
    objUser.SetInfo
    objUser.ChangePassword "", AUser.Password
    objUser.AccountDisabled = False
    objUser.Put "userAccountControl", ADS_UF_NORMAL_ACCOUNT Or ADS_UF_DONT_EXPIRE_PASSWD
    objUser.SetInfo
    If AUser.PasswordMustChange Then
        objUser.Put "pwdLastSet", 0
    Else
        objUser.Put "pwdLastSet", -1
    End If
End Sub
 
Public Sub DeleteUser(AUserName As String, AContainerName As String)
    Dim objCont As IADsContainer
    Dim objUser As IADsUser
    Dim sPath As String
 
    sPath = GetLDAPPath(AContainerName)
    Set objCont = GetContainer(sPath)
    objCont.Delete "User", "cn=" & AUserName
End Sub
 
Public Sub AddToGroup(AUserPath As String, AUserName As String, AGroupPath As String, _
    AGroupName As String)
    Dim objGroup As IADsGroup
    Dim objUser As IADsUser
 
    Set objGroup = GetADGroup(GetLDAPPath("cn=" & AGroupName & "," & AGroupPath))
    Set objUser = GetADUser(GetLDAPPath("cn=" & AUserName & "," & AUserPath))
    objGroup.Add objUser.ADsPath
End Sub
 
Function QueryMember(AUserName As String, AGroupPath As String, AGroupName As String)
    Dim objGroup As IADsGroup
    Dim objUser As IADsUser
    Dim result As Boolean
 
    Set objGroup = GetADGroup(GetLDAPPath("cn=" & AGroupName & "," & AGroupPath))
    result = False
    For Each objUser In objGroup.Members
        If objUser.Get("cn") = AUserName Then
            result = True
            Exit For
        End If
    Next
    QueryMember = result
End Function
 
Public Property Get ServerBaseDN() As String
    ServerBaseDN = m_ServerBaseDN
End Property
 
Public Property Let ServerBaseDN(ByVal ANewValue As String)
    m_ServerBaseDN = ANewValue
End Property
 
Public Property Get ServerAddress() As String
    ServerBaseDN = m_ServerBaseDN
End Property
 
Public Property Let ServerAddress(ByVal ANewValue As String)
    m_ServerBaseDN = ANewValue
End Property

次回からこのCADSIクラスを使用してADのユーザ管理をするコードを書いてゆく。