退屈なことはVBAにやらせよう
OutlookでもExcelと同じようにVBAが使えます。便利なのに、Excelと比較するとあまり知られていないため、少しでも広まればと。
なお、本コードはOutlook2013、2010で動作を確認しています。
定型項目の通知メールを別ファイルへ自動転記
申請だったり障害の通知メールだったりと、手動で転記することはつまらないのでVBAにやらせました。
次のコードは下記に当てはまっている必要があります。
- 項目名とデータが１行である事（改行をまたがない）
- １メールにつき、１内容である事
コード
- コード上段の定数を修正するだけで使いまわせます
- メールの項目数である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を使うとできそう。