Outlookメール送信先の情報を一覧表示(コード解説編)

2023.05.12

メールの送信先が多いと、確認が面倒です

そこで、VBAを使って、確認を簡単にする方法を紹介します

まずは、サンプルメールです

横にずらずらとアドレスが並んでいて、1つ1つ目で追うのが大変です

ここで、VBAのプロシージャを起動させると

下記のようにユーザーフォームで、きれいに表示することができます

ついでに、事業所、部署、役職、フルネームも表示しています

また、csv形式で出力することもできます

では、具体的な方法について解説していきます

 

ユーザーフォームで表示

まず、メール送信先の情報をユーザーフォームで表示する方法です

メール送信先がそれほど多くない時など、サクッと見たいときに使います

 

モジュールの準備

下記の２つのモジュールを使用します

  • ユーザーフォーム
  • 標準モジュール

ユーザーフォーム：送信先の情報を表示するためのフォーム

標準モジュール：主な処理内容を記述し、Outlook画面からプロシージャを呼び出します

 

ユーザーフォーム

OutlookのVBE上で、ユーザフォームを新規作成し下記のようにコントロールズ（ラベルとテキストボックス）を配置します

 

ラベルの設定

プロパティ 値
Font フォント名：メイリオ、サイズ：9

 

テキストボックスの設定

プロパティ 値
Font フォント名：メイリオ、サイズ：9
ScrollBars 1 – fmScrollBarsHorizontal
SpecialEffect 0 – fmSpecialEffectFlat
WordWrap Flase
ScrollBars: 1 – fmScrollBarsHorizontal スクロールバー（縦方向）を表示します
SpecialEffect: 0 – fmSpecialEffectFlat テキストボックスの枠の段差をフラットにします
WordWrap: False 文字列がテキストボックスからあふれた場合、文字列を折り返さないようにします

 

オブジェクト名の設定

Caption(ラベル) オブジェクト名(テキストボックス)
宛先/CC TxtTOCC
名前 TxtLastName
役職 TxtTitle
事業所 TxtOffice
部署 TxtDepartment
フルネーム TxtFullName

他のモジュール（標準モジュール）と変数の受け渡しをするために、オブジェクト名を設定します

 

標準モジュール

標準モジュールでは、下記のプロシージャを作成します

  • ShowReciver()
  • setCurMail()
  • setAddrLists()
  • setTOs()
  • setCCs()
  • setReciever()
  • putReciever()
  • resetReciever()
  • resetCurMail()

 

ShowReciver()

'**
'* メール受信者を表示
'*
Public Sub ShowReciever()

Call setCurMail

Call setAddrLists
Call setTOs: Category = "TO": Call setReciever(TOs)
Call setCCs: Category = "CC": Call setReciever(CCs)

Call putReciever

Call resetReciever

Call resetCurMail

End Sub

Outlook画面から直接呼び出されるプロシージャです

このプロシージャ内で下記のプロシージャを呼び出しています

プロシージャ 概要
setCurMail() アクティブメールをCurMailに設定する
setAddrLists() 全メールリスト群を設定
setTOs() 全アドレス(TO)を設定
setCCs() 全アドレス(CC)を設定
setReciever() メール受信者を設定
putReciever() ユーザーフォームにメール受信者を表示
resetReciever() メール受信者をリセット
resetCurMail() CurMailの設定を解除する

 

setCurMail()

'**
'* アクティブメールをCurMailに設定する
'*

Private Sub setCurMail()

Set CurMail = Application.ActiveInspector.CurrentItem

End Sub

現在表示しているメールをCurMailに格納します

以降、CurMailに対して処理を実行していきます

 

setAddrLists()

'**
'* 全メールリスト群を設定
'*

Private Sub setAddrLists()

Set AddrLists = Application.Session.AddressLists

End Sub

Outlook内に存在する全てのアドレス帳をコレクションとしてAddrListsに格納します

AddrLists内から、役職・事業所・部署・フルネームを検索します

 

setTOs()

'**
'* 全アドレス(TO)を設定
'*

Private Sub setTOs()

TOs = Split(CurMail.To, "; ")

End Sub

アドレスは、

徳川 家光(tokugawa.iemitsu@edo.jp); 徳川 家康(tokugawa.ieyasu@edo.jp)

のように、”; ” （セミコロン + 半角スペース）で区切られています

宛先にあるメールアドレスのコレクションを、”; ” で区切って、配列として、TOs に格納しています

 

setCCs()

'**
'* 全アドレス(CC)を設定
'*

Private Sub setCCs()

CCs = Split(CurMail.cc, "; ")

End Sub

CCにあるメールアドレスのコレクションを、”; ” で区切って、配列として、CCs に格納しています

 

setReciever()

'**
'* メール受信者を設定
'*

Private Sub setReciever(ByVal Tgt As Variant)

