iCloudと連携したOutlook連絡先の氏名が逆になるのをOUTLOOK VBAで治す方法を考えました。

iCloudと同期するOutlookの連絡先で、iCloudのデータを正として、Outlookの連絡先を更新（新規追加も含む）した氏名データがOutlookの名刺形式で逆に表示されるのはiCloudの仕様による既知の通りですが、これを解決する際にデータのCSVエクスポート・CSV再インポートや個別編集以外の方法で一括でやる方法としてVBAプログラムによる自動修正・変換プログラムを考えました。

iCloudと同期するOutlookのデータの持ち方を理解していませんので、Outlookのアドレスデータフォルダの連絡先の氏名やアドレス表題を変更したら、サブフォルダの連絡先は変換しなくてもよいのか確信が持てませんので、両方チェックして治すするようにしています。

OutlookのVBAプログラムを実装・有効・実行にする方法は別にお調べください。

なお、プログラム作成にあたって下記のサイトを参考にしております。

１）OUTLOOK研究所
連絡先の電子メールの表示名を一括変更するマクロ
https://outlooklab.wordpress.com/2007/09/22/%e9%80%a3%e7%b5%a1%e5%85%88%e3%81%ae%e9%9b%bb%e5%ad%90%e3%83%a1%e3%83%bc%e3%83%ab%e3%81%ae%e8%a1%a8%e7%a4%ba%e5%90%8d%e3%82%92%e4%b8%80%e6%8b%ac%e5%a4%89%e6%9b%b4%e3%81%99%e3%82%8b%e3%83%9e%e3%82%af/

２）ken3memo (三流君)
Outlookのフォルダー を 探ってみた アイテムとサブフォルダー
http://d.hatena.ne.jp/ken3memo/20120306/1330966790

３）好きなものあれこれ

Outlook VBA（タイトルバーの動的変更）

http://peiyorin.cocolog-nifty.com/blog/2007/04/outlook_vba_c01f.html

---------------------------

'連絡先の情報を修正するプログラム
Sub ReSetContactData()

Dim oNamespace As NameSpace

Dim oFolder As folder 'フォルダー
Dim objContact As ContactItem '連絡先アイテム

Dim intLoopN As Integer 'ループのカウンター
Dim subFolder As folder 'サブフォルダー１つ下を探る
Dim intLoopC As Integer 'フォルダのループカウンタ

Dim lnghWnd As Long
Dim strMyTitle As String
Dim strTempTilte As String
Dim lngLeng As Long
Dim lngRet As Long
Dim dtSTTIME As Date
Dim dtENDTIME As Date
Dim strMESSAGE As String

lnghWnd = GetActiveWindow()
strMyTitle = String(250, Chr(10))
lngLeng = Len(MyTitle)

lngRet = GetWindowText(lnghWnd, strMyTitle, lngLeng)

strMESSAGE = "連絡先の氏名、メールアドレス表題を設定します。" + Chr(13) + Chr(10) + "よろしいですか？"

If MsgBox(strMESSAGE, vbYesNo + vbQuestion) = vbNo Then
Exit Sub
End If

dtSTTIME = Now()


' NameSpace オブジェクトへの参照を取得します。
Set oNamespace = Application.GetNamespace("MAPI")

' 既定のフォルダへの参照を取得し、フォルダを表示します。
'⇒上のOutlook規定フォルダではなく、iCloudとリンクしているアドレスフォルダを指定
Set oFolder = Session.Folders("iCloud").Folders("アドレスデータ")

Set Application.ActiveExplorer.CurrentFolder = oFolder

'iCloudフォルダ直下の ITEMとしては、アドレスデータ と サブフォルダーが存在します
'　アドレスデータ直下のアイテム数分ループ

For intLoopN = 1 To oFolder.items.Count 'アイテム数分ループ
Set objContact = oFolder.items(intLoopN)
'↑代入が終わったので、各プロパティに objContact.XXXX で アクセスする

'氏名、メールアドレス１～３の名称再設定
Call CorrectContactItemDATA(objContact)

