2019-04-11

グループメンバー同期

Option Explicit
'======================================================================
'【ファイル名】
'AD_ReplicateGroupMembers.vbs
'
'【用途】
'AD上の2つのグループのグループメンバシップを同期させる
'
'【実行手順】
'Domain Adminsメンバとしてスクリプトを実行
'
'【関連ファイル】
'①Groups.txt ：同期するグループを指定(スクリプトと同じフォルダに配置)
' 「[同期元グループ名] <Tab> [同期先グループ名]
' [同期元グループ名] <Tab> [同期先グループ名]
' ：
' [同期元グループ名] <Tab> [同期先グループ名]」
'②ログファイル：同期元グループのメンバリストとツール実行結果はツールの
' フォルダ直下の「Log」フォルダにZIP形式で保存
' 同期元グループメンバリスト → [YYYYMMDDhhmmssss][グループ名].zip
' ログファイル → [YYYYMMDDhhmmssss]RepGroupLog.zip
'
'======================================================================
'【基本情報】
'======================================================================
'同期するグループを指定したファイル名
Const cntInputFileName = "Groups.txt"

'グループメンバの差分を抽出するドメインコントローラ名(FQDN)
Const cntDomainController = "XXXX"

'グループメンバの出力ファイル名
'同期元グループ
Const cntGroupMemberFileName = "GroupMember"
'動機先グループ
Const cntRepGroupMemberFileName = "RepGroupMember.txt"

'差分調査結果ファイル名
'追加対象
Const cntAddUsersFileName = "AddUsers"
'削除対象
Const cntDeleteUsersFileName = "DeleteUsers"

'処理結果ファイル名
Const cndResultFileName = "RepGroupLog.txt"

'======================================================================
'【メイン処理】
'======================================================================
'変数定義
Dim objFSO 'ファイルシステムオブジェクト
Dim objInputFileStream '入力ファイルのストリーム
Dim objFileStream '読み込みファイルのストリーム

Dim strInputFilePath '同期するグループを指定したファイルのパス
Dim strDomainDN '実行アカウントの所属ドメインのDN
Dim strInputFileLine '入力ファイルの1行
Dim arrInputFileLine '入力ファイルの<Tab>の前後の文字列
Dim strGroupDN '同期元グループのDN
Dim strRepGroupDN '同期先グループのDN
Dim strGroupMemberFilePath '同期元グループのメンバ出力ファイルのパス
Dim strRepGroupMemberFilePath '同期先グループのメンバ出力ファイルのパス
Dim strAddUsersFilePath '追加対象ユーザリストのパス
Dim strDeleteUsersFilePath '削除対象ユーザリストのパス
Dim strResultFilePath '処理結果ファイルのパス
Dim strGroupMemberBackupPath 'グループメンバのバックアップファイルのパス
Dim strResultFileBackupPath '処理結果のバックアップファイルパス
Dim strLine '読み込みファイルの1行
Dim strResultLine '処理結果ファイルへの出力行
Dim arrLine '読み込みファイルの1行をTabで分割
Dim strTempGroupDN '処理対象グループのDN
Dim strMemberDN 'グループメンバのDN
Dim strDate 'ツール実行時間の文字列
Dim strErrLogLine 'エラー発生時のメッセージ
Dim lngResult '処理結果

'事前準備
'入力ファイルのパス生成
strInputFilePath = funGetScriptPath() & "\" & cntInputFileName
'ドメインDNの取得
strDomainDN = funGetDomainDN()
'実行時刻の取得
strDate = Replace(Replace(Replace(Replace(Now(), "/", ""), ":", ""), ":", ""), " ","")
'グループメンバ出力ファイルのパス生成
strGroupMemberFilePath = funGetScriptPath() & "\" & strDate & cntGroupMemberFileName
strRepGroupMemberFilePath = funGetScriptPath() & "\" & strDate & cntRepGroupMemberFileName
'同期対象ユーザリストのパス生成
strAddUsersFilePath = funGetScriptPath() & "\" & strDate & cntAddUsersFileName
strDeleteUsersFilePath = funGetScriptPath() & "\" & strDate & cntDeleteUsersFileName
'処理結果ファイルのパス生成
strResultFilePath = funGetScriptPath() & "\" & strDate & cndResultFileName
'処理結果バックアップファイルのパス生成
strResultFileBackupPath = funGetScriptPath() & "\Log\" & strDate & cndResultFileName & ".zip"
'エラーメッセージの初期化
strErrLogLine = ""

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

