[最初に表示するアドレス帳] を変更するスクリプト


コメントにて以下のようなご要望をいただきました。


勤務先で、入社してきた社員のPC設定をしております。
その中のひとつで、アドレス帳の「最初に表示するアドレス一覧」をあるアドレス一覧を自動選択が出来るようにしたいのですが、可能でしょうか。
また、「送信時に名前を確認するアドレス一覧の順番」の変更も出来ると嬉しいのですが・・


残念ながら Outlook Object Model では、[最初に表示するアドレス一覧] や [送信時に名前を確認するアドレス一覧の順番] の設定を変更することはできません。しかし、これらの設定はレジストリの MAPI プロファイルに格納されていますので、これを変更するようなスクリプトを作れば可能です。

というわけで作ったスクリプトは以下の通りです。冒頭の DEFAULT_AB_NAME で最初に表示したいアドレス一覧の名前を指定し、拡張子を vbs として保存して実行します。設定がバイナリ データとして保存されているので、ちょっと複雑になってしまいました。

' ここをトリプルクリックでスクリプト全体を選択できます。
Option Explicit
Const DEFAULT_AB_NAME = "連絡先" ' 最初に表示させたいアドレス帳の名前を指定します。
' 定数定義
Const HKEY_CURRENT_USER = &H80000001
Const MAPI_PROFILE_KEY = "Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles"
Const MAPI_SERVICES_KEY = "9207f3e0a3b11019908b08002b2a56c2"
Const PR_AB_PROVIDERS = "01023d01"
Const PR_AB_DEFAULT_DIR = "01023d06"
Const PR_AB_SEARCH_PATH = "11023d05"
Const PR_SERVICE_NAME = "001f3d09"
Const MAPI_EMS_KEY = "13dbb0c8aa05101a9bb000aa002fc45a"
Const PR_HMVCOL_ENTRYID = "110265e0"
Const PR_HMVCOL_DISPLAY_NAMES = "101f65e4"
Const CONTAB_PREFIX = "00000000FE42AA0A18C71A10E8850B651C2400000300000003000000"
Const PR_CONTAB_UID = "01026601"
Const PR_CONTAB_FOLDER_ENTRYIDS = "11026620"
Const PR_CONTAB_DISPLAY_NAMES = "101f6629"
Const PT_BINARY = &H102
Const PT_UNICODE = &H1F
' 変数宣言
Dim objReg
Dim strKey
Dim strDefaultProfile
Dim strProfileKey
Dim strServicesKey
Dim abyAddrBookUIDs
Dim iCount
Dim strServiceKey
Dim strServiceName
Dim abyData
Dim strDefaultEID
Dim strDefaultEIDSP
Dim abyEntryID()
Dim astrEntryIDs
Dim iStart
Dim i, j
' レジストリにアクセスするための WMI の StdRegProv オブジェクトを取得します。
Set objReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
' 既定の MAPI プロファイルの名前を取得します。
objReg.GetStringValue HKEY_CURRENT_USER, MAPI_PROFILE_KEY, "DefaultProfile", strDefaultProfile
' プロファイルの名前からキーの文字列を生成します。
strProfileKey = MAPI_PROFILE_KEY & "\" & strDefaultProfile & "\"
strServicesKey = strProfileKey & MAPI_SERVICES_KEY
' アドレス帳プロバイダの ID の一覧を取得します。
objReg.GetBinaryValue HKEY_CURRENT_USER, strServicesKey, PR_AB_PROVIDERS, abyAddrBookUIDs
' アドレス帳プロバイダの ID ごとに指定されたアドレス帳を検索します。
iCount = (UBound(abyAddrBookUIDs) + 1) / 16
For i = 0 To iCount - 1
    strServiceKey = ""
    ' 16 バイトのバイナリ データを文字列に変換します。
    For j = 0 To 15
        strServiceKey = strServiceKey & Right("0" & Hex(abyAddrBookUIDs(i * 16 + j)), 2)
    Next
    ' アドレス帳プロバイダの名前を取得します。
    objReg.GetBinaryValue HKEY_CURRENT_USER, strProfileKey & strServiceKey, PR_SERVICE_NAME, abyData
    strServiceName = BinaryToUnicodeString(abyData, 0, UBound(abyData))
    ' サービスごとに情報の取得を行ないます。
    If strServiceName = "MSEMS" Then
        ' MSEMS は Exchange のグローバル アドレス一覧です。
        strDefaultEID = FindInGAL(objReg, strProfileKey & MAPI_EMS_KEY, DEFAULT_AB_NAME)
        strDefaultEIDSP = Left(strDefaultEID, 58) & "00"
    ElseIf strServiceName = "CONTAB" Then
        ' CONTAB は Outlook アドレス帳です。
        strDefaultEID = FindInCONTAB(objReg, strProfileKey & strServiceKey, DEFAULT_AB_NAME)
        strDefaultEIDSP = strDefaultEID
    End If
    ' アドレス帳が見つかったらループを抜けます。
    If strDefaultEID <> "" Then Exit For
