ActiveDirectory登録用スクリプト

- 2月 08, 2013

先ほどのメイン処理にひき続いて、ActiveDirectory登録用のスクリプト
ホントは所属するグループもデータベースから引っこ抜いてきて処理させたかったんやけど
グループツリーが複雑すぎるんでユーザ追加のみ実装、相変わらずぶさいくなコードです。
メールサーバ登録部分は公開なし。ブラウザ立ち上げて某社さんのツールで登録するという
ブラウザ制御のやつなんで、ここでは載せられない・・・。

そういえば、Samba4.0出てきてActiveDirectory使えるようになってるらしい。
実用レベルだとするとActiveDirectoryとファイルサーバをLinuxで構築して
CALを削減するということもできそうと感じたりした。

ちょろっと修正したソース。汚いのには代わりはないが・・・

Function ActiveDirectoryAdd(val_Uname,val_UloginID,val_Upassword,val_Email,val_Place)
    Dim argRtn(5)        '引数チェック用  
    Dim strUserName        'ユーザ名
    Dim strLoginID        'WindowsログインID
    Dim strPassword        'Windowsパスワード
    Dim strEmailAdd        'Emailアドレス
    Dim strPlace        '事業所
    Dim dtStart
    Dim objConnection
    Dim objCommand
    Dim objRecordSet
    Dim objOU
    Dim objUser
    Dim nwErrChk
    Dim adServName
    Dim adDc
    Dim adDomain
    Dim userFrags
    adServName = "XXXX"
    adDc = "CN=users,dc=XXXX,dc=local"
    adDomain = "XXXX.local"
    Const UF_DONT_EXPIRE_PASSWORD = &H10000        'パスワード無期限

    '/* 引数エラーチェック
    argRtn(0)= argumentChecker(val_Uname)
    argRtn(1)= argumentChecker(val_UloginID)
    argRtn(2)= argumentChecker(val_Upassword)
    argRtn(3)= argumentChecker(val_Email)
    argRtn(4)= argumentChecker(val_Place)
  
    If argRtn(0) ="False" Or argRtn(1) ="False" Or argRtn(2)="False"  Or argRtn(3) ="False" Or argRtn(4) ="False" Then
        ActiveDirectoryAdd = "False"
        Logrtn = OutLogger("[Err],ユーザ名等が入力されていません。")
        If Logrtn = "False" Then
            WScript.Echo LErrMsg
        End If
        Exit Function
    Else
        strUserName = val_Uname
        strLoginID  = val_UloginID
        strPassword = val_Upassword
        strEmailAdd = val_Email
        strPlace = val_Place
      
        nwErrChk = ServerConnectChk(adServName)
      
        If nwErrChk = "False" Then
            Set objConnection = Nothing
            ActiveDirectoryAdd = "False"
            Logrtn = OutLogger("[Err],ActiveDirectory接続に失敗しました。")
            If Logrtn = "False" Then
                WScript.Echo LErrMsg
            End If
            Exit Function
        Else
            '*********  ①ActiveDirectoryユーザ検索
            dtStart = TimeValue(Now())
            Set objConnection = CreateObject("ADODB.Connection")
            objConnection.Open "Provider=ADsDSOObject;"
          
            Set objCommand = CreateObject("ADODB.Command")
            objCommand.ActiveConnection = objConnection
          
            objCommand.CommandText = _
            ";(&(objectCategory=User)" & _
            "(samAccountName=" & strLoginID & "));samAccountName;subtree"
           
            'ActiveDirectory接続不可チェック
            '** AD接続しユーザ追加を行う(ユーザが未登録時のみ)
            Set objRecordSet = objCommand.Execute
            If objRecordset.RecordCount = 0 Then
                'オブジェクト追加
                Set objOU = GetObject("LDAP://" & adDc )                 'OU登録
                Set objUser = objOU.Create("User", "cn=" & strUserName )        
                objUser.Put "sAMAccountName", strLoginID                'ログインアカウント名
                objUser.Put "userPrincipalName", strLoginID &"@" & adDomain        'ユーザログイン名
                objUser.Put "sn", strUserName                        '姓
                objUser.Put "displayName", strUserName                    '表示名
                objUser.Put "mail", strEmailAdd                        'メールアドレス
                objUser.Put "physicalDeliveryOfficeName", strPlace            '事業所
                objUser.SetInfo 
                objUser.GetInfo
                objUser.SetPassword strPassword                        'ドメインパスワード
                objUser.IsAccountLocked = False                        'アカウントロックしない
                objUser.AccountDisabled = False                        'アカウント無効にしない
                objUser.SetInfo 
                ' パスワードを無期限、パスワード変更不可
                objUser.GetInfo
                userFrags = objUser.Get("userAccountControl")
                userFrags = userFrags Or UF_DONT_EXPIRE_PASSWORD            'パスワードを無期限にする
                objUser.Put "userAccountControl", userFrags
                objUser.SetInfo
               
                ActiveDirectoryAdd = "True"
                objConnection.Close
                Exit Function
            Else
                ActiveDirectoryAdd = "False"
                Logrtn = OutLogger("[Err]," & "ユーザ:" & strLoginID & " は既に存在しています。ActiveDirectoryとACCESSデータベースの内容を再確認してください。")
                If Logrtn = "False" Then
                    WScript.Echo LErrMsg
                End If
                Exit Function
                objConnection.Close
            End If
           
        End If
       
    End If
   
