退屈なことは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を使うとできそう。

※Qiitaは3記事しか書いていないので、はてなブログに統合しようと思います。