'ファイルを1行ずつ読み込んでグループメンバの差分を同期
Do Until objInputFileStream.AtEndOfStream = True
'入力ファイルを1行読み込み
strInputFileLine = objInputFileStream.ReadLine
If strInputFileLine <> "" Then

'同期対象ユーザの調査
arrInputFileLine = Split(strInputFileLine, vbTab)
'プライマリグループとそれ以外のグループで処理を分岐
If (UCase(arrInputFileLine(0)) = "DOMAIN USERS") Or (UCase(arrInputFileLine(0)) = "DOMAIN COMPUTERS") Or (UCase(arrInputFileLine(0)) = "DOMAIN CONTROLLERS") Then
Call subPrimaryGroupMemberListup(arrInputFileLine(0), strGroupMemberFilePath, strDomainDN, cntDomainController)
Else
'同期元グループのDNを取得
strGroupDN = funUserDNSearch(arrInputFileLine(0), strDomainDN, cntDomainController)
'同期元グループのメンバを出力
Call subADGroupMemberListup(strGroupDN, strGroupMemberFilePath, cntDomainController)
End If
'同期先グループのDNを取得
strRepGroupDN = funUserDNSearch(arrInputFileLine(1), strDomainDN, cntDomainController)
'同期先グループのメンバを出力
Call subADGroupMemberListup(strRepGroupDN, strRepGroupMemberFilePath, cntDomainController)

'同期処理
'同期元グループと同期先グループの差分抽出
Call subExecute_GroupDiff(strGroupMemberFilePath, strRepGroupMemberFilePath, strAddUsersFilePath, strDeleteUsersFilePath)

'グループメンバの追加
Call funPutLog(strResultFilePath, "【" & arrInputFileLine(0) & "グループメンバ同期-追加分】", vbYes)
Set objFileStream = objFSO.OpentextFile(strAddUsersFilePath)
Do Until objFileStream.AtEndOfStream = True
strLine = objFileStream.ReadLine
strResultLine = ""
If strLine <> "" Then
arrLine = Split(strLine, vbTab)
If (Ubound(arrLine) = 1) And (arrLine(1) <> "") Then
strMemberDN = funUserDNSearch(arrLine(1), strDomainDN, cntDomainController)
If strMemberDN = "" Then
strResultLine = "[N G]" & vbTab & arrInputFileLine(1) & vbTab & arrLine(1) & vbTab & "【メンバ存在せず】"
strErrLogLine = strErrLogLine & arrInputFileLine(0) & Replace(strResultLine, "[N G]", "") & vbCrLf
Else
lngResult = funGroupMemberAdd(strRepGroupDN, strMemberDN, cntDomainController)
If lngResult = vbOK Then
strResultLine = "[O K]" & vbTab & arrInputFileLine(1) & vbTab & arrLine(1) & vbTab & "【追加成功】"
Else
strResultLine = "[N G]" & vbTab & arrInputFileLine(1) & vbTab & arrLine(1) & vbTab & "【追加失敗】"
strErrLogLine = strErrLogLine & arrInputFileLine(0) & Replace(strResultLine, "[N G]", "") & vbCrLf
End If
End If
End If
If Left(strResultLine, 1) = "[" Then
Call funPutLog(strResultFilePath, strResultLine, vbYes)
End If
End If
Erase arrLine
Loop
Set objFileStream = Nothing

