コメントにて以下のようなご要望をいただきました。
勤務先で、入社してきた社員の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
Outlook 研究所 