Option Explicit
'========================================
' 同姓候補チェック（高速版・総当たり禁止）
' - 連絡先は Items.Restrict で姓前方一致のみ
' - GAL は AddressEntries.Find/FindNext で姓前方一致のみ
' - 宛先と同じSMTPは除外
' - 実行中キャッシュで同じ姓の再検索を回避
'
' 使い方：
' 1) 既存の旧版エントリーポイント名を「CheckSurnamesForRecipients_Legacy」に変更
' 2) 本モジュールを追加
' 3) 新エントリーポイント「CheckSurnamesForRecipients_Fast」を実行
'
' 必要に応じて下記フラグを調整
'========================================
' GAL検索を行うか（Falseにするとさらに高速）
Private Const ENABLE_GAL As Boolean = True
' 会社名や氏名の表記ゆれ対策として姓の前方一致検索を使用
' NormalizeKey（全半・かな種変換・大文字化）後のキーを用いる
' 実行中キャッシュ：surnameKey → Collection("姓|名|会社|smtp")
Private mSurnameCache As Object ' Scripting.Dictionary（実行中のみ生存）
'===============================
' エントリーポイント（高速版）
' ・宛先/CC/BCC に同姓が複数いる場合に警告を出す
' ・OK / キャンセル付きのMsgBoxを表示
' ・キャンセル選択時は送信中止（Application_ItemSendでCancel=True）
'===============================
Public Function CheckSurnamesForRecipients_Fast() As Boolean
Dim insp As Outlook.Inspector
Dim mi As Outlook.MailItem
Dim r As Outlook.Recipient
Dim i As Long, key As String
Dim reported As Object ' 同じ姓は1回だけ
Dim recipientSmtps As Object ' 宛先に入っているSMTP（候補から自分を除外）
Dim coll As Collection, j As Long
Dim report As String, anyFound As Boolean
Dim readableSurname As String
Dim response As VbMsgBoxResult ' OK/キャンセルの結果用
' === メール作成ウィンドウを取得 ===
On Error Resume Next
Set insp = Application.ActiveInspector
If insp Is Nothing Or Not TypeOf insp.CurrentItem Is Outlook.MailItem Then
MsgBox "作成中のメールが見つかりません。", vbExclamation
Exit Function
End If
Set mi = insp.CurrentItem
On Error GoTo 0
' === 宛先全員のSMTPを収集 ===
Set recipientSmtps = CreateObject("Scripting.Dictionary"): recipientSmtps.CompareMode = vbTextCompare
For i = 1 To mi.Recipients.Count
Set r = mi.Recipients(i)
recipientSmtps(LCase$(GetSmtpAddress(r))) = True
Next
' === キャッシュ初期化 ===
If mSurnameCache Is Nothing Then
Set mSurnameCache = CreateObject("Scripting.Dictionary")
mSurnameCache.CompareMode = vbTextCompare
End If
' === 各宛先の姓でアドレス帳を検索 ===
Set reported = CreateObject("Scripting.Dictionary"): reported.CompareMode = vbTextCompare
report = "": anyFound = False
For i = 1 To mi.Recipients.Count
Set r = mi.Recipients(i)
key = NormalizedSurnameFromRecipient_Fast(r) ' 正規化済み姓
If key <> "" And Not reported.exists(key) Then
reported(key) = True
' 見栄え用の姓（表示名から推測）
readableSurname = ExtractSurname(IIf(Not r.AddressEntry Is Nothing, r.AddressEntry.Name, r.Name))
If Trim$(readableSurname) = "" Then readableSurname = key
' 同姓候補を取得
Set coll = FindPeopleBySurname_Fast(key, recipientSmtps)
' 2件以上ある場合のみ警告対象
Dim altCount As Long, smtp As String, mark As String
altCount = 0
' まず別候補の件数を数える（宛先に含まれないもの）
For j = 1 To coll.Count
smtp = LCase$(Part_Fast(coll(j), 3))
If Not recipientSmtps.exists(smtp) Then altCount = altCount + 1
Next
If altCount > 1 Then
anyFound = True
' 件数は「別候補」の数を表示
report = report & "■ 同じ姓の候補：" & readableSurname & " (" & altCount & "件)" & vbCrLf
For j = 1 To coll.Count
smtp = LCase$(Part_Fast(coll(j), 3))
' 宛先/CC/BCCに入っているなら →、それ以外は ・
If recipientSmtps.exists(smtp) Then
mark = "・"
Else
mark = "×"
End If
report = report & " " & mark & " " & FormatLine_SurnameGivenCompany_Fast(coll(j)) & vbCrLf
Next
report = report & String(40, "-") & vbCrLf
End If
End If
Next
' === 同姓候補が見つかった場合は確認ダイアログ ===
If anyFound Then
response = MsgBox(report & vbCrLf & "送信を続けますか？", vbExclamation + vbOKCancel, "同姓（アドレス帳）チェック結果")
If response = vbCancel Then
' Trueを返すことで送信イベント側でCancel=Trueにできる
CheckSurnamesForRecipients_Fast = True
End If
End If
End Function
'===============================
' 表示用：「姓 名（会社名）」に整形
' packed = "姓|名|会社|smtp"
'===============================
Private Function FormatLine_SurnameGivenCompany_Fast(ByVal packed As String) As String
Dim p() As String, s As String
p = Split(packed, "|")
s = NzStrArr_Fast(p, 0)
If NzStrArr_Fast(p, 1) <> "" Then s = s & " " & NzStrArr_Fast(p, 1)
If NzStrArr_Fast(p, 2) <> "" Then s = s & "（" & NzStrArr_Fast(p, 2) & "）"
FormatLine_SurnameGivenCompany_Fast = Trim$(s)
End Function
Private Function NzStrArr_Fast(ByRef arr() As String, ByVal idx As Long) As String
On Error Resume Next
NzStrArr_Fast = Trim$(arr(idx))
On Error GoTo 0
End Function
'===============================
' 正規化・姓の取得（フィールド優先）
'===============================
Private Function NormalizeKey_Fast(ByVal s As String) As String
Dim t As String
t = Trim$(s)
t = Replace$(t, " ", " ")
On Error Resume Next
t = StrConv(t, vbNarrow) ' 全角→半角
t = StrConv(t, vbKatakana) ' ひらがな→カタカナ
On Error GoTo 0
NormalizeKey_Fast = UCase$(t)
End Function
Private Function RemoveParenPart_Fast(ByVal s As String) As String
Dim t As String: t = s
t = Replace$(t, "（", "("): t = Replace$(t, "）", ")")
t = Replace$(t, "【", "["): t = Replace$(t, "】", "]")
t = Replace$(t, "〔", "["): t = Replace$(t, "〕", "]")
If InStr(t, "(") > 0 Then t = Left$(t, InStr(t, "(") - 1)
If InStr(t, "[") > 0 Then t = Left$(t, InStr(t, "[") - 1)
RemoveParenPart_Fast = Trim$(t)
End Function
' 表示名からの姓推測（最終手段）
Private Function ExtractSurname(ByVal fullDispName As String) As String
Dim s As String
s = Trim$(fullDispName)
If s = "" Then Exit Function
s = RemoveParenPart_Fast(s)
If InStr(s, ",") > 0 Then ExtractSurname = Trim$(Split(s, ",")(0)): Exit Function
If InStr(s, " ") > 0 Then ExtractSurname = Trim$(Split(s, " ")(0)): Exit Function
If InStr(s, " ") > 0 Then ExtractSurname = Trim$(Split(s, " ")(0)): Exit Function
ExtractSurname = s
End Function
' Recipient → 姓（LastName優先、無ければ推測）を正規化キー化
Private Function NormalizedSurnameFromRecipient_Fast(ByVal r As Outlook.Recipient) As String
On Error Resume Next
Dim ae As Outlook.AddressEntry, exu As Outlook.ExchangeUser, c As Outlook.ContactItem
Dim ln As String, guess As String
If r Is Nothing Then Exit Function
Set ae = r.AddressEntry
If Not ae Is Nothing Then
Set exu = ae.GetExchangeUser
If Not exu Is Nothing Then ln = Trim$(exu.lastName)
If ln = "" Then
Set c = ae.GetContact
If Not c Is Nothing Then ln = Trim$(c.lastName)
End If
End If
If ln = "" Then
guess = IIf(Not ae Is Nothing, ae.Name, r.Name)
ln = ExtractSurname(guess)
End If
NormalizedSurnameFromRecipient_Fast = NormalizeKey_Fast(ln)
End Function
' AddressEntry → 姓の正規化キー
Private Function NormalizedSurnameFromAE_Fast(ByVal ae As Outlook.AddressEntry) As String
On Error Resume Next
Dim exu As Outlook.ExchangeUser, c As Outlook.ContactItem
Dim ln As String
If ae Is Nothing Then Exit Function
Set exu = ae.GetExchangeUser
If Not exu Is Nothing Then ln = Trim$(exu.lastName)
If ln = "" Then
Set c = ae.GetContact
If Not c Is Nothing Then ln = Trim$(c.lastName)
End If
If ln = "" Then ln = ExtractSurname(Trim$(ae.Name))
NormalizedSurnameFromAE_Fast = NormalizeKey_Fast(ln)
End Function
'===============================
' 宛先のSMTP取得（Exchangeでも安定）
'===============================
Private Function GetSmtpAddress(ByVal r As Outlook.Recipient) As String
On Error Resume Next
Const PR_SMTP As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
Dim s As String
s = Trim$(r.PropertyAccessor.GetProperty(PR_SMTP))
If s = "" Then s = Trim$(r.address)
GetSmtpAddress = LCase$(s)
End Function
'===============================
' 高速検索：連絡先＋GAL（必要時）
' 返却: Collection of "姓|名|会社|smtp"（重複除外済）
'===============================
Private Function FindPeopleBySurname_Fast(ByVal surnameKey As String, ByVal recipientSmtps As Object) As Collection
' 実行中キャッシュ
If Not mSurnameCache Is Nothing Then
If mSurnameCache.exists(surnameKey) Then
Set FindPeopleBySurname_Fast = mSurnameCache(surnameKey)
Exit Function
End If
End If
Dim res As New Collection
Dim seen As Object: Set seen = CreateObject("Scripting.Dictionary")
seen.CompareMode = vbTextCompare
' 1) 連絡先（サブフォルダ含む）：Restrictで前方一致
On Error Resume Next
Dim root As Outlook.Folder
Set root = Application.Session.GetDefaultFolder(olFolderContacts)
If Not root Is Nothing Then
CollectContactsBySurname_Fast root, surnameKey, res, seen
End If
On Error GoTo 0
' 2) GAL 等：Find/FindNextで前方一致
If ENABLE_GAL Then
On Error Resume Next
Dim lst As Outlook.AddressList, ae As Outlook.AddressEntry
Dim f As String
f = BuildAddressEntryFindFilterFromSurname(surnameKey)
For Each lst In Application.Session.AddressLists
Set ae = Nothing
Set ae = lst.AddressEntries.Find(f)
Do While Not ae Is Nothing
Dim line As String, smtp As String
line = BuildInfoFromAE_Fast(ae) ' "姓|名|会社|smtp"
smtp = Part_Fast(line, 3)
If smtp <> "" Then
If Not seen.exists(LCase$(smtp)) Then
res.Add line
seen(LCase$(smtp)) = True
End If
End If
Set ae = lst.AddressEntries.FindNext
Loop
Next
On Error GoTo 0
End If
' 置き換え後:
If mSurnameCache Is Nothing Then
Set mSurnameCache = CreateObject("Scripting.Dictionary")
mSurnameCache.CompareMode = vbTextCompare
End If
Set mSurnameCache(surnameKey) = res ' ← Collection を入れるので Set が必要
Set FindPeopleBySurname_Fast = res
End Function
' 連絡先：Restrictで姓前方一致ヒットのみ収集（Email1～3、重複除外）
Private Sub CollectContactsBySurname_Fast(ByVal f As Outlook.Folder, ByVal keyQuery As String, _
ByRef res As Collection, ByVal seen As Object)
On Error Resume Next
Dim dasl As String
dasl = BuildContactsRestrictFilterFromSurname(keyQuery)
Dim its As Outlook.Items, hits As Outlook.Items, it As Object
Set its = f.Items
Set hits = its.Restrict(dasl)
If Not hits Is Nothing Then
For Each it In hits
If TypeOf it Is Outlook.ContactItem Then
Dim c As Outlook.ContactItem
Set c = it
AddContactEmailIfAny_Fast res, seen, c, 1
AddContactEmailIfAny_Fast res, seen, c, 2
AddContactEmailIfAny_Fast res, seen, c, 3
End If
Next
End If
' サブフォルダも処理
Dim sf As Outlook.Folder
For Each sf In f.Folders
CollectContactsBySurname_Fast sf, keyQuery, res, seen
Next
End Sub
Private Sub AddContactEmailIfAny_Fast(ByRef res As Collection, ByVal seen As Object, _
ByVal c As Outlook.ContactItem, ByVal idx As Integer)
Dim smtp As String, ln As String, fn As String, comp As String
Select Case idx
Case 1: smtp = Trim$(c.Email1Address)
Case 2: smtp = Trim$(c.Email2Address)
Case 3: smtp = Trim$(c.Email3Address)
End Select
If smtp = "" Then Exit Sub
ln = Trim$(c.lastName): fn = Trim$(c.firstName): comp = Trim$(c.companyName)
If ln = "" Then ln = ExtractSurname(Trim$(c.fullName))
smtp = LCase$(smtp)
If Not seen.exists(smtp) Then
res.Add ln & "|" & fn & "|" & comp & "|" & smtp
seen(smtp) = True
End If
End Sub
' AddressEntry → "姓|名|会社|smtp"
Private Function BuildInfoFromAE_Fast(ByVal ae As Outlook.AddressEntry) As String
On Error Resume Next
Dim ln As String, fn As String, comp As String, smtp As String
Dim exu As Outlook.ExchangeUser, c As Outlook.ContactItem
Set exu = ae.GetExchangeUser
If Not exu Is Nothing Then
ln = Trim$(exu.lastName)
fn = Trim$(exu.firstName)
comp = Trim$(exu.companyName)
smtp = Trim$(exu.PrimarySmtpAddress)
End If
If smtp = "" Then
Set c = ae.GetContact
If Not c Is Nothing Then
If Trim$(c.Email1Address) <> "" Then
smtp = Trim$(c.Email1Address)
ElseIf Trim$(c.Email2Address) <> "" Then
smtp = Trim$(c.Email2Address)
ElseIf Trim$(c.Email3Address) <> "" Then
smtp = Trim$(c.Email3Address)
End If
If ln = "" Then ln = Trim$(c.lastName)
If fn = "" Then fn = Trim$(c.firstName)
If comp = "" Then comp = Trim$(c.companyName)
End If
End If
If ln = "" And fn = "" Then ln = ExtractSurname(Trim$(ae.Name)) ' 最後の手段
If smtp = "" Then smtp = Trim$(ae.address)
BuildInfoFromAE_Fast = ln & "|" & fn & "|" & comp & "|" & LCase$(smtp)
End Function
' packed から要素取得（0=姓,1=名,2=会社,3=SMTP）
Private Function Part_Fast(ByVal packed As String, ByVal idx As Long) As String
Dim p() As String
p = Split(packed, "|")
On Error Resume Next
Part_Fast = Trim$(p(idx))
On Error GoTo 0
End Function
'===============================
' Restrict / Find 用フィルタ
'===============================
' 連絡先用 Restrict（DASL）
' LastName または DisplayName が key で始まる
Private Function BuildContactsRestrictFilterFromSurname(ByVal keyQuery As String) As String
' NormalizeKey_Fast済みのキーを想定。Restrictは大文字小文字をあまり気にしないが安全に前方一致。
' DASL: urn:schemas:contacts:sn = LastName
' http://schemas.microsoft.com/mapi/proptag/0x3001001E = PR_DISPLAY_NAME (FullNameに相当)
Dim k As String: k = Replace$(keyQuery, "'", "''") ' クオートエスケープ
Dim lastNameDASL As String, dispNameDASL As String
lastNameDASL = "urn:schemas:contacts:sn"
dispNameDASL = "http://schemas.microsoft.com/mapi/proptag/0x3001001E"
BuildContactsRestrictFilterFromSurname = _
"@SQL=" & _
Chr$(34) & lastNameDASL & Chr$(34) & " LIKE '" & k & "%' OR " & _
Chr$(34) & dispNameDASL & Chr$(34) & " LIKE '" & k & "%'"
End Function
' GAL用 Find フィルタ
' [LastName] または [Name] が key で始まる
Private Function BuildAddressEntryFindFilterFromSurname(ByVal keyQuery As String) As String
Dim k As String: k = Replace$(keyQuery, "'", "''")
BuildAddressEntryFindFilterFromSurname = _
"[LastName] Like '" & k & "*' OR [Name] Like '" & k & "*'"
End Function
'========================================
' 手動確認用：送信は一切しない／止めない版
' - ボタンから実行して重複姓候補を確認するだけ
' - 同姓候補が2件以上ある姓だけを一覧表示
' - OK=何もしない、キャンセル=何もしない（マクロ終了）
'========================================
Public Sub CheckSurnamesForRecipients_Preview()
Dim insp As Outlook.Inspector
Dim mi As Outlook.MailItem
Dim r As Outlook.Recipient
Dim i As Long, key As String
Dim reported As Object ' 同じ姓は1回だけ
Dim recipientSmtps As Object ' 宛先に入っているSMTP（候補から自分を除外）
Dim coll As Collection, j As Long
Dim report As String, anyFound As Boolean
Dim readableSurname As String
Dim response As VbMsgBoxResult
' === メール作成ウィンドウを取得 ===
On Error Resume Next
Set insp = Application.ActiveInspector
If insp Is Nothing Or Not TypeOf insp.CurrentItem Is Outlook.MailItem Then
MsgBox "作成中のメールが見つかりません。", vbExclamation
Exit Sub
End If
Set mi = insp.CurrentItem
On Error GoTo 0
' === 宛先全員のSMTPを収集 ===
Set recipientSmtps = CreateObject("Scripting.Dictionary"): recipientSmtps.CompareMode = vbTextCompare
For i = 1 To mi.Recipients.Count
Set r = mi.Recipients(i)
recipientSmtps(LCase$(GetSmtpAddress(r))) = True
Next
' === キャッシュ初期化（必要なら）===
If mSurnameCache Is Nothing Then
Set mSurnameCache = CreateObject("Scripting.Dictionary")
mSurnameCache.CompareMode = vbTextCompare
End If
' === 各宛先の姓でアドレス帳を検索 ===
Set reported = CreateObject("Scripting.Dictionary"): reported.CompareMode = vbTextCompare
report = "": anyFound = False
For i = 1 To mi.Recipients.Count
Set r = mi.Recipients(i)
key = NormalizedSurnameFromRecipient_Fast(r) ' 正規化済み姓
If key <> "" And Not reported.exists(key) Then
reported(key) = True
' 見栄え用の姓（表示名から推測）
readableSurname = ExtractSurname(IIf(Not r.AddressEntry Is Nothing, r.AddressEntry.Name, r.Name))
If Trim$(readableSurname) = "" Then readableSurname = key
' 同姓候補を取得（宛先自身は除外）
Set coll = FindPeopleBySurname_Fast(key, recipientSmtps)
' 2件以上ある場合のみ警告対象（1件＝重複なし扱い）
Dim altCount As Long, smtp As String, mark As String
altCount = 0
' まず別候補の件数を数える（宛先に含まれないもの）
For j = 1 To coll.Count
smtp = LCase$(Part_Fast(coll(j), 3))
If Not recipientSmtps.exists(smtp) Then altCount = altCount + 1
Next
If altCount > 1 Then
anyFound = True
' 件数は「別候補」の数を表示
report = report & "■ 同じ姓の候補：" & readableSurname & " (" & altCount & "件)" & vbCrLf
For j = 1 To coll.Count
smtp = LCase$(Part_Fast(coll(j), 3))
' 宛先/CC/BCCに入っているなら →、それ以外は ・
If recipientSmtps.exists(smtp) Then
mark = "・"
Else
mark = "×"
End If
report = report & " " & mark & " " & FormatLine_SurnameGivenCompany_Fast(coll(j)) & vbCrLf
Next
report = report & String(40, "-") & vbCrLf
End If
End If
Next
' === 結果表示（送信の可否は一切操作しない）===
If anyFound Then
response = MsgBox(report & vbCrLf & "OKで閉じます。", vbExclamation + vbOKCancel, "同姓（アドレス帳）チェック結果（プレビュー）")
' キャンセルを押しても送信は止めない（このマクロは確認のみ）
' 何もせず終了
Else
MsgBox "重複し得る同姓候補は見つかりませんでした。", vbInformation
End If
End Sub
ごん
次に、ThisOutlookSessionに下記のコードを貼り付けます
'=========================================
' メール送信時イベント
' 送信ボタン押下時に自動チェックを実行
'=========================================
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
On Error Resume Next
If TypeOf Item Is Outlook.MailItem Then
' 関数がTrueを返した場合はキャンセル
If CheckSurnamesForRecipients_Fast() Then
Cancel = True
Exit Sub
End If
End If
End Sub
カテゴリ
悩む人
ごん