'グループメンバの削除
Call funPutLog(strResultFilePath, "【" & arrInputFileLine(0) & "グループメンバ同期-削除分】", vbYes)
Set objFileStream = objFSO.OpentextFile(strDeleteUsersFilePath)
Do Until objFileStream.AtEndOfStream = True
strLine = objFileStream.ReadLine
strResultLine = ""
If strLine <> "" Then
arrLine = Split(strLine, vbTab)
If (Ubound(arrLine) = 1) And (arrLine(1) <> "") Then
strMemberDN = funUserDNSearch(arrLine(1), strDomainDN, cntDomainController)
If strMemberDN = "" Then
strResultLine = "[N G]" & vbTab & arrInputFileLine(1) & vbTab & arrLine(1) & vbTab & "【削除失敗】"
strErrLogLine = strErrLogLine & arrInputFileLine(0) & Replace(strResultLine, "[N G]", "") & vbCrLf
Else
lngResult = funGroupMemberDelete(strRepGroupDN, strMemberDN, cntDomainController)
If lngResult = vbOK Then
strResultLine = "[O K]" & vbTab & arrInputFileLine(1) & vbTab & arrLine(1) & vbTab & "【削除成功】"
Else
strResultLine = "[N G]" & vbTab & arrInputFileLine(1) & vbTab & arrLine(1) & vbTab & "【削除失敗】"
strErrLogLine = strErrLogLine & arrInputFileLine(0) & Replace(strResultLine, "[N G]", "") & vbCrLf
End If
End If
End If
If Left(strResultLine, 1) = "[" Then
Call funPutLog(strResultFilePath, strResultLine, vbYes)
End If
End If
Erase arrLine
Loop
Set objFileStream = Nothing

'グループメンバリストのバックアップ
strGroupMemberBackupPath = funGetScriptPath() & "\Log\" & strDate & arrInputFileLine(1) & ".zip"
Call funCompressFile(strRepGroupMemberFilePath, vbYes, vbYes)
Call funRenameFile(strRepGroupMemberFilePath & ".zip", strGroupMemberBackupPath)

'中間ファイルの削除
Call funDeleteFile(strGroupMemberFilePath)
Call funDeleteFile(strAddUsersFilePath)
Call funDeleteFile(strDeleteUsersFilePath)
End If
Loop

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

'ログファイルのバックアップ
Call funCompressFile(strResultFilePath, vbYes, vbYes)
Call funRenameFile(strResultFilePath & ".zip", strResultFileBackupPath)

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

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

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

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

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

End Function

'======================================================================
'【関数】funGetDomainDN
'【機能】自ドメインのDNを取得する
'【返値】ユーザの所属ドメインのDN
'======================================================================
Function funGetDomainDN()

'変数定義
Dim objRootDSE 'デフォルトコンテキストオブジェクト

'オブジェクトの定義
Set objRootDSE = GetObject("LDAP://RootDSE")

'ドメインDNの取得
funGetDomainDN = objRootDSE.Get("defaultNamingContext")

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

End Function

'======================================================================
'【関数】funUserDNSearch
'【機能】SAMアカウントネームを読み込み、ユーザのDNを返す
'【変数】strUserName : SAMアカウントネーム
' strDomainDN : 検索ドメインのDN
' strDomainController ：使用ドメインコントローラ
'【返値】ユーザのDN（ユーザが見つからなかった場合はNullを返す）
'======================================================================
Function funUserDNSearch(strUserName, strDomainDN, strDomainController)

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

Dim strUserDN 'ユーザのDN

'初期設定
funUserDNSearch = ""

'オブジェクトの定義
Set objConnection = CreateObject("ADODB.Connection")
Set objcommand = CreateObject("ADODB.Command")

'コネクションの確立
objConnection.Provider = "ADsDSOObject"
objConnection.Open "Active Directory Provider"
Set objCommand.ActiveConnection = objConnection
objCommand.Properties("Page Size") = 200000

'コマンドの定義
objCommand.CommandText = "Select ADsPath From 'LDAP://" & strDomainController & "/" & strDomainDN & "' Where sAMAccountName='" & strUserName & "'"

'コマンドの実行
On Error Resume Next
Set objRecordSet = objCommand.Execute

'ユーザオブジェクトのDNの取得
strUserDN = objRecordSet.Fields("ADsPath").Value
If Err.Number = 0 Then
funUserDNSearch = Replace(strUserDN, "LDAP://" & strDomainController & "/", "")
End If
On Error Goto 0

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

End Function