Dim i As Long
Dim addrList As Variant
Dim entry As Variant

For i = LBound(Tgt) To UBound(Tgt)

For Each addrList In AddrLists

            If addrList.AddressListType = 0 Or addrList.AddressListType = 2 Then

                    For Each entry In addrList.AddressEntries

                        If entry.Name = Tgt(i) Then
                        
                            count = count + 1
                        
                            Select Case addrList.AddressListType
                            
                            Case 0
                    
                              If count = 1 Then Lastname = entry.GetExchangeUser.Lastname Else Lastname = Lastname & vbCrLf & entry.GetExchangeUser.Lastname
                              If count = 1 Then Title = entry.GetExchangeUser.JobTitle Else Title = Title & vbCrLf & entry.GetExchangeUser.JobTitle
                              If count = 1 Then Office = entry.GetExchangeUser.OfficeLocation Else Office = Office & vbCrLf & entry.GetExchangeUser.OfficeLocation
                              If count = 1 Then Department = entry.GetExchangeUser.Department Else Department = Department & vbCrLf & entry.GetExchangeUser.Department
                              If count = 1 Then Displayname = entry.GetExchangeUser.Name Else Displayname = Displayname & vbCrLf & entry.GetExchangeUser.Name
                              
                            Case 2
                                
                             If count = 1 Then Lastname = entry.GetContact.Lastname Else Lastname = Lastname & vbCrLf & entry.GetContact.Lastname
                             If count = 1 Then Title = entry.GetContact.JobTitle Else Title = Title & vbCrLf & entry.GetContact.JobTitle
                             If count = 1 Then Office = entry.GetContact.CompanyName Else Office = Office & vbCrLf & entry.GetContact.CompanyName
                             If count = 1 Then Department = entry.GetContact.Department Else Department = Department & vbCrLf & entry.GetContact.Department
                             If count = 1 Then Displayname = entry.GetContact.Fullname Else Displayname = Displayname & vbCrLf & entry.GetContact.Fullname
                              
                            End Select
                            
                            If count = 1 Then TOCC = Category Else TOCC = TOCC & vbCrLf & Category
                            
                            GoTo Continue
                              
                        End If
                        
Continue:

                    Next

            End If

        Next

Next

End Sub

 

15行目：

addrList.AddressListType = 0 (アドレス帳：Offline Global Address List)

addrList.AddressListType = 2 (アドレス帳：連絡先)

社内のメールアドレスと、個人で使用しているアドレス帳のみ使用しています

 

21行目：

count = count + 1

姓、役職、事業所、部署、フルネームを改行区切りで、追記していきます

ただし、1つ目は改行なしとしたい

27 – 31行目と35 – 39行目では、1つ目とそれ以外で処理を分けています

 

45, 49行目：

GoTo Continue / Continue:

アドレス帳からメールアドレスが見つかった場合、For文の途中処理をスキップしています

これをしておかないと処理時間が長くなってしまいます

 

宛先やCCのコレクションを受け取って、

アドレス帳にアクセスし、

姓、役職、事業所、部署、フルネームの情報を

各変数（Lastname、Title、Office、Department、Displayname）に格納しています

 

putReciever()

'**
'* ユーザーフォームにメール受信者を表示
'*

Private Sub putReciever()

UserForm1.Show vbModeless

    With UserForm1
    
        .TxtTOCC = TOCC
        .TxtLastName = Lastname
        .TxtTitle = Title
        .TxtOffice = Office
        .TxtDepartment = Department
        .TxtFullName = Displayname
    
    End With

End Sub

ユーザーフォームのテキストボックスに値を代入して表示させます

 

resetReciever()

'**
'* メール受信者をリセット
'*

Private Sub resetReciever()

TOCC = ""
Lastname = ""
Title = ""
Office = ""
Department = ""
Displayname = ""

End Sub

各変数に、空文字を代入してリセットします

これをやっておかないと、ShowReciver を再び実行した際に、検索が重複して表示されてしまいます

 

resetCurMail()

'**
'* CurMailの設定を解除する
'**

Private Sub resetCurMail()

Set CurMail = Nothing

End Sub

CurMail の設定を解除します

 

変数の設定

Option Explicit

Private CurMail As MailItem
Private AddrLists As Outlook.AddressLists
Private TOs As Variant
Private CCs As Variant
Private TOCC As String
Private Lastname As String
Private Title As String
Private Office As String
Private Department As String
Private Displayname As String
Private Category As String
Private count As Long

 

実行方法

VBEに上記のコードを記述すると、Outlook のマクロで、ShowReciever が選択できるようになります

メールを開いた状態で、ShowReciever を実行すると、メール送信先の情報がユーザフォームで表示されます

 

csvファイルで出力

今度は、メール送信先の情報をcsvファイルで出力する方法です

