コンピューターOU移動 - ナマステSEの備忘録

Option Explicit
'======================================================================
'【ファイル名】
'VBS_MoveComputerToWin7OU.vbs
'
'【用途】
'Win10のコンピュータオブジェクトを指定のOUに移動する
'
'【実行手順】
'①Domain Admins権限でスクリプトを実行
'
'【関連ファイル】
'Win10OUList.txt：移動元と移動先のOU対応表(本ツールと同じフォルダに配置)
' ファイル形式「移動元OUのDN <Tab> 移動先OUのDN
' 移動元OUのDN <Tab> 移動先OUのDN
' :
' 移動元OUのDN <Tab> 移動先OUのDN」
' ※移動しないOUを定義する場合には、「移動先OUのDN」に"<->"を指定
'Win10OUMoveReult_YYYYMMDDhhmmss.log：処理結果ファイル(本ツールと同じフォルダに出力)
' ファイル形式「処理日時 <Tab> PC名 <Tab> 移動元OU <Tab> 移動先OU <Tab> 処理結果
' 処理日時 <Tab> PC名 <Tab> 移動元OU <Tab> 移動先OU <Tab> 処理結果
' ：：：：
' 処理日時 <Tab> PC名 <Tab> 移動元OU <Tab> 移動先OU <Tab> 処理結果」
'
'======================================================================
'【基本情報】
'======================================================================
'ドメイン名
Const cntDomainDN = "DC=XXXX"

'AD内検索条件(条件間の接続はTab区切り)
Const cntCondition = "objectCategory:::Computer operatingSystem:::Windows 10*"

'OU対応表のファイル名
Dim strOUListFilePath
strOUListFilePath = funGetScriptPath() & "\Win10OUList.txt"

'処理結果ファイルのパス
Dim strOutputFilePath
strOutputFilePath = funGetScriptPath() & "\Win7OUMoveReult_" & _
Replace(Replace(Replace(Now(), "/", ""), ":", ""), " ", "") & _
".log"

'昨日までのログファイルの移動先フォルダ
Dim strLogFolderPath
strLogFolderPath = funGetScriptPath() & "\Log"

'======================================================================
'【メイン処理】
'======================================================================
'変数定義
Dim objDictionary 'Dictionaryオブジェクト

Dim strResult 'AD内検索結果
Dim arrComputerDN '検索結果のコンピュータオブジェクトのDNの配列
Dim strPCName 'コンピュータオブジェクト名
Dim strParentOUDN 'PCの格納されているOUのDN
Dim strLogMessage 'ログファイルへの書き込みメッセージ
Dim lngResult '処理結果
Dim strBody '通知メールの本文
Dim arrResult(5) '処理件数

Dim arrTemp, arrTemp2 '一時利用配列
Dim i 'ダミーインデックス

'オブジェクトの定義
Set objDictionary = CreateObject("Scripting.Dictionary")