End Function
'--------------------------------------------------------------------------------------------------
Function ADGroupAdd(val_UloginID,val_Group)
    Dim argRtn(2)        '引数チェック用   
    Dim strLoginID        'WindowsログインID
    Dim strGroup        '所属グループ
    Dim dtStart
    Dim objConnection
    Dim objOU
    Dim objUser        'ユーザ用
    Dim objGroup    'グループ用
    Dim nwErrChk
    Dim adServName
    Dim adDc
    Dim adDomain
    Dim userFrags
    Dim adGroup
    Dim adUseradd
    adServName = "XXXX"
    adDc = "CN=users,dc=XXXX,dc=local"
    adDomain = "XXXX.local"

    '/* 引数エラーチェック
    argRtn(0)= argumentChecker(val_UloginID)
    argRtn(1)= argumentChecker(val_Group)
   
    If argRtn(0) ="False" Or argRtn(1) ="False" Then
        ADGroupAdd = "False"
        Logrtn = OutLogger("[Err],ユーザ名等が入力されていません。")
        If Logrtn = "False" Then
            WScript.Echo LErrMsg
        End If
        Exit Function
    Else
        strLoginID  = val_UloginID
        strGroup = val_Group
       
        nwErrChk = ServerConnectChk(adServName)
       
        If nwErrChk = "False" Then
            Set objConnection = Nothing
            ADGroupAdd = "False"
            Logrtn = OutLogger("[Err],ActiveDirectory接続に失敗しました。")
            If Logrtn = "False" Then
                WScript.Echo LErrMsg
            End If
            Exit Function
        Else
            '**　AD登録済みユーザに所属部署を設定する。 
            Set objConnection = CreateObject("ADODB.Connection")
            objConnection.Open "Provider=ADsDSOObject;"
           
            adGroup = "CN=" & strGroup & "," & adDc                            '追加対象グループ
            adUseradd ="CN=" & strLoginID & "," & adDc                     '追加対象ユーザ
           
            Set objGroup = GetObject("LDAP://" & adGroup )            
            Set objUser = GetObject("LDAP://" & adUseradd )                
           
            If Not objGroup.IsMember(objUser.ADsPath) Then 
                objGroup.Add(objUser.ADsPath) 
            Else 
                ADGroupAdd = "False"
                Logrtn = OutLogger("[Err],このグループには既に登録済です。")
                If Logrtn = "False" Then
                    WScript.Echo LErrMsg
                End If
                objConnection.Close
                Exit Function
            End If 
           
            ADGroupAdd = "True"
            objConnection.Close
            Exit Function
        End If
    End If
End Function
'--------------------------------------------------------------------------------------------------
Function argumentChecker(val_strTarget)
    Dim strTarget
    strTarget = val_strTarget
    argumentChecker = "True"   
   
    '""をチェック
    If    strTarget = "" Then
        argumentChecker="False"
    End If
    'Nullチェック
    If IsNull(strTarget) = True Then
        argumentChecker="False"
    End If
    '空白チェック
    If IsEmpty(strTarget) = True Then
        argumentChecker="False"
    End If
   
End Function
'--------------------------------------------------------------------------------------------------
Function ServerConnectChk(val_ServName)
    Dim objWMIService
    Dim colItems
    Dim objItem
   
    Dim strComputer
    strComputer = val_ServName
   
    Set objWMIService = GetObject("winmgmts:\\.\root\cimv2")
    Set colItems = objWMIService.ExecQuery _
    ("Select * from Win32_PingStatus " & _
    "Where Address = '" & strComputer & "'")
   
    For Each objItem In colItems
        If objItem.StatusCode = 0 Then
            ServerConnectChk="True"
        Else
            ServerConnectChk="False"
            Logrtn = OutLogger("[Err],サーバへのネットワーク接続ができていない可能性があります。")
            If Logrtn = "False" Then
                WScript.Echo LErrMsg
            End If
        End If
    Next
   
    Set objWMIService = Nothing
    Set colItems = Nothing
    Exit Function
End Function
'--------------------------------------------------------------------------------------------------
Function OutLogger(val_ErrMsg)
    Dim LogMsg
    Dim objFso          ' FileSystemObject
    Dim objText         ' テキストファイルオブジェクト
   
    Const LOG_FILE_NAME = "PGNAME"
   
    If val_ErrMsg ="" Then
        OutLogger = "False"
        LogMsg = "処理内容:," & CStr(Now()) & ",　　　[Err],エラーメッセージ空白"
    Else
        OutLogger = "True"
        LogMsg = "処理内容:," & CStr(Now()) & ",　　　" & val_ErrMsg
    End If
   
    Set objFso = WScript.CreateObject("Scripting.FileSystemObject")    ' 追記モードで開く(存在しない場合は新規作成)
    Set objText = objFso.OpenTextFile(LOG_FILE_NAME & ".log", 8, True)
    objText.Write LogMsg & vbCrLf
    objText.Close
    Set objText = Nothing
    Set objFso = Nothing
    Exit Function
End Function
'--------------------------------------------------------------------------------------------------

このブログを検索

アラフィフおやじログ

ActiveDirectory登録用スクリプト

コメント

このブログの人気の投稿

GASでGoogleDriveのサブフォルダとファイル一覧を出力する

証券外務員1種勉強(計算式暗記用メモ)

マクロ経済学(IS-LM分析)