'======================================================================
'【関数】subADGroupMemberListup
'【機能】AD上のグループのメンバをリストアップする（グループ名を指定）
'【変数】strGroupDN ：グループのOUのDN
' strResultFileName ：結果ファイルのパス
' strDomainController ：使用ドメインコントローラ
'======================================================================
Sub subADGroupMemberListup(strGroupDN, strResultFileName, strDomainController)

'変数定義
Dim objFSO 'ファイルシステムオブジェクト
Dim objResultFile '結果ファイルオブジェクト
Dim objConnection 'ドメイン接続オブジェクト
Dim objCommand '検索コマンドオブジェクト
Dim objRecordSet '検索結果コレクション
Dim objGroup 'グループオブジェクト
Dim objMember 'グループメンバオブジェクト

Dim i 'グループメンバ数のカウンタ

'オブジェクトの定義
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objResultFile = objFSO.OpenTextFile(strResultFileName, 8, True)
Set objConnection = CreateObject("ADODB.Connection")
Set objCommand = CreateObject("ADODB.Command")
objConnection.Provider = "ADsDSOObject"
objConnection.Open "Active Directory Provider"
Set objCommand.ActiveConnection = objConnection
objCommand.Properties("Page Size") = 200000

'検索コマンドの実行
objCommand.CommandText = "SELECT ADsPath FROM 'LDAP://" & strDomainController & "/" & strGroupDN & "'" & " WHERE objectCategory='group'"
Set objRecordSet = objCommand.Execute

'グループメンバを出力
With objRecordSet
Do Until .EOF
Set objGroup = GetObject(.Fields("ADsPath").Value)
i = 0
For Each objMember In objGroup.Members
objResultFile.WriteLine objGroup.sAMAccountName & vbTab & objMember.sAMAccountName
i = i + 1
Next

Set objMember = Nothing

If i = 0 Then
objResultFile.WriteLine objGroup.sAMAccountName & vbTab & vbNullString
End If

Set objGroup = Nothing
.MoveNext
Loop
End With

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

End Sub

'======================================================================
'【関数】subPrimaryGroupMemberListup
'【機能】ADのプライマリグループのメンバをリストアップする(グループ名を指定)
'【変数】strGroupName ：グループ名
' [対象グループ]
' Domain Users, Domain Computers, Domain Controllers
' strResultFileName ：結果ファイルのパス(グループ名とユーザ名はTab区切り)
' strDomainDN ：ドメインのDN
' strDomainController ：使用ドメインコントローラ
'======================================================================
Sub subPrimaryGroupMemberListup(strGroupName, strResultFileName, strDomainDN, strDomainController)

'変数定義
Dim objFSO 'ファイルシステムオブジェクト
Dim objResultFile '結果ファイルオブジェクト
Dim objConnection 'ドメイン接続オブジェクト
Dim objCommand '検索コマンドオブジェクト
Dim objRecordSet '検索結果コレクション

Dim lngPrimaryGroupRID 'プライマリグループのRID

Dim i 'グループメンバ数のカウンタ

Select Case UCase(strGroupName)
Case "DOMAIN USERS"
lngPrimaryGroupRID = 513
Case "DOMAIN COMPUTERS"
lngPrimaryGourpRID = 515
Case "DOMAIN CONTROLLERS"
lngPrimaryGroupRID = 516
Case Else
Exit Sub
End Select

'検索コマンドの実行
objCommand.CommandText = "SELECT sAMAccountName FROM 'LDAP://" & strDomainController & "/" & strDomainDN & "'" & " WHERE primaryGroupID='" & lngPrimaryGroupRID & "'"
Set objRecordSet = objCommand.Execute

'グループメンバを出力
With objRecordSet
If .BOF <> True Then
.MoveFirst
End If
Do Until .EOF
objResultFile.WriteLine strGroupName & vbTab & .Fields("sAMAccountName").Value
.MoveNext
Loop
End With

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

End Sub

'======================================================================
'【関数】subExecute_GroupDiff
'【機能】グループメンバファイル2ファイルの行一致検索
'【変数】strSourceFileName : 一致検索基準ファイル(グループ名とメンバはTab区切り)
' strTargetFileName : 一致検索対象ファイル(グループ名とメンバはTab区切り)
' strSResultFileName : 一致検索基準ファイルのみに含まれる行の出力用(グループ名とメンバはTab区切り)
' strTResultFileName : 一致検索検索ファイルのみに含まれる行の出力用(グループ名とメンバはTab区切り)
'======================================================================
Sub subExecute_GroupDiff(strSourceFileName, strTargetFileName, strSResultFileName, strTResultFileName)

