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

비고