Outlook – リボン日記

データベースを使わない、または外部のウェブサービスからのメールを受信していて、そのメールの中から住所を抜き出し、顧客分布を測定したい時がある。Excel とOutlook ならVBA が使えるので、それを一部自動化した。

この解説は、限られた条件で使ったものなので、サンプルプログラムとして記録を残す。

前提

Oltlook の受信トレイに「予約」フォルダ、その直下に「A店」と「B店」のフォルダがある

受信トレイ
└予約
├A店
└B店

それぞれのフォルダはOutlook のルールで、件名ごとにフォルダ分けされるようになっている

「A店」と「B店」に保存されたメールの中に、「住所」情報がある

実装したい機能

指定したフォルダを次々に読み込んで、住所を抜き出し、都道府県、市町村、区、その他で横方向のセルに挿入する

セルは横方向が属性、縦方向がメールごとの内容にして、データを表に入力する

VBA スクリプト

'Outlook の指定フォルダから､一気にメール内容の住所を取得して､都道府県､市､区､で分ける
'「住所」の次の行を調べているだけなので、メールがメールフォームを使わずに返信してきた場合は住所が決まった位置に書かれていないため抜ける

'全てのプロシージャで使用できる変数宣言
Dim subFolder As String ' サブフォルダ名
Dim folderArray() As String ' 選択するフォルダ名
Dim nextRow As Long '挿入するセルの開始行

Sub GetCustomersAddress()

    '初期設定
    'フォルダ構造は次のようになっている
    '受信トレイOutlook 2013
    '└予約
    '　├A店
    '　├B店
    '　└C店
    ReDim folderArray(2)
    subFolder = "予約"
    folderArray(1) = "A店"
    folderArray(2) = "B店"

    nextRow = 2

    '指定したフォルダ内にGetMail()の処理を実施する
    Call GetMail(subFolder, folderArray(1), nextRow)
    Call GetMail(subFolder, folderArray(2), nextRow)

End Sub

'Outlook にある指定されたフォルダを順に読み込み、「住所」が書かれた行の次の行にある住所を、都道府県、市区町村、以下で分けてセルに記載する
Function GetMail(ByVal nowFolder As String, ByVal ssFolder As String, ByVal nowRow As Long)
    Dim objOutlook As Outlook.Application
    Dim myNamespace As Outlook.Namespace
    Dim myInbox, mySubfolder

    Set objOutlook = New Outlook.Application ' Outlook アプリケーションオブジェクトの取得
    Set myNamespace = objOutlook.GetNamespace("MAPI") ' Outlook のメールフォルダにアクセスするためのNamespace オブジェクトを取得
    
    ' GetDefaultFolder() の引数olFolderInbox は、受信トレイフォルダー(メール)を指す
    Set myInbox = myNamespace.GetDefaultFolder(olFolderInbox) ' 受信トレイのフォルダオブジェクトを取得
    Set mySubfolder = myInbox.Folders(nowFolder).Folders(ssFolder) ' 引数で指定された階層のサブフォルダオブジェクトを取得


    Dim i As Long
    Dim ij As Integer
    Dim textSolo As String
    Dim stringLine As String
    Dim sPrefecture As String
    Dim sCity As String
    Dim sKu As String

    ' 取得したサブフォルダmySubfolder のアイテム数をすべて読む
    For i = 1 To mySubfolder.Items.Count
      'シート"email"を指定
      With ThisWorkbook.Worksheets("email")
        arrayLine = Split(mySubfolder.Items(i).Body, vbCrLf) 'メール本文を改行で分割
        '住所を書き出す
        For ij = LBound(arrayLine) To UBound(arrayLine)
            stringLine = arrayLine(ij)
            ' 行が指定のキーワード「住所」なのか確認
            If stringLine Like "*住所*" Then
                textSolo = arrayLine(ij + 1)
                '都道府県
                If (InStr(textSolo, "道") <> 0) Or (InStr(textSolo, "東京都") <> 0) Or (InStr(textSolo, "府") <> 0) Then
                    sPrefecture = Mid(textSolo, 1, 3) ' 都道府県を取得
                    textSolo = Right(textSolo, Len(textSolo) - 3) ' testSolo から都道府県を削除
                ElseIf (InStr(textSolo, "県") <> 0) Then
                    sPrefecture = Mid(textSolo, 1, InStr(textSolo, "県"))
                    textSolo = Right(textSolo, Len(textSolo) - InStr(textSolo, "県"))
                ElseIf (InStr(textSolo, "名古屋市") <> 0) Then
                    '名古屋市から書き始める人用
                    sPrefecture = "愛知県"
                End If
                .Cells(i + nowRow, 2).Value = sPrefecture ' 都道府県を指定されたセルに記載
                
                '市
                If (InStr(textSolo, "市") <> 0) Then
                    sCity = Mid(textSolo, 1, InStr(textSolo, "市")) ' 市を取得
                    textSolo = Right(textSolo, Len(textSolo) - InStr(textSolo, "市")) ' textSolo から市までを削除
                ElseIf (InStr(textSolo, "郡") <> 0) Then
                    sCity = Mid(textSolo, 1, InStr(textSolo, "郡"))
                    textSolo = Right(textSolo, Len(textSolo) - InStr(textSolo, "郡"))
                Else
                    sCity = ""
                End If
                .Cells(i + nowRow, 3).Value = sCity ' 市を指定されたセルに記載
                '区
                If (InStr(textSolo, "区") <> 0) Then
                    sKu = Mid(textSolo, 1, InStr(textSolo, "区")) ' 句を取得
                    textSolo = Right(textSolo, Len(textSolo) - InStr(textSolo, "区")) ' textSolo から区までを削除
                Else
                    sKu = ""
                End If
                .Cells(i + nowRow, 4).Value = sKu ' 区を指定されたセルに記載
                .Cells(i + nowRow, 5).Value = textSolo ' それ以外の住所を指定されたセルに記載
            End If
        Next
      End With
    Next i

    nextRow = nowRow + mySubfolder.Items.Count