'変数定義
Dim objFSO 'ファイルシステムオブジェクト
Dim objSourceFile '基準ファイルオブジェクト
Dim objTargetFile '対象ファイルオブジェクト
Dim objSResultFile '結果ファイルオブジェクト
Dim objTResultFile '結果ファイルオブジェクト
Dim objSourceRecordSet '基準ファイルのレコードオブジェクト
Dim objTargetRecordSet '対象ファイルのレコードオブジェクト

Dim strSourceLine '基準ファイルの1行
Dim strTargetLine '対象ファイルの1行
Dim lngTarget '対象ファイルの処理済行数
Dim lngTargetTemp '対象ファイルの読み込み行
Dim arrSourceGroup '基準グループのグループ名とメンバの配列
Dim arrTargetGroup '対象グループのグループ名とメンバの配列
Dim lngResult '比較結果
Dim lngState '一致の有無
Dim i 'ダミーインデックス

'レコードセットの文字列
Const cntVarChar = 200
'一行の最大サイズ
Const cntMaxLine = 1000

'変数の初期化
lngTarget = 0

'オブジェクトの定義
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objSourceFile = objFSO.OpenTextFile(strSourceFileName)
Set objTargetFile = objFSO.OpenTextFile(strTargetFileName)
Set objSResultFile = objFSO.OpenTextFile(strSResultFileName, 8, True)
Set objTResultFile = objFSO.OpenTextFile(strTResultFileName, 8, True)
Set objSourceRecordSet = CreateObject("ADODB.Recordset")
With objSourceRecordSet.Fields
.Append "Group", cntVarChar, cntMaxLine
.Append "Member", cntVarChar, cntMaxLine
End With
Set objTargetRecordSet = CreateObject("ADODB.Recordset")
With objTargetRecordSet.Fields
.Append "Group", cntVarChar, cntMaxLine
.Append "Member", cntVarChar, cntMaxLine
End With

'入力ファイルをレコードセットに読み込み
objSourceRecordSet.Open
Do Until objSourceFile.AtEndOfStream = True
strSourceLine = objSourceFile.ReadLine
arrSourceGroup = Split(strSourceLine, vbTab)
objSourceRecordSet.AddNew
objSourceRecordSet("Group") = arrSourceGroup(0)
objSourceRecordSet("Member") = arrSourceGroup(1)
objSourceRecordSet.Update
Erase arrSourceGroup
Loop
objTargetRecordSet.Open
Do Until objTargetFile.AtEndOfStream = True
strTargetLine = objTargetFile.ReadLine
arrTargetGroup = Split(strTargetLine, vbTab)
objTargetRecordSet.AddNew
objTargetRecordSet("Group") = arrTargetGroup(0)
objTargetRecordSet("Member") = arrTargetGroup(1)
objTargetRecordSet.Update
Erase arrTargetGroup
Loop
objSourceRecordSet.Sort = "Member ASC"
objTargetRecordSet.Sort = "Member ASC"

'一致比較
If objSourceRecordSet.BOF <> True Then
objSourceRecordSet.MoveFirst
End If
With objTargetRecordSet
Do Until objSourceRecordSet.EOF
'基準レコードの読み込み
strSourceLine = objSourceRecordSet("Member").Value

'変数の初期化
lngState = 0

'対象レコードの一行目に移動
If .BOF <> True Then
.MoveFirst
End If

'比較済みの行まで処理をスキップ
lngTargetTemp = lngTarget + 1
.Move lngTarget

'対象レコードを1行ずつ読み込んで比較
Do Until .EOF
'対象ファイルの1行を読み込み
strTargetLine = objTargetRecordSet("Member").Value
'比較
lngResult = StrComp(strSourceLine, strTargetLine, vbTextCompare)
If lngResult = 0 Then '一致の場合
lngState = 1
Exit Do
End If

