Windows 転送ツールで転送後に Outlook で連絡先がアドレス帳に表示されない現象について

PC を買い替えたとき、古い PC から新しい PC に Outlook のデータや設定を転送するためには Windows 転送ツールが非常に便利です。

しかし、Windows XP から Windows 7 へ転送すると、移行後に Outlook で連絡先がアドレス帳に表示されなくなる現象が発生するようです。この現象が発生すると、単に表示されないだけでなく、連絡先の追加や削除もできない状態となります。
調査してみたところ、どうやら原因は Outlook アドレス帳のレジストリのデータにあるようなのですが、Outlook のユーザー インターフェイスからはこの値を初期化することができませんでした。

そこで、この現象が発生した場合に Outlook アドレス帳のレジストリを初期化するスクリプトを作ってみました。この内容をメモ帳などで拡張子 vbs として保存し、そのファイルをダブルクリックして実行すると既定の MAPI プロファイルの Outlook アドレス帳の設定を初期化し、連絡先フォルダが追加できるようになります。

' ここをトリプルクリックでスクリプト全体を選択できます。
Option Explicit
'
Const HKEY_CURRENT_USER = &H80000001
Const MAPI_PROFILE_KEY = "Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles"
' Const MAPI_PROFILE_KEY = "Software\Microsoft\Office\15.0\Outlook\Profiles" ' Outlook 2013 ではこちらを使用
Const MAPI_SERVICES_KEY = "9207f3e0a3b11019908b08002b2a56c2"
Const PR_AB_PROVIDERS = "01023d01"
'
Dim stdRegProv
Dim strDefaultProfile
Dim strProfileKey
Dim strServicesKey
Dim arrServiceUIDs
Dim iCount
Dim i,j
Dim strServiceKey
Dim arrData
'
Set stdRegProv = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
stdRegProv.GetStringValue HKEY_CURRENT_USER, MAPI_PROFILE_KEY, "DefaultProfile", strDefaultProfile
strProfileKey = MAPI_PROFILE_KEY & "\" & strDefaultProfile & "\"
strServicesKey = strProfileKey & MAPI_SERVICES_KEY
'
stdRegProv.GetBinaryValue HKEY_CURRENT_USER, strServicesKey, PR_AB_PROVIDERS, arrServiceUIDs
iCount = (UBound(arrServiceUIDs)+1)/16
For i=0 To iCount-1
    strServiceKey = ""
    For j=0 To 15
        strServiceKey = strServiceKey & Right("0" & Hex(arrServiceUIDs(i*16+j)), 2)
    Next
    If stdRegProv.GetBinaryValue(HKEY_CURRENT_USER, strProfileKey & strServiceKey, "11026626", arrData ) = 0 Then
        Dim aDelProps
        aDelProps = Array( "101e6622", "101e6623", "101e6624", "101f6627", "101f6628", "101f6629", "11026620", "11026626" )
        For j=0 To UBound(aDelProps)
            stdRegProv.DeleteValue HKEY_CURRENT_USER, strProfileKey & strServiceKey, aDelProps(j)
        Next
        Exit For
    End If
Next
'
Set stdRegProv = Nothing

変更履歴:

2013/07/12 Outlook 2013 対応のための記述を追加しました。