End Function

100

101

102

103

'Outlook の指定フォルダから､一気にメール内容の住所を取得して､都道府県､市､区､で分ける

'「住所」の次の行を調べているだけなので、メールがメールフォームを使わずに返信してきた場合は住所が決まった位置に書かれていないため抜ける

'全てのプロシージャで使用できる変数宣言

Dim subFolder As String ' サブフォルダ名

Dim folderArray() As String ' 選択するフォルダ名

Dim nextRow As Long '挿入するセルの開始行

Sub GetCustomersAddress()

'初期設定

'フォルダ構造は次のようになっている

'受信トレイOutlook 2013

'└予約

'　├A店

'　├B店

'　└C店

ReDim folderArray(2)

subFolder = "予約"

folderArray(1) = "A店"

folderArray(2) = "B店"

nextRow = 2

'指定したフォルダ内にGetMail()の処理を実施する

Call GetMail(subFolder, folderArray(1), nextRow)

Call GetMail(subFolder, folderArray(2), nextRow)

End Sub

'Outlook にある指定されたフォルダを順に読み込み、「住所」が書かれた行の次の行にある住所を、都道府県、市区町村、以下で分けてセルに記載する

Function GetMail(ByVal nowFolder As String, ByVal ssFolder As String, ByVal nowRow As Long)

Dim objOutlook As Outlook.Application

Dim myNamespace As Outlook.Namespace

Dim myInbox, mySubfolder

Set objOutlook = New Outlook.Application ' Outlook アプリケーションオブジェクトの取得

Set myNamespace = objOutlook.GetNamespace("MAPI") ' Outlook のメールフォルダにアクセスするためのNamespace オブジェクトを取得

' GetDefaultFolder() の引数olFolderInbox は、受信トレイフォルダー(メール)を指す

Set myInbox = myNamespace.GetDefaultFolder(olFolderInbox) ' 受信トレイのフォルダオブジェクトを取得

Set mySubfolder = myInbox.Folders(nowFolder).Folders(ssFolder) ' 引数で指定された階層のサブフォルダオブジェクトを取得

Dim i As Long

Dim ij As Integer

Dim textSolo As String

Dim stringLine As String

Dim sPrefecture As String

Dim sCity As String

Dim sKu As String

' 取得したサブフォルダmySubfolder のアイテム数をすべて読む

For i = 1 To mySubfolder.Items.Count

'シート"email"を指定

With ThisWorkbook.Worksheets("email")

arrayLine = Split(mySubfolder.Items(i).Body, vbCrLf) 'メール本文を改行で分割

'住所を書き出す

For ij = LBound(arrayLine) To UBound(arrayLine)

stringLine = arrayLine(ij)

' 行が指定のキーワード「住所」なのか確認

If stringLine Like "*住所*" Then

textSolo = arrayLine(ij + 1)

'都道府県

If (InStr(textSolo, "道") <> 0) Or (InStr(textSolo, "東京都") <> 0) Or (InStr(textSolo, "府") <> 0) Then

sPrefecture = Mid(textSolo, 1, 3) ' 都道府県を取得

textSolo = Right(textSolo, Len(textSolo) - 3) ' testSolo から都道府県を削除

ElseIf (InStr(textSolo, "県") <> 0) Then

sPrefecture = Mid(textSolo, 1, InStr(textSolo, "県"))

textSolo = Right(textSolo, Len(textSolo) - InStr(textSolo, "県"))

ElseIf (InStr(textSolo, "名古屋市") <> 0) Then

'名古屋市から書き始める人用

sPrefecture = "愛知県"

End If