lngTargetTemp = lngTargetTemp + 1
.MoveNext
Loop

'結果ファイルへの書き込み
If lngState = 0 Then '一致行が見つからなかった場合
strSourceLine = objSourceRecordSet("Group").Value & vbTab & objSourceRecordSet("Member").Value
objSResultFile.WriteLine(strSourceLine)
Else '一致行が見つかった場合
If lngTargetTemp - lngTarget > 1 Then
'対象レコードの一行目に移動
If .BOF <> True Then
.MoveFirst
End If

'比較済みの行は処理をスキップ
i = lngTarget + 1
.Move lngTarget

'対象レコード内の不一致行を書き込み
Do Until i = lngTargetTemp
strTargetLine = objTargetRecordSet("Group").Value & vbTab & objTargetRecordSet("Member").Value
objTResultFile.WriteLine(strTargetLine)
.MoveNext
i = i + 1
Loop
End If

'対象レコードの処理済の行数のセット
lngTarget = lngTargetTemp
End If
objSourceRecordSet.MoveNext
Loop

'対象レコードの残りの行を書き出す
'対象レコードの一行目に移動
If .BOF <> True Then
.MoveFirst
End If

'処理済みの行は処理をスキップ
i = lngTarget + 1
.Move lngTarget

'対象レコード内の残りの行を書き込み
Do Until .EOF
strTargetLine = objTargetRecordSet("Group").Value & vbTab & objTargetRecordSet("Member").Value
objTResultFile.WriteLine(strTargetLine)
.MoveNext
Loop
End With

'オブジェクトの開放
Set objSourceRecordSet = Nothing
Set objTargetRecordSet = Nothing
Set objSourceFile = Nothing
Set objTargetFile = Nothing
Set objSResultFile = Nothing
Set objTResultFile = Nothing
Set objFSO = Nothing

End Sub

'======================================================================
'【関数】funGroupMemberAdd
'【機能】グループにメンバを追加する
'【変数】strGroupDN ：グループのDN
' strMemberDN ：グループメンバのDN
' strDomainController ：使用ドメインコントローラ
'【返値】vbOK ：成功
' vbCancel ：失敗
'======================================================================
Function funGroupMemberAdd(strGroupDN, strMemberDN, strDomainController)

'変数定義
Dim objGroup 'グループオブジェクト

'オブジェクトの定義
On Error Resume Next
Set objGroup = Getobject("LDAP://" & strDomainController & "/" & strGroupDN)

'メンバの追加
objGroup.Add("LDAP://" & strDomainController & "/" & strMemberDN)

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

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

End Function

'======================================================================
'【関数】funGroupMemberDelete
'【機能】グループからメンバを削除する
'【変数】strGroupDN ：グループのDN
' strMemberDN ：グループメンバのDN
' strDomainController ：使用ドメインコントローラ
'【返値】vbOK ：成功
' vbCancel ：失敗
'======================================================================
Function funGroupMemberDelete(strGroupDN, strMemberDN, strDomainController)

'変数定義
Dim objGroup 'グループオブジェクト

'オブジェクトの定義
On Error Resume Next
Set objGroup = Getobject("LDAP://" & strDomainController & "/" & strGroupDN)

'メンバの追加
objGroup.Remove("LDAP://" & strDomainController & "/" & strMemberDN)

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

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

End Function

'======================================================================
'【関数】funPutLog
'【機能】ログを書き込み
'【変数】strLogFileName : ログファイル名
' strMessage ：ログメッセージ
' lngMode ：追記モード
' vbYes 内容を追記
' vbNo 内容を新規に追加
'【返値】vbOK ：成功
' vbCancel ：失敗
'======================================================================
Function funPutLog(strLogFileName, strMessage, lngMode)

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

'オブジェクトの定義
On Error Resume Next
Set objFSO = CreateObject("Scripting.FileSystemObject")
If lngMode = vbYes Then
Set objLogFile = objFSO.OpenTextFile(strLogFileName, 8, True)
Else
Set objLogFile = objFSO.OpenTextFile(strLogFileName, 2, True)
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

