'
' 受信者一括インポートスクリプト
'
' メールボックスが有効なユーザ、メールが有効なユーザを作成します。
' メールボックスの場合は転送先アドレスと両方に配信するかどうかを指定できます。
' 転送先は con0-エイリアス, con1-エイリアス, ... という名前で作成し、
' alt-エイリアス という名前のグループに入れて代理受信者に設定します。

Option Explicit

' デフォルトのインポートファイル名
Const strDefaultImportFileName = "ImportRecip.csv"
' デフォルトのログファイル
Const strDefaultLogFileName = "ImportRecip.log"

' 組織の DNS名
Const strDefaultOrganizationDNSName = "exchange-admin.biz"

' 組織名
Const strDefaultOrganizationName = "EXCHANGE-ADMIN"

' 管理グループ名
Const strDefaultAdministrativeGroupName = "最初の管理グループ"
' Exchange Server 2003 のデフォルトは "first administrative group"

' ストレージグループ名
Const strDefaultStorageGroupName = "最初のストレージ グループ"

' 最大転送アドレス数(0番目を含まない)
Const MaxForwardingAddresses = 9

Dim strNeededColumnHeader
' インポート用 CSVファイルの１行目を、次の項目名並びと同じにしてください(" を除く)
' 使用する項目名並び
strNeededColumnHeader = _
    "alias,password,external_address,ServerName," & _
    "LastName,FirstName,DisplayName,Department,Title," & _
    "DeliverBoth,ForwardingAddress0," & _
    "ForwardingAddress1,ForwardingAddress2,ForwardingAddress3," & _
    "ForwardingAddress4,ForwardingAddress5,ForwardingAddress6," & _
    "ForwardingAddress7,ForwardingAddress8,ForwardingAddress9"

' 意味は
'
' エイリアス(アカウント名を兼ねる)
' パスワード(新規作成の場合のみ設定)
' 外部アドレス(メールが有効なユーザの場合)
' サーバ名(メールボックスが有効なユーザの場合)
' 名字
' 名前
' 表示名
' 部署
' 役職
' メッセージを転送先とメールボックスの両方に配信する(1 or 0)
' 転送先アドレス0
' 転送先アドレス1
' 転送先アドレス2
'      ・
'      ・
'      ・

Dim objFileSystemObject
Dim objFile
Dim mapColumnNameIndex
Dim strColumnNames
Dim strLogFileName

Dim strDelivaryDomain
Dim strServerName
Dim strOrganizationDNSName
Dim strDomainPath
Dim strOrganizationName
Dim strAdministrativeGroupName
Dim strStorageGroupName
Dim strStoreName
Dim nMailEnabled
Dim nMailBoxEnabled
Dim nMailBoxMustMove
Dim nMailBoxMustDelete

strLogFileName = strDefaultLogFileName
strOrganizationDNSName = strDefaultOrganizationDNSName
strDomainPath = "DC=" & Replace(strOrganizationDNSName, ".", ",DC=")
strOrganizationName = strDefaultOrganizationName
strAdministrativeGroupName = strDefaultAdministrativeGroupName
strStorageGroupName = strDefaultStorageGroupName
nMailEnabled = 0
nMailBoxEnabled = 0
nMailBoxMustMove = 0
nMailBoxMustDelete = 0

Call Main

