ユーザ登録用スクリプト_その1

-
ひとまずACCESSのデータベースから値を拾ってきてActiveDirectoryと外部メールサービスに新規ユーザを追加するVBスクリプトを作ってみた。どこかで再利用するかもしれないから保存しとく。ずぶの素人が作成しているのでソース汚いのはお約束で・・・・
以下、メインの処理 を
 ・EXCELからデータを引いてきて、データを加工しACCESSに登録
 ・ACCESSからデータを抜いてADとメールサーバにデータ登録
 ・結果をEXCELに登録しつつ、完了メール送信
てな塩梅です。 


Option Explicit
Dim Logrtn        'Log
Dim CErrMsg
Dim LErrMsg

CErrMsg = "エラー：処理継続不可"
LErrMsg = "エラー：ログ出力時エラー"

Dim cn, rs        'ACCESSデータベース
Dim objFso        'ファイル存在チェック用

Dim DataBaseName
Dim strSQL
Dim ExcelName

Dim EmpDate        '現在日付取得
Dim EmpNo      

Dim rsCount        'レコード件数取得用

Dim strName      
Dim strKnName  
Dim strPlace   
Dim Section  
Dim EmpLank  
Dim EmpStat  
Dim strLoginID    'WindowsログインID
Dim strLoginPW    'WindowsログインPW
Dim strPMailAdd    'メールアドレス
Dim strPMailPW     'メールアドレスパスワード

Dim AdColum
Dim MailColum
AdColum   = "X"    'EXCELの列
MailColum = "X"    'EXCELの列

Dim EmpMrtn      
Dim Adrtn      
Dim AdGrtn      
Dim Mlrtn      
Dim Mlsndrtn      
Dim Excelrtn      
Dim adCounter      
Dim mailCounter      

'***ACCEESS(入力)
DataBaseName = "C:\XXX.accdb"      
'***EXCEL(出力)
ExcelName = "C:\XXX.xls"

'当日日付取得(m/d/yyyy形式)
EmpDate = Month(Now)
EmpDate = EmpDate & "/" & Day(Now)
EmpDate = EmpDate & "/" & Year(Now)

EmpMrtn = ExcelToAccess(ExcelName,DataBaseName,EmpDate)
If EmpMrtn = "False" Then
    WScript.Echo CErrMsg
    Logrtn = OutLogger("[Err],ACCESSデータベース登録処理でエラーが発生しました。入社チェックリストを確認してください。")
    If Logrtn = "False" Then
        WScript.Echo LErrMsg
    End If
    WScript.Quit()
End If

'ACCESSデータベースオープン　参照：http://pnpk.net/cms/archives/3226
Set objFso = CreateObject("Scripting.FileSystemObject")
If objFso.FileExists(DataBaseName) Then
    Set cn = CreateObject("ADODB.Connection")
    cn.CursorLocation = 3                     ' クライアントサイドカーソルに変更(レコードセットカウント対策)
    Set rs = CreateObject("ADODB.Recordset")
    cn.Open "Provider = Microsoft.ACE.OLEDB.12.0; " & _
    "Data Source = " & DataBaseName & ";"
Else
    WScript.Echo CErrMsg
    Logrtn = OutLogger("[Err],ACCESSデータベースに入社対象者が存在しません。ACCESSデータベースを確認してください。")
    If Logrtn = "False" Then
        WScript.Echo LErrMsg
    End If
    Set objFso = Nothing
    WScript.Quit()
End If
Set objFso = Nothing

'SQL発行
strSQL=""
strSQL= strSQL & "SELECT ACCESSデータベース.[KeyCD], "
strSQL= strSQL & " FROM ACCESSデータベース "
strSQL= strSQL & " WHERE (((ACCESSデータベース.対象日)> "
strSQL= strSQL & "#" & EmpDate & "#" & ")"
strSQL= strSQL & " AND "
strSQL= strSQL & " AND "
strSQL= strSQL & "((ACCESSデータベース.));"

Set rs =cn.Execute(strSQL)    'ACCESSデータベースSQL実行
rsCount = rs.RecordCount

If rsCount = 0 Then
    Set rs = Nothing
    Set cn = Nothing
    WScript.Echo CErrMsg
    Logrtn = OutLogger("[Err],処理対象が0件です。")
    If Logrtn = "False" Then
        WScript.Echo LErrMsg
    End If
    WScript.Quit()
End If

If rs.Eof Then
    Set rs = Nothing
    Set cn = Nothing
    WScript.echo "対象0件：処理が完了しました。"
    Logrtn = OutLogger("[Worn],追加対象なし。")
    If Logrtn = "False" Then
        WScript.Echo LErrMsg
    End If
    WScript.Quit()
Else
    rs.MoveFirst      
End If