'======================================================================
'【関数】funDeleteFile
'【機能】ファイルの削除
'【変数】strFileName : ファイル名
'【返値】vbOK : 成功
' vbAbort : 失敗
'======================================================================
Function funDeleteFile(strFileName)

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

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

'存在チェック
On Error Resume Next
objFSO.DeleteFile(strFileName)
If Err.Number = 0 Then
funDeleteFile = vbOK
Else
funDeleteFile = vbAbort
End If
On Error Goto 0

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

End Function

'======================================================================
'【関数】funCompressFile
'【機能】指定されたファイルをZIP圧縮して同フォルダに保存する
'【変数】strSourceFilePath ：圧縮対象ファイルのフルパス
' lngOverWrite ：同フォルダに同名のZIPファイルがあった場合
' vbYes 同名のZIPファイルを上書き
' vbNo 同名のZIPファイルがある場合は未処理
' lngDelete ：圧縮成功後に元ファイルを削除するか
' vbYes 圧縮成功後削除
' vbNo 削除しない
'【返値】vbOK ：成功
' vbCancel ：失敗 Or 未処理
' vbAbort ：指定ファイルが存在しない
'======================================================================
Function funCompressFile(strSourceFilePath, lngOverWrite, lngDelete)

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

Dim strParentFolderPath '指定ファイルの親フォルダ
Dim strFileBaseName '指定ファイルのベース名
Dim strZIPFilePath 'ZIPファイルのパス
Dim strSourceFileName '指定ファイルのファイル名
Dim zFolder 'ZIPファイルのお約束
Dim zFolderItem 'ZIPファイルのお約束
Dim sFolder 'ZIPファイルのお約束
Dim sFolderItem 'ZIPファイルのお約束
Dim strZIPdata 'ZIPファイルのお約束

'オブジェクトの定義
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objShell = CreateObject("Shell.Application")
Set objCOMObject = CreateObject("WScript.Shell.1")

'初期設定
On Error Resume Next
strZIPdata = "PK" & Chr(5) & Chr(6) & String(18,0)
funCompressFile = vbOK

'ファイルの存在確認
If objFSO.FileExists(strSourceFilePath) = False Then
funCompressFile = vbAbort
End If

'ZIPファイルの存在確認
If funCompressFile = vbOK Then
strParentFolderPath = objFSO.GetParentFolderName(strSourceFilePath)
' strFileBaseName = objFSO.GetBaseName(strSourceFilePath)
strFileBaseName = objFSO.GetFileName(strSourceFilePath)
strZIPFilePath = strParentFolderPath & "\" & strFileBaseName & ".zip"
If objFSO.FileExists(strZIPFilePath) = True Then
If lngOverWrite = vbYes Then
objFSO.DeleteFile strZIPFilePath
If Err.Number <> 0 Then
Err.Clear
funCompressFile = vbCancel
End If
Else
funCompressFile = vbCancel
End If
End If
End If

'指定ファイルを圧縮
If funCompressFile = vbOK Then
funCompressFile = vbCancel

'ZIPファイルを作成
objFSO.CreateTextFile(strZIPFilePath, False).Write strZIPdata
Set zFolder = objShell.NameSpace(strZIPFilePath)

'圧縮処理
strSourceFileName = objFSO.GetFileName(strSourceFilePath)
Set sFolder = objShell.NameSpace(strParentFolderPath)
If Not (sFolder Is Nothing) Then
Set sFolderItem = sFolder.ParseName(strSourceFileName)
If Not (sFolderItem Is Nothing) Then
Set zFolderItem = zFolder.ParseName(strSourceFileName)
If zFolderItem Is Nothing Then
zFolder.CopyHere sFolderItem
Do
Err.Clear
' objCOMObject.PopUp strSourceFilePath, 1, "圧縮しています"
WScript.Sleep(1000)
objFSO.MoveFile strZIPFilePath, strZIPFilePath
Loop While Err.Number <> 0
WScript.Sleep(100)
If (objFSO.FileExists(strZIPFilePath) = True) And (objFSO.GetFile(strZIPFile).Size > 0) Then
funCompressFile = vbOK
End If
End If
End If
End If
End If