' メイン
Sub Main()
    Dim strFilePath
    Dim strLine
    Dim strLineTop
    Dim bHeaderLoaded
    Dim aHeader
    Dim i
    Dim aLine
    
    ' ファイル名の取得
    strFilePath = GetImportFileName()
    If strFilePath = "" Then
        Call Cleanup()
        Exit Sub
    End If
    
    ' ファイルシステムオブジェクト・テキストストリームオブジェクト作成
    Set objFileSystemObject = Nothing
    Set objFile = Nothing
    Set objFileSystemObject = CreateObject("Scripting.FileSystemObject")
    Set objFile = objFileSystemObject.OpenTextFile(strFilePath)
    If objFileSystemObject Is Nothing Or objFile Is Nothing Then
        Call Cleanup()
        MsgBox "ファイルシステムオブジェクトまたはテキストストリームオブジェクト作成失敗"
        Exit Sub
    End If
    
    LogWriteLine ""
    LogWriteLine ""
    LogWriteLine ""
    LogWriteLine "開始 " & Now  
    ' ヘッダーの読み込み
    bHeaderLoaded = False
    Do Until objFile.AtEndOfStream
        strLine = objFile.ReadLine
        If LoadHeader(strLine, aHeader) = True Then
            bHeaderLoaded = True
            Exit Do
        End If
    Loop
    
    ' ヘッダーが無かったら終了
    If bHeaderLoaded = False Then
        Call Cleanup()
        MsgBox "ヘッダー無し"
        Exit Sub
    End If
    
    ' 項目名−インデックスマップの作成
    Set mapColumnNameIndex = Nothing
    Set mapColumnNameIndex = CreateObject("Scripting.Dictionary")
    If mapColumnNameIndex Is Nothing Then
        Call Cleanup()
        MsgBox "項目名−インデックスマップの(オブジェクト)作成失敗"
        Exit Sub
    End If
    
    For i = 0 To Ubound(aHeader) Step 1
        mapColumnNameIndex.Add aHeader(i), i
    Next
    Erase aHeader
    
    strColumnNames = strNeededColumnHeader
    
    ' データ行の読み込み
    Do Until objFile.AtEndOfStream
        strLine = objFile.ReadLine
        If IsComment(strLine) = False Then
            aLine = Split(strLine, ",")
            If IsArray(aLine) Then
                Call DoUpdateRecipient(aLine)
                Erase aLine
            End If
        End If
    Loop
    
    LogWriteLine "-------------------------------------------------------------------------------"
    LogWriteLine "終了 " & Now  
    LogWriteLine "メールが有効なユーザー：" & CStr(nMailEnabled)
    LogWriteLine "メールボックス：" & CStr(nMailBoxEnabled)
    LogWriteLine "移動すべきメールボックス：" & CStr(nMailBoxMustMove)
    LogWriteLine "削除すべきメールボックス：" & CStr(nMailBoxMustDelete)
    LogWriteLine "-------------------------------------------------------------------------------"
    LogWriteLine ""
    Call Cleanup()
    MsgBox "終了"
End Sub

' 終了処理
Sub Cleanup()
    On Error Resume Next
    Set mapColumnNameIndex = Nothing
    Set objFile = Nothing
    Set objFileSystemObject = Nothing
End Sub

' ログ出力
Sub LogWrite(str)
    Dim objText
    Set objText = objFileSystemObject.OpenTextFile(strLogFileName, 8, True)
    objText.Write str
    objText.Close
    Set objText = Nothing
End Sub

Sub LogWriteLine(str)
    LogWrite(str & vbCrLf)
End Sub

' ファイル名の取得
Function GetImportFileName()
    Dim strImportFile
    
    ' プロンプト
    strImportFile = InputBox("インポートファイル名を入力してください", _
        "インポートファイル名の入力(ImportRecip)", strDefaultImportFileName)
    
    If Len(strImportFile) > 5 Then
        strLogFileName = Left(strImportFile, Len(strImportFile) - 4) & ".log"
    End If
    
    GetImportFileName = strImportFile
End Function

' ヘッダー行の読み込み
Function LoadHeader(strLine, aHeader)
    If IsComment(strLine) = True Then
        LoadHeader = False
        Exit Function
    End If
    
    aHeader = Split(strLine, ",")
    If IsArray(aHeader) = False Then
        LoadHeader = False
    End If
    
    LoadHeader = True
End Function

' コメント行の判定
Function IsComment(strLine)
    If LTrim(strLine) = "" Then
        IsComment = True
        Exit Function
    ElseIf Left(LTrim(strLine), 1) = "'" Then
        IsComment = True
        Exit Function
    End If
End Function

