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

データベースを使わない、または外部のウェブサービスからのメールを受信していて、そのメールの中から住所を抜き出し、顧客分布を測定したい時がある。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”に結果を書き出す

実装したい機能

VBA スクリプト

コメントを残す コメントをキャンセル

コメントを残すコメントをキャンセル