LoginSignup
8

More than 3 years have passed since last update.

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

Last updated at Posted at 2018-12-11

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

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
8