Sub DoUpdateRecipient(aLine)
    Dim strCallingSequence
    Dim strHeader
    Dim aColumnName
    Dim i
    
    aColumnName = Split(strColumnNames, ",")
    
    strCallingSequence = "Call UpdateRecipient("""
    For i = 0 To UBound(aColumnName) Step 1
        If i <> 0 Then
            strCallingSequence = strCallingSequence & """, """
        End If
        If mapColumnNameIndex.Exists(aColumnName(i)) Then
            If UBound(aLine) >= mapColumnNameIndex.Item(aColumnName(i)) Then
                strCallingSequence = strCallingSequence & aLine(mapColumnNameIndex.Item(aColumnName(i)))
            End If
        Else
            ' 必要な項目が無い
            MsgBox "必要な項目が無い"
            Exit Sub
        End If
    Next
    strCallingSequence = strCallingSequence & """)"
    
    Erase aColumnName
    Execute strCallingSequence
End Sub

' 受信者の更新
Sub UpdateRecipient(alias,password,external_address,ServerName,LastName,FirstName, _
    DisplayName,Department,Title,DeliverBoth,ForwardingAddress0,ForwardingAddress1, _
    ForwardingAddress2,ForwardingAddress3,ForwardingAddress4,ForwardingAddress5, _
    ForwardingAddress6,ForwardingAddress7,ForwardingAddress8,ForwardingAddress9)
    
    Dim objPrimitiveUser
    Dim objUser
    Dim objContainer
    Dim rn
    Dim objMailRecipUser
    Dim objMailBox
    Dim HomeMDBURL
    Dim objPrimitiveGroup
    Dim objGroup
    Dim objPrimitiveContact
    Dim objMailRecipGroup
    Dim objMailRecipContact
    Dim strContactPath
    Dim aProxyAddresses
    Dim varProxy
    Dim bFound
    Dim strAppendAddress
    Dim i
    Dim param
    Dim bMemberExists

    If alias = "" Then
        Exit Sub
    End If
    LogWriteLine "-------------------------------------------------------------------------------"
    LogWriteLine "開始:" & Now & " " & alias

    rn = "CN=" & alias
    Set objContainer = GetObject("LDAP://CN=Users," + strDomainPath)
    
    ' ユーザーオブジェクト
    LogWriteLine "ユーザーオブジェクト"
    On Error Resume Next
    Set objPrimitiveUser = Nothing
    Set objPrimitiveUser = objContainer.GetObject("user", rn)
    If objPrimitiveUser Is Nothing Then
        ' ユーザが見つからない
        On Error GoTo 0
        LogWriteLine "user オブジェクトを作成"
        Set objPrimitiveUser = objContainer.Create("user", rn)
        objPrimitiveUser.Put "samAccountName", alias
        objPrimitiveUser.Put "userAccountControl", 66048
        objPrimitiveUser.Put "userPrincipalName", alias
        objPrimitiveUser.Put "sn", LastName
        objPrimitiveUser.Put "givenName", FirstName
        objPrimitiveUser.Put "description", DisplayName
        objPrimitiveUser.Put "displayName", DisplayName
        
        LogWriteLine "user オブジェクトをコミット"
        objPrimitiveUser.SetInfo

        Set objUser = objPrimitiveUser  ' IADsUser を使う
        LogWriteLine "パスワードを設定"
        objUser.SetPassword password
    Else
        On Error GoTo 0
        LogWriteLine "user オブジェクトを取得"
        objPrimitiveUser.Put "userPrincipalName", alias
        objPrimitiveUser.Put "sn", LastName
        objPrimitiveUser.Put "givenName", FirstName
        objPrimitiveUser.Put "description", DisplayName
        objPrimitiveUser.Put "displayName", DisplayName
        
        LogWriteLine "user オブジェクトをコミット"
        objPrimitiveUser.SetInfo
        
        Set objUser = objPrimitiveUser  ' IADsUser を使う
    End If
    
    If Department <> "" Then
        objPrimitiveUser.Put "department", Department                   ' 部署
        objPrimitiveUser.Put "physicalDeliveryOfficeName", Department   ' 事業所
    Else
        objPrimitiveUser.PutEx 1, "department", ""
        objPrimitiveUser.PutEx 1, "physicalDeliveryOfficeName", ""
    End If
    If Title <> "" Then
        objPrimitiveUser.Put "title", Title                             ' 役職
    Else
        objPrimitiveUser.PutEx 1, "title", ""
    End If
    
    objPrimitiveUser.SetInfo
    Set objMailRecipUser = objPrimitiveUser
    
    ' グループと連絡先の掃除
    
    ' 転送アドレスループ
    For i = 0 To MaxForwardingAddresses Step 1
        rn = "CN=con" & CStr(i) & "-" & alias
        ' 転送用連絡先を削除する
        On Error Resume Next
        Set objPrimitiveContact = Nothing
        Set objPrimitiveContact = objContainer.GetObject("contact", rn)
        If Not objPrimitiveContact Is Nothing Then
            ' 連絡先があった
            On Error GoTo 0
            LogWriteLine "転送用連絡先" & CStr(i) & "を(一旦?)削除"
            objContainer.Delete objPrimitiveContact.Class, objPrimitiveContact.Name
            Set objPrimitiveContact = Nothing
        End If
        On Error GoTo 0
    Next
    
    ' 転送用配布リストを削除
    rn = "CN=alt-" & alias
    On Error Resume Next
    Set objPrimitiveGroup = Nothing
    Set objPrimitiveGroup = objContainer.GetObject("group", rn)
    If Not objPrimitiveGroup Is Nothing Then
        On Error GoTo 0
        LogWriteLine "転送用配布グループを(一旦?)削除"
        objContainer.Delete objPrimitiveGroup.Class, objPrimitiveGroup.Name
    End If
    On Error GoTo 0
    
    ' メールボックスが必要かどうか
    If external_address <> "" Then
        '-------------------------------------------
        ' メールが有効なユーザー(メールボックス無し)
        '-------------------------------------------
        LogWriteLine "メールが有効なユーザー"
        Set objMailBox = objUser
        ' メールボックスが有効な場合は削除する(かな？)
        If objMailBox.HomeMDB <> "" Then
            ' メールボックスを削除
            LogWriteLine "削除する必要があるメールボックス"
            'objMailBox.DeleteMailBox
            nMailBoxMustDelete = nMailBoxMustDelete + 1
        Else
        
            ' メールを無効にする
            LogWriteLine "メールを一旦無効にする"
            On Error Resume Next
            objMailRecipUser.MailDisable
            On Error GoTo 0
            ' メールを有効にする
            objMailRecipUser.Alias = alias
            LogWriteLine "メールを有効にする"
            objMailRecipUser.MailEnable("SMTP:" & external_address)
            LogWriteLine "外部アドレスを設定"
            objMailRecipUser.SMTPEmail = external_address
            
            ' SecondaryProxyAddresses に内部のアドレスを入れる
            LogWriteLine "内部アドレスを追加"
            aProxyAddresses = objMailRecipUser.ProxyAddresses
            bFound = False
            strAppendAddress = "smtp:" & alias & "@" & strOrganizationDNSName
            If VarType(aProxyAddresses) = 8204 Then ' Variant 型配列
                For Each varProxy In aProxyAddresses
                    If UCase(CStr(varProxy)) = UCase(strAppendAddress) Then
                        bFound = True
                    End If
                Next
                If bFound = False Then
                    ReDim Preserve aProxyAddresses(UBound(aProxyAddresses) + 1)
                    aProxyAddresses(UBound(aProxyAddresses)) = strAppendAddress
                    objMailRecipUser.ProxyAddresses = aProxyAddresses
                End If
                Erase aProxyAddresses
            ElseIf VarType(aProxyAddresses) = 8 Then ' 文字列型
                If UCase(aProxyAddresses) <> UCase(strAppendAddress) Then
                    objMailRecipUser.ProxyAddresses = Array(aProxyAddresses, strAppendAddress)
                End If
            Else
                objMailRecipUser.ProxyAddresses = Array(strAppendAddress)
            End If
            
            nMailEnabled = nMailEnabled + 1
        End If
    Else
        '-------------------------------
        ' メールボックスが必要なユーザー
        '-------------------------------
        LogWriteLine "メールボックスユーザー"
        
        strServerName = UCase(ServerName)
        LogWriteLine "サーバー：" & strServerName
        strStoreName = "メールボックス ストア (" & strServerName & ")"
        LogWriteLine "ストア：" & strStoreName
        
        ' メールボックス
        Set objMailBox = objUser
        ' HomeMDB プロパティを組み立てる
        HomeMDBURL = _
            "CN=" & strStoreName & _
            ",CN=" & strStorageGroupName & ",CN=InformationStore," & _
            "CN=" & strServerName & ",CN=Servers," & _
            "CN=" & strAdministrativeGroupName & "," & _
            "CN=Administrative Groups,CN=" & strOrganizationName & "," & _
            "CN=Microsoft Exchange,CN=Services," & _
            "CN=Configuration," & strDomainPath
        
        If objMailBox.HomeMDB = "" Then
            ' メールボックスが無い
            ' メールが有効な可能性があるので無効にする
            LogWriteLine "メールを無効にする"
            On Error Resume Next
            objMailRecipUser.MailDisable
            On Error GoTo 0
            objPrimitiveUser.Put "mailNickname", alias
            LogWriteLine "メールボックスを作成"
            objMailBox.CreateMailbox HomeMDBURL
        ElseIf objMailBox.HomeMDB <> HomeMDBURL Then
            ' メールボックス移動
            LogWriteLine "メールボックスの移動が必要"
            nMailBoxMustMove = nMailBoxMustMove + 1
            'objMailBox.MoveMailBox HomeMDBURL
        End If
        
        ' プライマリSMTPアドレス
        objMailRecipUser.SMTPEmail = alias & "@" & strOrganizationDNSName
        
        ' 転送用配布グループ
        rn = "CN=alt-" & alias
        LogWriteLine "配布グループを作成"
        Set objPrimitiveGroup = objContainer.Create("group", rn)
        
        'typedef enum {
        '  ADS_GROUP_TYPE_GLOBAL_GROUP              = 0x00000002,
        '  ADS_GROUP_TYPE_DOMAIN_LOCAL_GROUP    = 0x00000004,
        '  ADS_GROUP_TYPE_LOCAL_GROUP               = 0x00000004,
        '  ADS_GROUP_TYPE_UNIVERSAL_GROUP       = 0x00000008,
        '  ADS_GROUP_TYPE_SECURITY_ENABLED      = 0x80000000
        '  } ADS_GROUP_TYPE_ENUM;
        
        objPrimitiveGroup.Put "samAccountName", "alt-" & alias
        objPrimitiveGroup.Put "groupType", 4
        LogWriteLine "配布グループをコミット"
        objPrimitiveGroup.SetInfo
        
        Set objGroup = objPrimitiveGroup
        
        ' 転送アドレスループ
        For i = 0 To MaxForwardingAddresses Step 1
            ' 転送用連絡先を作成して、配布グループのメンバーにする
            
            rn = "CN=con" & CStr(i) & "-" & alias
            param = "ForwardingAddress" & CStr(i)
            
            ' 転送先アドレスがあれば連絡先を作成して配布グループに追加
            If Eval(param & " <> """"") = True Then
                LogWriteLine "連絡先オブジェクト" & CStr(i) & "を作成"
                Set objPrimitiveContact = objContainer.Create("contact", rn)
                
                Set objMailRecipContact = objPrimitiveContact
                objMailRecipContact.Alias = "con" & CStr(i) & "-" & alias
                
                Execute "objPrimitiveContact.Put ""displayName"", " & param
                Execute "objMailRecipContact.MailEnable(""SMTP:"" & " & param & ")"
                
                objMailRecipContact.HideFromAddressBook = True
                LogWriteLine "連絡先オブジェクト" & CStr(i) & "をコミット"
                objPrimitiveContact.SetInfo
                
                strContactPath = objPrimitiveContact.AdsPath
                LogWriteLine "配布グループに連絡先" & CStr(i) & "を追加"
                objGroup.Add strContactPath
                
                bMemberExists = True
            End If
        Next
        
        Set objMailRecipGroup = objGroup
        If objMailRecipGroup.Alias = "" Then
            objMailRecipGroup.Alias = "alt-" & alias
            LogWriteLine "配布グループのメールを有効にする"
            objMailRecipGroup.MailEnable
        End If
        objMailRecipGroup.SMTPEmail = "alt-" & alias & "@" & strOrganizationDNSName
        objMailRecipGroup.HideFromAddressBook = True
        LogWriteLine "配布グループをコミット"
        objPrimitiveGroup.SetInfo
        
        ' 配布グループ作成後のメールボックスの処理
        If bMemberExists = True Then
            ' メールボックスの代理受信者に設定
            LogWriteLine "代理受信者を設定"
            objMailRecipUser.ForwardTo = objPrimitiveGroup.AdsPath
            LogWriteLine "メールボックスに残すかどうかを設定"
            If DeliverBoth = "1" Then
                objMailRecipUser.ForwardingStyle = 1
            Else
                objMailRecipUser.ForwardingStyle = 0
            End If
            'cdoexmRecipientOrForward   0   代理受信者のみへ配信
            'cdoexmDeliverToBoth        1   受信者と代理受信者の両方に配信
        Else
            ' 転送先が無ければ配布グループを削除
            LogWriteLine "転送先が無かったため、代理受信者用配布グループを削除"
            objContainer.Delete objPrimitiveGroup.Class, objPrimitiveGroup.Name
            ' メールボックスの代理受信者設定を外す
            objMailRecipUser.ForwardingStyle = 0
            LogWriteLine "代理受信者を解除"
            objMailRecipUser.ForwardTo = ""
        End If
        
        nMailBoxEnabled = nMailBoxEnabled + 1
    End If
    
    LogWriteLine "ユーザーオブジェクトをコミット"

    objPrimitiveUser.SetInfo
    
    LogWriteLine "終了:" & Now & " " & alias
    LogWriteLine ""
    LogWriteLine ""
    
    On Error Resume Next
    
    Set objMailRecipGroup = Nothing
    Set objMailRecipContact = Nothing
    Set objGroup = Nothing
    Set objPrimitiveGroup = Nothing
    Set objPrimitiveContact = Nothing
    Set objMailRecipUser = Nothing
    Set objMailBox = Nothing
    Set objUser = Nothing
    Set objPrimitiveUser = Nothing
    Set objContainer = Nothing
End Sub