'OU対応表を読み込んで、Dictionaryオブジェクトに格納
arrTemp = Split(funReadFile(strOUListFilePath), vbCrLf)
For i = 0 To UBound(arrTemp)
arrTemp2 = Split(arrTemp(i), vbTab)
If UBound(arrTemp2) = 1 Then
arrTemp2(0) = Replace(Trim(arrTemp2(0)), """", "")
arrTemp2(1) = Replace(Trim(arrTemp2(1)), """", "")
If (arrTemp2(0) <> "") And (arrTemp2(1) <> "") Then
objDictionary.Add arrTemp2(0), arrTemp2(1)
End If
End If
Erase arrTemp2
Next
Erase arrTemp

'AD内の検索
strResult = funGetObjectNameFromAD(cntCondition, cntDomainDN)
arrComputerDN = Split(strResult, vbTab)

'ログファイルにタイトル行を追加
strLogMessage = "処理日時" & vbTab & "PC名" & vbTab & "移動元OU" & vbTab & "移動先OU" & vbTab & "処理結果"
Call funPutLog(strOutputFilePath, strLogMessage, vbYes, -2)

'1件ずつコンピュータオブジェクトを処理
For i = 0 To UBound(arrComputerDN)
'PC名と格納先OU名を取得
strPCName = funGetObjectProperty(arrComputerDN(i), "cn")
strParentOUDN = Replace(arrComputerDN(i), "CN=" & strPCName & ",", "")
'格納先OUによって処理を分岐
If InStr(1, strParentOUDN, "OU=Computers-7,", vbTextCompare) > 0 Then
'格納先OUが"Computers-7"OU配下の場合は処理なし
arrResult(0) = arrResult(0) + 1
Else
'格納先OUが"Computers-7"OU配下ではない場合
If strPCName <> "" Then
If objDictionary.Exists(strParentOUDN) = True Then
'OU対応表に載っているOUの場合はOU移動
If objDictionary.Item(strParentOUDN) <> "<->" Then
lngResult = funOU_Move(arrComputerDN(i), objDictionary.Item(strParentOUDN))
If lngResult = vbOK Then
strLogMessage = Now() & vbTab & strPCName & vbTab & strParentOUDN & vbTab & objDictionary.Item(strParentOUDN) & vbTab & "【移動成功】"
arrResult(1) = arrResult(1) + 1
Else
strLogMessage = Now() & vbTab & strPCName & vbTab & strParentOUDN & vbTab & objDictionary.Item(strParentOUDN) & vbTab & "【移動失敗】"
arrResult(2) = arrResult(2) + 1
End If
Else
strLogMessage = Now() & vbTab & strPCName & vbTab & strParentOUDN & vbTab & objDictionary.Item(strParentOUDN) & vbTab & "【対象外】"
arrResult(3) = arrResult(3) + 1
End If
Else
'OU対応表に載っていないOUの場合はメッセージのみ
strLogMessage = Now() & vbTab & strPCName & vbTab & strParentOUDN & vbTab & "移動先の定義なし" & vbTab & "【未処理】"
arrResult(4) = arrResult(4) + 1
End If
Else
strLogMessage = Now() & vbTab & "検索失敗" & vbTab & "検索失敗" & vbTab & "検索失敗" & vbTab & "【検索失敗】：" & arrComputerDN(i)
arrResult(5) = arrResult(5) + 1
End If
'ログファイルに結果を書き込み
Call funPutLog(strOutputFilePath, strLogMessage, vbYes, -2)
End If
Next

'オブジェクトの開放
Set objDictionary = Nothing

'メール送信
strBody = "Windows 7プロジェクト各位" & vbCrLf & vbCrLf & _
"FFWIN上のWindows 7コンピュータオブジェクトの" & vbCrLf & _
"移動結果を通知します。" & vbCrLf & vbCrLf & _
"【処理結果】" & vbCrLf & _
"================================" & vbCrLf & _
"Win7 OUに既に所属：" & vbTab & arrResult(0) & "台" & vbCrLf & _
"OU移動の対象外：" & vbTab & arrResult(3) & "台" & vbCrLf & _
"Win7 OUに移動(成功)：" & vbTab & arrResult(1) & "台" & vbCrLf & _
"Win7 OUに移動(失敗)：" & vbTab & arrResult(2) & "台" & vbCrLf & _
"移動先OUが未定義：" & vbTab & arrResult(4) & "台" & vbCrLf & _
"PC情報の検索失敗：" & vbTab & arrResult(5) & "台" & vbCrLf & _
"================================" & vbCrLf & vbCrLf & _
"【タスク実行サーバ】" & vbCrLf & _
CreateObject("WScript.Network").ComputerName & vbCrLf
If (arrResult(2) > 0) Or (arrResult(4) > 0) Or (arrResult(5) > 0) Then
Call funSendMail(cntFromAddress, cntToAddress, cntCCAddress, cntBCCAddress, "【異常】" & cntSubject, strBody, strOutputFilePath)
Else
If (arrResult(1) > 0) Or (InStr(1, Replace(funGetSubFileName(funGetScriptPath()), strOutputFilePath, ""), Replace(Date(), "/", ""), vbTextCompare) = 0) Then
Call funSendMail(cntFromAddress, cntToAddress, cntCCAddress, cntBCCAddress, "【通知】" & cntSubject, strBody, strOutputFilePath)
Else
Call funSendMail(cntFromAddress, cntToAddress, cntCCAddress, cntBCCAddress, "【通知】" & cntSubject, strBody, "")
End If
End If

'昨日までのログファイルをフォルダに移動
arrTemp = Split(funGetSubFileName(funGetScriptPath()), vbTab)
For i = 0 To UBound(arrTemp)
If (InStr(1, arrTemp(i), ".log", vbTextCompare) > 0) And (InStr(1, arrTemp(i), Replace(Date(), "/", ""), vbTextCompare) = 0) Then
Call funRenameFile(arrTemp(i), strLogFolderPath & "\")
End If
Next

'======================================================================
'【関数】funGetScriptPath
'【機能】実行中のスクリプトのパスを取得する
'【返値】スクリプトのパス
'======================================================================
Function funGetScriptPath()

'変数定義
Dim objFSO 'ファイルシステムオブジェクト

'オブジェクトの定義
Set objFSO = CreateObject("Scripting.FileSystemObject")

'返り値の設定
funGetScriptPath = objFSO.GetFile(WScript.ScriptFullName).ParentFolder

'オブジェクトの開放
Set objFSO = Nothing

End Function

'======================================================================
'【関数】funReadFile
'【機能】指定したファイルを読み込む
'【変数】strFilePath ：読み込むファイル
'【返値】ファイルの内容(ファイルが存在しない場合には""を返す)
'======================================================================
Function funReadFile(strFilePath)

'変数定義
Dim objFSO 'ファイルシステムオブジェクト
Dim objReadStream '読み込み対象ファイルのストリームオブジェクト

'オブジェクトの定義
Set objFSO = CreateObject("Scripting.FileSystemObject")

'ファイルの読み込み
If objFSO.FileExists(strFilePath) = True Then
Set objReadStream = objFSO.OpenTextFile(strFilePath)
funReadFile = objReadStream.ReadAll
Set objReadStream = Nothing
Else
funReadFile = ""
End If

'オブジェクトの解放
Set objFSO = Nothing

End Function

'======================================================================
'【関数】funGetObjectNameFromAD
'【機能】指定した条件に合致するオブジェクトのDN一覧を取得する
'【変数】strConditions ：プロパティに対する値の条件(部分一致の場合は値に"*"を利用)
' 形式「プロパティ:::値 <Tab> プロパティ:::値 <Tab>･･･」
' strDomainDN ：検索するドメインのDN
'【返値】条件に一致したオブジェクトのDN(複数ある場合には<Tab>区切り、対象がない場合には"")
'======================================================================
Function funGetObjectNameFromAD(strConditions, strDomainDN)

'変数定義
Dim objConnection 'コネクションオブジェクト
Dim objCommand 'SQLコマンドオブジェクト
Dim objRecordSet '検索結果のレコードセット

Dim strCommandText 'AD検索コマンド
Dim arrConditions '検索条件の配列
Dim arrCondition '検索条件(プロパティと値の2要素)の配列

Dim i 'ダミーインデックス

'初期設定
funGetObjectNameFromAD = ""

'検索対象のADに接続
Set objConnection = CreateObject("ADODB.Connection")
Set objCommand = CreateObject("ADODB.Command")
objConnection.Provider = "ADsDSOObject"
objConnection.Open "ADs Provider"
Set objCommand.ActiveConnection = objConnection
objCommand.Properties("Page Size") = 50000

'ADに対する検索コマンドを生成
strCommandText = "SELECT ADsPath FROM 'LDAP://" & strDomainDN & "' WHERE"
arrConditions = Split(strConditions, vbTab)
For i = 0 To UBound(arrConditions)
arrCondition = Split(arrConditions(i), ":::")
If i = 0 Then
strCommandText = strCommandText & " " & arrCondition(0) & "='" & arrCondition(1) & "'"
Else
strCommandText = strCommandText & " And " & arrCondition(0) & "='" & arrCondition(1) & "'"
End If
Erase arrCondition
Next

'AD内を検索
On Error Resume Next
objCommand.CommandText = strCommandText
Set objRecordSet = objCommand.Execute

'返値の設定
If Err.Number = 0 Then
With objRecordSet
'レコードセットの先頭に移動
If .BOF <> True Then
.MoveFirst
End If
'レコードセットの内容を返り値に設定
Do Until .EOF = True
funGetObjectNameFromAD = funGetObjectNameFromAD & Replace(objRecordSet.Fields("ADsPath").Value, "LDAP://", "") & vbTab
.MoveNext
Loop
End With
Else
Err.Clear
End If
funGetObjectNameFromAD = Replace(funGetObjectNameFromAD & vbTab, vbTab & vbTab, "")
On Error Goto 0

'オブジェクトの開放
Set objRecordSet = Nothing
Set objCommand = Nothing
Set objConnection = Nothing

End Function

'======================================================================
'【関数】funGetObjectProperty
'【機能】オブジェクトのプロパティを取得
'【変数】strObjectName ：オブジェクトのDN
' strPropertyName ：取得するプロパティ
'【返値】プロパティの値(複数値を持つ場合にはTab区切り)
'======================================================================
Function funGetObjectProperty(strObjectName, strPropertyName)

'変数定義
Dim objObject 'オブジェクト

Dim arrProperty 'オブジェクトのプロパティ値の配列
Dim strProperty 'オブジェクトのプロパティ
Dim i 'ダミーインデックス

'初期設定
i = 0
'ユーザ情報の書き出し
On Error Resume next
Set objObject = GetObject("LDAP://" & strObjectName)

'プロパティの取得
arrProperty = objObject.GetEx(strPropertyName)
For Each strProperty In arrProperty
If i = 0 Then
funGetObjectProperty = strProperty
Else
funGetObjectProperty = funGetObjectProperty & vbTab & strProperty
End If
i = i + 1
Next
On Error Goto 0

'オブジェクトの開放
Set objObject = Nothing

End Function

'======================================================================
'【関数】funOU_Move
'【機能】オブジェクトのOUを移動する
'【変数】strObjectDN : 移動対象オブジェクトのDN
' strTargetOU : 移動先OUのDN
'【返値】vbOK : 成功
' vbAbort : 処理失敗
'======================================================================
Function funOU_Move(strObjectDN, strTargetOU)
'変数定義
Dim objObject '移動完了後の対象オブジェクト
Dim objTarget '移動先のOUオブジェクト

On Error Resume Next

'オブジェクトの定義
Set objTarget = GetObject("LDAP://" & strTargetOU)
Set objObject = objTarget.MoveHere("LDAP://" & strObjectDN, vbNullString)

'返値の設定
If Err.Number <> 0 Then
funOU_Move = vbAbort
Else
funOU_Move = vbOK
End If

'オブジェクトの開放
Set objObject = Nothing
Set objTarget = Nothing

End Function

'======================================================================
'【関数】funPutLog
'【機能】ログを書き込み
'【変数】strLogFileName : ログファイル名
' strMessage ：ログメッセージ
' lngMode ：追記モード
' vbYes 内容を追記
' vbNo 内容を新規に追加
' lngEncode ：エンコード
' 0 ASCII
' -1 Unicode
' -2 システムのデフォルト
'【返値】vbOK ：成功
' vbCancel ：失敗
'======================================================================
Function funPutLog(strLogFileName, strMessage, lngMode, lngEncode)

'変数定義
Dim objFSO 'ファイルシステムオブジェクト
Dim objLogFile 'ログファイルオブジェクト

'オブジェクトの定義
On Error Resume Next
Set objFSO = CreateObject("Scripting.FileSystemObject")
If lngMode = vbYes Then
Set objLogFile = objFSO.OpenTextFile(strLogFileName, 8, True, lngEncode)
Else
Set objLogFile = objFSO.OpenTextFile(strLogFileName, 2, True, lngEncode)
End If

'ログの書き込み
objLogFile.WriteLine strMessage

'返値の設定
If Err.Number <> 0 Then
funPutLog = vbCancel
Else
funPutLog = vbOK
End If
On Error Goto 0

'オブジェクトの開放
Set objLogFile = Nothing
Set objFSO = Nothing

End Function

'======================================================================
'【関数】funGetSubFileName
'【機能】フォルダ内のファイル名を取得する
'【変数】strFolderName ：フォルダ名
'【返値】ファイル名（タブ区切り）
'======================================================================
Function funGetSubFileName(strFolderName)

'変数定義
Dim objFSO 'ファイルシステムオブジェクト
Dim objFolder 'フォルダオブジェクト
Dim objFile 'サブフォルダオブジェクト

Dim i 'カウンタ

'初期設定
funGetSubFileName = ""
i = 0

'オブジェクトの定義
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(strFolderName)

'サブフォルダ名の取得
For Each objFile In objFolder.Files
If i <> 0 Then
funGetSubFileName = funGetSubFileName & vbTab & objFile.Path
Else
funGetSubFileName = objFile.Path
End If
i = i + 1
Next

'オブジェクトの開放
Set objFile = Nothing
Set objFolder = Nothing
Set objFSO = Nothing

End Function

'======================================================================
'【関数】funSendMail
'【機能】メールを送信する
'【変数】strFromAdress ：差出人
' strToAddress ：あて先(複数の場合は","区切り)
' strCCAddress ： CC(複数の場合は","区切り、無しの場合は"")
' strBCCAddress ： BCC(複数の場合は","区切り、無しの場合は"")
' strSubject ：件名
' strBody ：本文
' strAttachmentPath ：添付ファイルのパス(複数の場合は:::区切り、無しの場合は"")
'【返値】vbOK ：成功
' vbAbort ：失敗
'======================================================================
Function funSendMail(strFromAddress, strToAddress, strCCAddress, strBCCAddress, strSubject, strBody, strAttachmentPath)

'変数定義
Dim objMsg 'メールオブジェクト
Dim arrAttachmentPath '添付ファイルのパスの配列
Dim strPath

Const cntRemoteSMTP = "133.170.11.8" '外部SMTPサーバ

'オブジェクトの定義
Set objMsg = CreateObject("CDO.Message")

'メールオブジェクトのプロパティ設定
With objMsg
.From = strFromAddress
.To = strToAddress
.CC = strCCAddress
.BCC = strBCCAddress
.Subject = strSubject
.BodyPart.Charset = "iso-2022-jp"
.BodyPart.ContentTransferEncoding = "7bit"
.TextBody = strBody
If strAttachmentPath <> "" Then
If InStr(1, strAttachmentPath, ":::", vbTextCompare) = 0 Then
.AddAttachment strAttachmentPath
Else
arrAttachmentPath = Split(strAttachmentPath, ":::")
For Each strPath In arrAttachmentPath
.AddAttachment strPath
Next
End If
End If
End With

'外部SMTPサーバを利用してメールを送信
With objMsg.Configuration.Fields
.Item _
( "http://schemas.microsoft.com/cdo/configuration/sendusing" ) = 2
.Item _
( "http://schemas.microsoft.com/cdo/configuration/smtpserver" ) = cntRemoteSMTP
.Item _
( "http://schemas.microsoft.com/cdo/configuration/smtpserverport" ) = 25
.Update
End With
On Error Resume Next
objMsg.send

'返値の設定
If Err.Number = 0 Then
funSendMail = vbOK
Else
funSendMail = vbAbort
End If
On Error Goto 0

End Function

'======================================================================
'【関数】funRenameFile
'【機能】指定されたファイルをリネームする
'【変数】strBeforeFileName ：リネーム対象ファイルのフルパス
' strAfterFileName ：リネーム後のファイルのフルパス
'【返値】vbOK ：リネーム成功
' vbCancel ：リネーム失敗
' vbAbort ：同名のファイルが存在するため、処理せず
'======================================================================
Function funRenameFile(strBeforeFileName, strAfterFileName)

'変数定義
Dim objFSO 'ファイルシステムオブジェクト

Dim lngResult '処理結果

'オブジェクトの定義
Set objFSO = CreateObject("Scripting.FileSystemObject")

'ファイルの存在チェック
If Right(strAfterFileName, 1) <> "\" Then
If objFSO.FileExists(strAfterFileName) Then
Set objFSO = Nothing
funRenameFile = vbAbort
Exit Function
End If
End If

'ファイルのリネーム
On Error Resume Next
objFSO.MoveFile strBeforeFileName, strAfterFileName
If Err.Number <> 0 Then
funRenameFile = vbCancel
Else
funRenameFile = vbOK
End If
On Error Goto 0

'オブジェクトの開放
Set objFSO = Nothing

End Function