Next
' [最初に表示するアドレス一覧] に設定します。
ReDim abyEntryID(Len(strDefaultEID) / 2 - 1)
For i = 0 To Len(strDefaultEID) / 2 - 1
    abyEntryID(i) = CInt("&H" & Mid(strDefaultEID, i * 2 + 1, 2))
Next
objReg.SetBinaryValue HKEY_CURRENT_USER, strServicesKey, PR_AB_DEFAULT_DIR, abyEntryID
' [送信時に名前を確認するアドレス一覧の順番] を入れ替えます。
objReg.GetBinaryValue HKEY_CURRENT_USER, strServicesKey, PR_AB_SEARCH_PATH, abyData
astrEntryIDs = BinaryToMultiValue(abyData, PT_BINARY)
For i = 1 To UBound(astrEntryIDs)
    If astrEntryIDs(i) = strDefaultEIDSP Then
        For j = i To 1 Step -1
            astrEntryIDs(j) = astrEntryIDs(j - 1)
        Next
        astrEntryIDs(0) = strDefaultEIDSP
        Exit For
    End If
Next
' PR_AB_SEARCH_PATH を再構成します。
iStart = 4 + (UBound(astrEntryIDs) + 1) * 8
For i = 0 To UBound(astrEntryIDs)
    abyData(i * 8 + 4) = CByte(Len(astrEntryIDs(i)) / 2)
    abyData(i * 8 + 8) = CByte(iStart Mod &H100)
    abyData(i * 8 + 9) = CByte(Int(iStart / &H100))
    For j = 0 To Len(astrEntryIDs(i)) / 2 - 1
        abyData(iStart + j) = CByte("&H" & Mid(astrEntryIDs(i), j * 2 + 1, 2))
    Next
    iStart = iStart + j
    While iStart Mod 4 > 0
        abyData(iStart) = 0
        iStart = iStart + 1
    Wend
Next
' [送信時に名前を確認するアドレス一覧の順番] を設定します。
objReg.SetBinaryValue HKEY_CURRENT_USER, strServicesKey, PR_AB_SEARCH_PATH, abyData
'   グローバル アドレス一覧から既定とするアドレス帳を検索する関数です。
Function FindInGAL(objReg, strEMSKey, strDefaultName)
    Dim abyData
    Dim astrEntryIDs
    Dim astrNames
    Dim i
    ' 名前の一覧を取得します。
    objReg.GetBinaryValue HKEY_CURRENT_USER, strEMSKey, PR_HMVCOL_DISPLAY_NAMES, abyData
    astrNames = BinaryToMultiValue(abyData, PT_UNICODE)
    For i = 0 To UBound(astrNames)
        ' 一覧に設定したいアドレス帳の名前があるか確認します。
        If astrNames(i) = strDefaultName Then
            ' 一致したら EntryID の一覧を取得します。
            objReg.GetBinaryValue HKEY_CURRENT_USER, strEMSKey, PR_HMVCOL_ENTRYID, abyData
            astrEntryIDs = BinaryToMultiValue(abyData, PT_BINARY)
            FindInGAL = astrEntryIDs(i)
            Exit Function
        End If
    Next
    FindInGAL = ""