メール送信先が多い時などに使用します

 

標準モジュールの準備

モジュールは、標準モジュールのみ使用します

下記のプロシージャを作成します

  • SaveReciverAsCsv()
  • setCurMail()
  • setAddrLists()
  • setTOs()
  • setCCs()
  • setReciever()
  • ctrCsv()
  • resetReciever()
  • resetCurMail()

 

ShowReciverAsCsv()

'**
'* メール受信者情報をcsv形式で出力
'*

Public Sub SaveRecieverAsCsv()

Call setCurMail

Call setAddrLists
Call setTOs: Category = "TO": Call setReciever(TOs)
Call setCCs: Category = "CC": Call setReciever(CCs)

Call crtCsv

Call resetReciever

Call resetCurMail

End Sub

Outlook画面から直接呼び出されるプロシージャです

このプロシージャ内で下記のプロシージャを呼び出しています

プロシージャ 概要
setCurMail() アクティブメールをCurMailに設定する
setAddrLists() 全メールリスト群を設定
setTOs() 全アドレス(TO)を設定
setCCs() 全アドレス(CC)を設定
setReciever() メール受信者を設定
ctrCsv() csvファイルを新規作成&送信先情報を出力
resetReciever() メール受信者をリセット
resetCurMail() CurMailの設定を解除する

ctrCsv() 以外のプロシージャは、ShowReciever プロシージャで呼び出しているものと同じものです

 

ctrCsv()

''**
'* csvファイルを新規作成&送信先情報を出力
'*

Private Sub crtCsv()

Dim fso As Object
Dim txtSAM As TextStream
Dim csvContent As String: csvContent = "TO/CC" & "," & "名前(姓)" & "," & "役職" & "," & "事業所" & "," & "部署" & "," & "フルネーム"
Const fp = "C:\Users\nobby\Desktop\recievers.csv"

Set fso = CreateObject("Scripting.FileSystemObject")
Set txtSAM = fso.OpenTextFile(fp, 8, True, 0)
Set txtSAM = Nothing

Dim tocc_ As Variant: tocc_ = Split(TOCC, vbCrLf)
Dim lastname_ As Variant: lastname_ = Split(Lastname, vbCrLf)
Dim title_ As Variant: title_ = Split(Title, vbCrLf)
Dim office_ As Variant: office_ = Split(Office, vbCrLf)
Dim department_ As Variant: department_ = Split(Department, vbCrLf)
Dim fullname_ As Variant: fullname_ = Split(Displayname, vbCrLf)

Dim i As Long

    For i = LBound(tocc_) To UBound(tocc_)
    
        If tocc_(i) <> "" Then csvContent = csvContent & vbCrLf & tocc_(i) & "," & lastname_(i) & "," & title_(i) & "," & office_(i) & "," & department_(i) & "," & fullname_(i)
    
    Next

With fso.GetFile(fp).OpenAsTextStream(8)

    .WriteLine csvContent
    .Close

End With

Set fso = Nothing

End Sub

 

9行目：

出力するcsvファイルの1行目の見出しを設定しています

 

10行目：

csvファイルを出力する場所を設定しています

“nobby” の箇所は、お使いのPCによって異なりますので設定が必要です

 

各変数(Lastname、Title、Office、Department、Displayname)に格納されている値は、改行区切りとなっています

まずは改行区切りで値を分割して、配列に格納し、

さらに”,” （カンマ）区切りで再度結合させています

 

実行方法

VBEに上記のコードを記述すると、Outlook のマクロで、ShowRecieverAsCsv が選択できるようになります

メールを開いた状態で、ShowRecieverAsCsv を実行すると、デスクトップ上にcsvファイルが新規作成され、そのcsvファイル内に送信先の情報が記述されています

 

他のPCでも使用できるようにする方法

今回作成したプロシージャを他のPCでも使用できるようにするには、モジュールをエクスポートします

VBE上で、モジュールを右クリックし、”ファイルのエクスポート(E)” クリック

これでモジュールがエクスポートされます

今度は使用できるようにしたい他のPCのVBE上で、Project1 を右クリックし、”ファイルをインポート(I)” クリック

さきほどエクスポートしたファイルを選択します

これで今回作成したプロシージャが使用できるようになります

Outlookの初期設定ではVBAが使用できないようになっていることがあります

その場合の解決方法は下記の記事を参考にしてみてください

 

VBAエラー関係の解決方法
VBA使用時に発生する問題について解決方法を解説します マクロが起動しない office365などに更新した場合、IPアドレスを追加しないとマクロが起動しないことがあります IPアドレスの確認方法～IPアドレスを追加する方法を解説...
nobushige.com
2023.02.14

コメント

この記事が気に入ったら
いいね！しよう
最新情報をお届けします。
タイトルとURLをコピーしました