Outlook VBAで定型項目の通知メールを自動転記する


退屈なことはVBAにやらせよう

OutlookでもExcelと同じようにVBAが使えます。便利なのに、Excelと比較するとあまり知られていないため、少しでも広まればと。

なお、本コードはOutlook2013、2010で動作を確認しています。


定型項目の通知メールを別ファイルへ自動転記



申請だったり障害の通知メールだったりと、手動で転記することはつまらないのでVBAにやらせました。

次のコードは下記に当てはまっている必要があります。


  • 項目名とデータが1行である事(改行をまたがない)

  • 1メールにつき、1内容である事


コード


  • コード上段の定数を修正するだけで使いまわせます

  • メールの項目数であるitemArrayの要素数を増やしたからと言って、コードを修正する必要はない

  • 転記先のファイルが他のアプリケーションで使用中の場合、同じフォルダに別途ファイルを作成し書き込む

Const MAIL_TITLE As String = "【AAシステム】申請連絡"   '対象とするメールの件名

Const FILE_NAME As String = "XXシステム管理表.csv" '管理表の名前
Const FILE_NAME_TEMP As String = "_XXシステム申請.csv" '管理表が開かれているときに書き込むファイル名
Const FILE_PATH As String = "d:\temp\" '管理表のパス
Const itemArray As String = "申請番号:,申請区分:,コード:,名前:" '項目。splitで分割するため、区切りの為の半角SPは入れない
Const MSG_ERR_NUMBER = "エラー番号:"
Const MSG_ERR_DESCRIPTION = "エラー種類:"

'メール受信時に発生するイベント
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)

Dim myMsg As Object
Set myMsg = Session.GetItemFromID(EntryIDCollection)

'全てのメール受信時に発生する為、管理しやすいよう関数の呼び出しに留める
Call MainExportXXsystemToCSV(myMsg) 'メールの任意の項目を自動転記する

Set myMsg = Nothing
End Sub

'メールの任意の項目を自動転記する関数
Private Function MainExportXXsystemToCSV(ByRef myMsg As Object)

On Error GoTo EXPORT_ERR

Dim itemXXsystem() As String
itemXXsystem = Split(itemArray, ",") '管理表の項目を設定

'対象の件名に対し処理を行う
If myMsg.Subject Like MAIL_TITLE Then

Dim wkData() As String
wkData = FetchItemByMailBody(myMsg.Body, itemXXsystem()) 'メール本文からデータを抜き出す

Dim i As Long
Dim wkstr As String
wkstr = myMsg.ReceivedTime & "," '先頭の項目を受信日時とする
For i = 0 To UBound(wkData) ' データをまとめる
wkstr = wkstr & wkData(i) & ","
Next

Dim dstfile As String ' ファイルに書き込む
If IsFileOpen(FILE_PATH & FILE_NAME) = False Then
Dim strrnd As String
Randomize
strrnd = "_" & Format((Int(1000 * Rnd)), "0000") 'キーとなる項目が重複しても、ファイル名が重複しないように。

dstfile = FILE_PATH & wkData(0) & strrnd & FILE_NAME_TEMP
Else
dstfile = FILE_PATH & FILE_NAME
End If

Dim fnum As Integer
fnum = FreeFile

Open dstfile For Append As fnum
Print #fnum, wkstr
Close #fnum

End If
Exit Function

EXPORT_ERR:
MsgBox MSG_ERR_NUMBER & Err.Number & vbCrLf & _
MSG_ERR_DESCRIPTION & Err.Description, vbExclamation

End Function

'メール本文から指定項目のデータを取得する関数
Private Function FetchItemByMailBody(ByVal strBody As String, ByRef itemXXsystem() As String) As String()

Dim stritem() As String
Dim max As Long

max = UBound(itemXXsystem)
ReDim stritem(max) '取得した項目を格納する

Dim i As Long
Dim sline As Long
Dim eline As Long
Dim strline As String

For i = 0 To max
sline = InStr(strBody, itemXXsystem(i)) '取得したい項目の開始位置

If sline > 0 Then
strline = Mid(strBody, sline + Len(itemXXsystem(i))) '取得したい項目の先頭から最後までを取得
eline = InStr(strline, vbCrLf) '取得したい項目の最後尾(改行)の位置を取得
stritem(i) = Left(strline, eline - 1) '-1により改行分を削除
Else
stritem(i) = ""
End If
Next

FetchItemByMailBody = stritem()

End Function

' ファイルがすでに開かれているか確認する関数
Private Function IsFileOpen(ByVal dst_file As String) As Boolean
On Error GoTo FILE_ERR

Dim fnum As Integer
fnum = FreeFile

Open dst_file For Binary Access Read Lock Read As #fnum
Close #fnum
IsFileOpen = True

Exit Function

FILE_ERR:
IsFileOpen = False

End Function


備考

実運用では、転記先のファイル(=管理表)にフラグを追加し実施未実施を管理します。

対象とするメールの条件に、件名だけでなく送信元も追加することでより強固になるかも。

また、エラーのメッセージボックスを表示した際、処理を止めないにしたほうがいいのかどうか。応答不要のメッセージボックスを実装するならVBAのMsgBoxでは出来ないっぽいです。色々調べたらユーザーフォームやWMIを使うとできそう。