'オブジェクトの開放
Set zFolderItem = Nothing
Set zFolder = Nothing
Set sFolderItem = Nothing
Set sFolder = Nothing
Set objShell = Nothing

'圧縮元ファイルを削除
If (funCompressFile = vbOK) And (lngDelete = vbYes) Then
Do
Err.Clear
WScript.Sleep(100)
objFSO.MoveFile strSourceFilePath, strSourceFilePath
Loop While Err.Number <> 0
WScript.Sleep(100)
objFSO.DeleteFile strSourceFilePath
If Err.Number <> 0 Then
funCompressFile = vbCancel
End If
End If

On Error Goto 0

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

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

'======================================================================
'【関数】funGetEnvironment
'【機能】環境変数を取得
'【変数】strEnv ：環境変数名
'【返値】環境変数の値（取得できなかった場合は空白）
'======================================================================
Function funGetEnvironment(strEnv)

'変数定義
Dim WshShell

Dim strEnvValue

'オブジェクトの定義
Set WshShell = CreateObject("WScript.Shell")

'環境変数の取得
On Error Resume Next
strEnvValue = WshShell.Environment("Process")(strEnv)
If Err.Number = 0 Then
funGetEnvironment = strEnvValue
End If
On Error Goto 0

'オブジェクトの開放
Set WshShell = 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

2019-04-11

コンピューターOU移動

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 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

'変数定義
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

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

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

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

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

End Function

'変数定義
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

2019-04-11

robocopyバッチファイル

DATコピーを実施します。

@ECHO OFF
@ECHO.

REM **************** 移行フォルダ名指定ファイル ************************
set host=%COMPUTERNAME%
if "%1"=="" (set dirlist=%host%.txt) else (set dirlist=%1)

REM **************** カレントディレクトリ変更 ************************
set dirpath=%~p0
set c_path=%CD%
cd "%dirpath%"

REM **************** ログファイル指定 ************************
set logdir=log
if not exist %logdir% (mkdir %logdir%)
set date2=%date:~-10%
set today=%date2:~0,4%%date2:~5,2%%date2:~8,2%
set now=%time:~0,2%%time:~3,2%
set now=%now: =0%
for %%i IN (%dirlist%) DO @set fname=%%~ni
set logfile=%logdir%\sabun_%fname%-%today%-%now%.log

REM **************** 処理開始 ************************
@ECHO %DATE% %TIME% ***** [%host%] サーバデータ移行処開始 ***** > %logfile%
@ECHO %DATE% %TIME% [%host%] ***** サーバデータ移行処開始 *****
if not exist %dirlist% (@ECHO エラー：移行フォルダリスト [%dirlist%] がありません)
if not exist %dirlist% (@ECHO エラー：移行フォルダリスト [%dirlist%] がありません >> %logfile% & goto end )

REM **************** robocopyのPATHとしてカレントディレクトリを追加 ************************
set PATH="%CD%";%PATH%
if not exist "robocopy.exe" (@ECHO エラー： [robocopy.exe ] コマンドがバッチファイルと同一ディレクトリにありません >> %logfile% & goto end )

REM **************** データコピー開始 *************************
@ECHO ■データコピーを開始します。■ >> %logfile%

REM スペースがあるファイル名に対応させるためデリミッタはTAB
for /F "eol=; TOKENS=1,2,3 delims= " %%A in (%dirlist%) do (
if not exist %%A (@ECHO エラー：[%%A] コピー元ファルダが存在しません && @ECHO エラー:[%%A] コピー元ファルダが存在しません >> %logfile% 2>&1) else (
@ECHO. && @ECHO [%%A] を [%%B] へコピーしています・・・ & robocopy "%%A" "%%B" /COPY:DAT %%C /S /E /MIR /FP /TS /R:0 /NP /V /LOG+:%logfile%)
)
@ECHO. >> %logfile% 2>&1
)

@ECHO ■データコピーを終了します。■ >> %logfile%

:end
@ECHO %DATE% %TIME% ***** [%host%] データ移行処理終了 ***** >> %logfile%
@ECHO %DATE% %TIME% ***** [%host%] データ移行処理終了 *****

REM **************** カレントディレクトリを戻す ************************
cd %c_path%
@ECHO ON