End Function
'   Outlook アドレス帳から既定とするアドレス帳を検索する関数です。
Function FindInCONTAB(objReg, strCONTABKey, strDefaultName)
    Dim abyData
    Dim astrEntryIDs
    Dim astrNames
    Dim strUID
    Dim i
    Dim j
    ' サービスの UID を取得します。
    objReg.GetBinaryValue HKEY_CURRENT_USER, strCONTABKey, PR_CONTAB_UID, abyData
    For j = 0 To UBound(abyData)
        strUID = strUID & Right("0" & Hex(abyData(j)), 2)
    Next
    ' 名前の一覧を取得します。
    objReg.GetBinaryValue HKEY_CURRENT_USER, strCONTABKey, PR_CONTAB_DISPLAY_NAMES, abyData
    astrNames = BinaryToMultiValue(abyData, PT_UNICODE)
    For i = 0 To UBound(astrNames)
        ' 一覧に設定したいアドレス帳の名前があるか確認します。
        If astrNames(i) = strDefaultName Then
            ' 一致したら EntryID の一覧を取得します。
            objReg.GetBinaryValue HKEY_CURRENT_USER, strCONTABKey, PR_CONTAB_FOLDER_ENTRYIDS, abyData
            astrEntryIDs = BinaryToMultiValue(abyData, PT_BINARY)
            FindInCONTAB = CONTAB_PREFIX & strUID & astrEntryIDs(i)
            Exit Function
        End If
    Next
    FindInCONTAB = ""
End Function
'   バイナリ データを Multi-Value のデータに変換する関数です。
Function BinaryToMultiValue(abyData, iType)
    Dim cValues
    Dim iStart
    Dim iLen
    Dim i
    Dim j
    Dim astrData()
    ' 格納されているデータの数を取得します。
    cValues = abyData(0)
    ReDim astrData(cValues - 1)
    For i = 0 To cValues - 1
        If iType = PT_BINARY Then
            ' データの長さとデータの開始位置を取得します。
            iLen = abyData(i * 8 + 4) + abyData(i * 8 + 5) * &H100
            iStart = abyData(i * 8 + 8) + abyData(i * 8 + 9) * &H100
            ' データを文字列に変換します。
            For j = 0 To iLen - 1
                astrData(i) = astrData(i) & Right("0" & Hex(abyData(iStart + j)), 2)
            Next
        Else
            ' データの開始位置を取得します。
            iStart = abyData(i * 4 + 4)
            ' 文字列の終端を検索します。
            For iLen = 0 To UBound(abyData) - iStart Step 2
                If abyData(iStart + iLen) = 0 And abyData(iStart + iLen + 1) = 0 Then
                    Exit For
                End If
            Next
            ' データを文字列に変換します。
            astrData(i) = BinaryToUnicodeString(abyData, iStart, iLen + 1)
        End If
    Next
    BinaryToMultiValue = astrData
End Function
'   バイナリ データを Unicode 文字列に変換する関数です。
Function BinaryToUnicodeString(abyData, iStart, iLen)
    Dim strUnicode
    Dim i
    strUnicode = ""
    ' 2 バイトごとに Unicode 文字に変換します。
    ' 最初のバイトが下位バイト、次のバイトが上位バイトになります。
    For i = iStart To iStart + iLen - 1 Step 2
        strUnicode = strUnicode & ChrW(abyData(i) + abyData(i + 1) * &H100)
    Next
    ' 文字列の中に NULL がある場合は取り除きます。
    BinaryToUnicodeString = Replace(strUnicode, Chr(0), "")
End Function

 

[最初に表示するアドレス帳] を変更するスクリプト」への2件のフィードバック

  1. 連絡先以外を設定するとエラーが発生します。
    DEFAULT_AB_NAMEの指定が間違っているのだとは思いますが・・・
    Const DEFAULT_AB_NAME = “\All Address Lists\●●●●●”と記入しています。

    行:174 文字:5 エラー:型が一致しません。:’abyData’

コメントを残す

以下に詳細を記入するか、アイコンをクリックしてログインしてください。

WordPress.com ロゴ

WordPress.com アカウントを使ってコメントしています。 ログアウト / 変更 )

Twitter 画像

Twitter アカウントを使ってコメントしています。 ログアウト / 変更 )

Facebook の写真

Facebook アカウントを使ってコメントしています。 ログアウト / 変更 )

Google+ フォト

Google+ アカウントを使ってコメントしています。 ログアウト / 変更 )

%s と連携中