'//**  ユーザ登録処理
'  参照：http://d.hatena.ne.jp/masahiror/20070706/ad_vbs
adCounter=0
Do Until rs.Eof = True
    EmpNo       = rs("XXX")
    strName    = rs("XXX")
    strLoginID = rs("XXX")
    strLoginPW = rs("XXX")
    strPMailAdd = rs("XXX")
    strPlace = rs("XXX")
    Section = rs("XXX")
  
    '***　ActiveDirectoryユーザ追加
    strName=Replace(strName,"　","")
    Adrtn = ActiveDirectoryAdd(strName,strLoginID,strLoginPW,strPMailAdd,strPlace)
    'エラー時は処理終了
    If Adrtn = "False" Then
        WScript.Echo CErrMsg
        Logrtn = OutLogger("[Err]," & StrName & ":追加中にAD登録エラーが発生しました。")
        If Logrtn = "False" Then
            WScript.Echo LErrMsg
        End If
        Set rs = Nothing
        Set cn = Nothing
        WScript.Quit()
    End If
    '***グループ追加
    AdGrtn = ADGroupAdd(strName,Section)
    'エラー時は処理終了
    If AdGrtn = "False" Then
        WScript.Echo CErrMsg
        Logrtn = OutLogger("[Err]," & StrName & ":グループ登録に失敗しました。")
        If Logrtn = "False" Then
            WScript.Echo LErrMsg
        End If
        Set rs = Nothing
        Set cn = Nothing
        WScript.Quit()
    End If
  
    'EXCELに結果入力」
    Excelrtn = ExcelSheetInput(EmpNo,AdColum,ExcelName)
  
    If Excelrtn = "False" Then
        Logrtn = OutLogger("[Err]," & StrName & "：EXCEL入力の際にエラーが発生しました。")
        If Logrtn = "False" Then
            WScript.Echo LErrMsg
        End If
    End If
  
    Logrtn = OutLogger("[Done]," & StrName & "：ActiveDirectoryのアカウント追加完了")
    If Logrtn = "False" Then
        WScript.Echo LErrMsg
    End If
    rs.MoveNext
    adCounter=adCounter+1
Loop

Logrtn = OutLogger("[Done],ActiveDirectoryのアカウント追加完了" & "処理対象:" & adCounter & "件")
If Logrtn = "False" Then
    WScript.Echo LErrMsg
End If

'/*　ActiveDirectoryとメールサーバの処理を切り分けるため初期レコードに戻す。
rs.MoveFirst      

mailCounter=0
Do Until rs.Eof = True
    EmpNo       = rs("XXX")
    strName    = rs("XXX")
    strPMailAdd = rs("XXX")
    strPMailPW  = rs("XXX")
  
    Mlrtn = MailSrvAdd(strName,strPMailAdd,strPMailPW,strPlace)
    'エラー時は処理終了
    If Mlrtn = "False" Then
        WScript.Echo CErrMsg
        Logrtn = OutLogger("[Err]," & StrName & "：メールサーバ登録エラーが発生しました。")
        If Logrtn = "False" Then
            WScript.Echo LErrMsg
        End If
      
        Set rs = Nothing
        Set cn = Nothing
        WScript.Quit()
    End If
    'EXCELに結果入力
    Excelrtn = ExcelSheetInput(EmpNo,MailColum,ExcelName)
  
    If Excelrtn = "False" Then
        Logrtn = OutLogger("[Err]," & StrName & "：EXCEL入力の際にエラーが発生しました。")
      
        If Logrtn = "False" Then
            WScript.Echo LErrMsg
        End If
    End If
    Logrtn = OutLogger("[Done]," & StrName & "：サーバへのメールアカウント追加完了")
    If Logrtn = "False" Then
        WScript.Echo LErrMsg
    End If
    rs.MoveNext
    mailCounter=mailCounter+1
Loop

Logrtn = OutLogger("[Done],メールサーバのアカウント追加完了" & "処理対象:" & mailCounter & "件")
If Logrtn = "False" Then
    WScript.Echo LErrMsg
End If

'SQL発行
strSQL=""
strSQL= strSQL & "UPDATE ACCESSデータベース SET ACCESSデータベース.XXX = '' "
strSQL= strSQL & "WHERE ((ACCESSデータベース.XXX='" & EmpNo & "'));"

If Err.Number <> 0 Then
    ExcelToAccess = "False"
    Logrtn = OutLogger("[Err],"& EmpNo & ":更新中にエラーが発生しました。")
    If Logrtn = "False" Then
        WScript.Echo LErrMsg
    End If
Else
    Set rs =cn.Execute(strSQL)
End If

Mlsndrtn = CompMailSend(EmpNo,ExcelName)
If Mlsndrtn = "False" Then
    WScript.Echo CErrMsg
    Logrtn = OutLogger("[Err],メール送信処理でエラーが発生しました。")
    If Logrtn = "False" Then
        WScript.Echo LErrMsg
    End If
    WScript.Quit()
End If

WScript.echo "処理完了"
Set rs = Nothing
Set cn = Nothing

コメント

コメントを投稿

このブログの人気の投稿

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 コントロールの初期化とスクリ...
続きを読む