.Cells(i + nowRow, 2).Value = sPrefecture ' 都道府県を指定されたセルに記載

'市

If (InStr(textSolo, "市") <> 0) Then

sCity = Mid(textSolo, 1, InStr(textSolo, "市")) ' 市を取得

textSolo = Right(textSolo, Len(textSolo) - InStr(textSolo, "市")) ' textSolo から市までを削除

ElseIf (InStr(textSolo, "郡") <> 0) Then

sCity = Mid(textSolo, 1, InStr(textSolo, "郡"))

textSolo = Right(textSolo, Len(textSolo) - InStr(textSolo, "郡"))

Else

sCity = ""

End If

.Cells(i + nowRow, 3).Value = sCity ' 市を指定されたセルに記載

'区

If (InStr(textSolo, "区") <> 0) Then

sKu = Mid(textSolo, 1, InStr(textSolo, "区")) ' 句を取得

textSolo = Right(textSolo, Len(textSolo) - InStr(textSolo, "区")) ' textSolo から区までを削除

Else

sKu = ""

End If

.Cells(i + nowRow, 4).Value = sKu ' 区を指定されたセルに記載

.Cells(i + nowRow, 5).Value = textSolo ' それ以外の住所を指定されたセルに記載

End If

End With

Next i

nextRow = nowRow + mySubfolder.Items.Count

End Function

動作

スクリプトを実行すると、シート”email”に結果を書き出す

ビジネスで使うメールアカウント宛てにスパムメールが届くことがある。届くこと自体で、スパムメールを全く受け取っていない人より仕事の処理能力が低下する。それに、セキュリティリスクにもつながる。スパムメールを迎撃する方法を探った。

メールアカウント名を変える

アカウント名の変更は、名刺に書いてあるから現実的ではないと考える方もいるだろう。
しかし、ダークウェブで販売されている個人情報リストから逃れられる。

手順

新アカウントを作成してメーラーに設定
取引相手にBCC でメールアカウント変更を通知、ウェブサービスで同メールを利用している場合は新しいものに変更する
通知後、1か月間は古いメールアカウントを新しいメールアカウントに転送
1か月経過したら古いメールアカウントの転送を停止、自動返信で利用停止した旨を伝えて、企業サイトの問い合わせフォームに誘導する

メールアカウントの変更許可が下りない場合

G-Suite を使う

Google が提供するGmail のビジネス版。スパムメールフィルタが強力。

Outlook を使って2秒でスパムメールを通報するショートカットを作る

「クイック操作」で、スパムメールを通報して削除するショートカットを使う
対象：Outlook 2013

設定方法

リボンにデフォルトで設定されている「クイック操作」右下「クイック操作の管理」
＞新規作成＞転送＞名前に「迷惑メールを通報」、転送先に「meiwaku@dekyo.or.jp」を記載
「オプション」をクリック＞「アクションの追加」で「メッセージを削除」を選択
ショートカットキーで「Ctrl+Shift+1」を選択(使いやすいものを選ぶ
「保存」をクリック＞「OK」をクリック

動作の確認

メールを1つ選び、設定したショートカットキーを押す
転送メールが作成され、画像が削除されるのを確認する

スパムメール通報のテンプレートを作る

スパムメールを通報するメールを作成し、Outlook テンプレート(*.oft)として保存。

作成方法

「新しい電子メール」をクリック＞宛先に「meiwaku@dekyo.or.jp」を入力、件名に「迷惑メールを転送」、本文に「よろしくお願いします。」を記載する
＞ファイル＞名前を付けて保存＞ファイルの種類で「Outlook テンプレート(*.oft)」を選択

テンプレートファイルが次のフォルダに入っているので、ファイルを選択してランチャーに追加する
C:\Users\{パソコンのアカウント名}\AppData\Roaming\Microsoft\Templates

使い方

ランチャーから「迷惑メールを転送」を開き、スパムメールをすべてドラッグして添付すして送信する

ランチャーとは：アプリを呼び出すソフトウェア。わたしはOrchis を使っている

追記：2019年11月11日(月)

スパム通報経過報告

最近、スパムメールの受信数が減ったので、送信したスパムメールの通報回数(件数ではない)を月ごとに集計してみた。上記のように減少傾向だ。

理由は不明だが、流出したメールアドレスリストの鮮度が低下したか、通報先の組織がしらみつぶしに対策したかと思われる。

タグ: Outlook

Outlook のメールを読んで、指定した情報をVBAを使って抜き出す

実装したい機能

VBA スクリプト

ビジネスアカウント宛てのスパムメールを楽に迎撃する

メールアカウント名を変える

手順

メールアカウントの変更許可が下りない場合

G-Suite を使う

Outlook を使って2秒でスパムメールを通報するショートカットを作る

設定方法

動作の確認

スパムメール通報のテンプレートを作る

作成方法

使い方

スパム通報経過報告