'ステータスバーに処理件数を表示
strTempTilte = "フォルダ-" & "アドレスデータ直下" & "(" & intLoopN & "/" & oFolder.items.Count & ")を処理中..."
DoEvents
lngRet = SetWindowText(lnghWnd, strTempTilte)

Next

'サブフォルダー

For intLoopC = 1 To oFolder.Folders.Count 'サブフォルダーの数だけループする
Set subFolder = oFolder.Folders.item(intLoopC) 'intLoopC番目のフォルダーを代入
Set Application.ActiveExplorer.CurrentFolder = subFolder '移動

'サブフォルダーのアイテム数分ループ
For intLoopN = 1 To subFolder.items.Count 'アイテム数分ループ
Set objContact = subFolder.items(intLoopN)
'↑代入が終わったので、各プロパティに objContact.XXXX で アクセスする

'氏名、メールアドレス１～３の名称再設定
Call CorrectContactItemDATA(objContact)

'ステータスバーに処理件数を表示
strTempTilte = intLoopC & "/" & oFolder.Folders.Count & "フォルダ-" & subFolder.Name & "(" & intLoopN & "/" & subFolder.items.Count & ")を処理中..."
DoEvents
lngRet = SetWindowText(lnghWnd, strTempTilte)
Next
Next

'使用したオブジェクトの解放　= Nothing
Set objContact = Nothing
Set subFolder = Nothing
Set oFolder = Nothing
Set oNamespace = Nothing

DoEvents
lngRet = SetWindowText(lnghWnd, strMyTitle)

'終了時間の取得
dtENDTIME = Now()

'終了メッセージ文をセット
strMESSAGE = "処理が終了しました。" + Chr(13) + Chr(10) + _
"START TIME=" & Format(dtSTTIME, "HH:NN:SS") + Chr(13) + Chr(10) + _
"END TIME=" & Format(dtENDTIME, "HH:NN:SS")

'終了メッセージを表示
If MsgBox(strMESSAGE, vbOKOnly + vbInformation) = vbOK Then
End If

End Sub

Public Sub CorrectContactItemDATA(objContact As ContactItem)
Dim bModified As Boolean
Dim strITEMName As String
Dim strITEMMailName As String

strNewDisplayName = ""
strITEMName = ""

With objContact
If .MessageClass = "IPM.Contact" Then
bModified = False

strITEMName = Trim(.LastName & " " & .FirstName)

'表題が逆等の場合は再設定
If Len(.Subject) > 0 And Trim(.Subject) <> strITEMName Then
.Subject = strITEMName
bModified = True
End If

'氏名が逆等の場合は再設定

If Len(.FullName) > 0 And Trim(.FullName) <> strITEMName Then
.FullName = strITEMName
bModified = True
End If

'メールアドレス１がある場合、タイトルが不一致ならば再設定
If .Email1AddressType = "SMTP" And Len(.Email1Address) > 0 Then
strITEMMailName = strITEMName & "(" & .Email1Address & ")"

If .Email1DisplayName <> strITEMMailName Then
.Email1DisplayName = strITEMMailName
bModified = True
End If
End If

'メールアドレス２がある場合、タイトルが不一致ならば再設定
If .Email2AddressType = "SMTP" And Len(.Email2Address) > 0 Then
strITEMMailName = strITEMName & "(" & .Email2Address & ")"

If .Email2DisplayName <> strITEMMailName Then
.Email2DisplayName = strITEMMailName
bModified = True
End If
End If

'メールアドレス３がある場合、タイトルが不一致ならば再設定
If .Email3AddressType = "SMTP" And Len(.Email3Address) > 0 Then
strITEMMailName = strITEMName & "(" & .Email3Address & ")"
If .Email3DisplayName <> strITEMMailName Then
.Email3DisplayName = strITEMMailName
bModified = True
End If
End If

　　　　　　'データを書き換えたときは保存

If bModified = True Then
.Save
End If
End If
End With

End Sub