ActiveDirectory登録用スクリプト

-
先ほどのメイン処理にひき続いて、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
'--------------------------------------------------------------------------------------------------

コメント

コメントを投稿

このブログの人気の投稿

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

-
 タイトルのまんまです。 以前、EXCELで似たようなこと をしていたのでGASではどうするのかなぁと思ってやってみました。まぁほとんど丸パクリです。とりあえず、また使うかもしれないので自分用にメモです。しかしGASでGoogleDriveのファイル一覧嘗め回そうとすると3分かかってしまう。数が多いと6分制限に引っかかるのでこれでは使えない。せいぜい100ファイルとか数が少ないところで使う分にはいいけどダイナミックな場合は何回かに分割してやらないと少し厳しいかもしれない。 ◆GAS //設定値取得 const SHEET_URL = SpreadsheetApp.getActiveSpreadsheet().getUrl(); const ss = SpreadsheetApp.openByUrl(SHEET_URL); const SETTING_SHEET = ss.getSheetByName('設定') const TARGET_FOLDER_ID = SETTING_SHEET.getRange('B2').getValue(); const SAVE_FOLDER_ID = SETTING_SHEET.getRange('B3').getValue(); const SAVE_FILE_NAME = SETTING_SHEET.getRange('B4').getValue(); const SAVE_SHEET_NAME = SETTING_SHEET.getRange('B5').getValue(); function writeSheet(values, labels, sheetUrl, sheetname, width) { /* スプレッドシートに書き出し */ try { if (values.length > 0) { // シートを追加する let spreadSheet = SpreadsheetApp.openByUrl(sheetUrl); let sheet = set_sheet(sheetUrl,sheetname); // 1行目だけヘッダ追加 let he...
続きを読む

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

-
イメージ
危うく3日坊主になりそうでした。とりあえず今日は 「IS-LM分析」 です。 テキストでは 簡便4象限法 とかいうのの説明が多いです。なのでさっぱり わけわからん状態ですが、それなりに頑張ってみます。 1: IS曲線 の導出 財市場の均衡を表す。Iは投資を表し、Sは貯蓄を表す。 ・IS曲線導出の材料 I→利子率の関数、S→所得の関数で「I=S」で財市場を表す。 ・ 投資関数 利子率の減少関数、I (投資関数)=I(r)　※rは利子率 ・政府活動の導入 裁量的な拡張的な財政政策はIS曲線をシフトさせる。 IS曲線の右シフト=政府支出の増大や減税等の有効需要を増加させる要因による 2: LM曲線 の導出 利子率の低下が国民所得の増大につながる因果関係を明らかにする目的 ・LM曲線導出の材料 貨幣需要(MD)=L、L=取引的動機+予備的動機(L1)+投機的動機(L2) MD=L1+L2 貨幣供給(Ms)=名目貨幣供給/物価(P) ・LM曲線のシフト 金融緩和策・物価下落：実質貨幣供給(MS)が増大→右(下)へシフト 金融引締策・物価上昇：実質貨幣供給(MS)が減少→左(上)へシフト 独立投資拡大→IS曲線が右にシフト 利子率がr1→r2に下落する。 IS曲線、LM曲線の均衡点がE→Fに移動する。 国民所得がY1→Yfとなって増大する。 3:特殊なLM曲線 ・ 流動性の罠 のLM曲線 金融政策は無効→LM曲線をシフトさせても均衡点Eは変わらない IS曲線を右にシフトさせる拡張的な財政政策を実施すると均衡点が E→E´となり国民所得がY1→Y2に増加するので財政政策は有効となる。　　　 ・ 投資の利子率に対する弾力性ゼロ 金融政策は無効→LM曲線を右にシフトさせても国民所得が増えない。 流動性の罠と同じくIS曲線を右にシフトさせる拡張的な財政政策を実施すると 均衡点がE→E´となり国民所得がY1→Y2に増加するので財政政策は有効となる。　　　　　　 4: クラウディング・アウト 政府が市場に介入して公共投資を行うと民間の投資が締出しを受ける ・古典派による財政政策の無効論 政府支出を拡大すると利子率が上昇してしまい。投資が減少する。 政府の支出がクラウディングアウトを引き起こして支...
続きを読む

IEのセキュリティ設定をいじくるバッチ

-
まぁかなり頻出ですがIEでアプリ用に設定しないといけなくて クリックOnlyで処理したかったので色々と調べてみて作ってみた。 ローカルイントラネットの設定いじくるのとActiveX関連をいじくるのと 互換表示設定をいじくっています。 というよりそういう設定しないと動かないアプリの組み方辞めてください。 頼むから・・・。 挙動が微妙に他と違うのでIEとかEdgeには苦しめられます。 @echo off set REGROOT="HKCU\SOFTWARE\Microsoft\Windows\CurrentVersion\Internet Settings\ZoneMap" reg add %REGROOT% /f /v "AutoDetect" /t REG_DWORD /d "0" reg add %REGROOT% /f /v "IntranetName" /t REG_DWORD /d "1" reg add %REGROOT% /f /v "ProxyBypass" /t REG_DWORD /d "1" reg add %REGROOT% /f /v "UNCAsIntranet" /t REG_DWORD /d "1" rem IEのローカルイントラネット設定(*ドメイン指定) set REGROOT="HKCU\SOFTWARE\Microsoft\Windows\CurrentVersion\Internet Settings\ZoneMap\Ranges\Range1" set REGROOT="HKCU\SOFTWARE\Microsoft\Windows\CurrentVersion\Internet Settings\ZoneMap\Domains\対象ドメイン" reg add %REGROOT% /f /v "*" /t REG_DWORD /d "1" rem スクリプトを実行しても安全だとマークされていない activex コントロールの初期化とスクリ...
続きを読む