VBA(受信メールを自動で出力) - Codeまとめby長谷川

受信したメールがメールアドレス、件名の場合に自動的にテキスト形式で保存する。

'定義なしの変数はエラー
Option Explicit

'デバッグ用フラグ
'1：ポップアップで値を表示、0：表示しない
Private Const debug_flag = 0

'新しいメールを受信したら実行されるプロシージャ
'引数：IDのリスト
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)

  If debug_flag = 1 Then
    MsgBox ("Application_NewMailEx")
  End If

  SaveToTxt EntryIDCollection

EndSub

'特定のメールをTXT出力するプロシージャ
Private Sub SaveToTxt(ByVal EntryIDCollection As String)

  If debug_flag = 1 Then
    MsgBox ("SaveToTxt")
  Endif

  '自動保存するメールの件名
  Const AUTO_SAVE_TITLE = "テストメール"
  '自動保存するメールのアドレス
  Const AUTO_SAVE_ADDRESS = "[e-mail]"
  '保存先
  Const TEXT_FILE = "D:\hoge.txt"

  Dim i As Integer
  Dim arrEntryId
  Dim myMsg
  Dim stmTxt
  Set stmTxt = Nothing

  arrEntryId = Split(EntryIDCollection, ",")

  For i = LBound(arrEntryId) To UBound(arrEntryId)
    Set myMsg = Application.Session.GetItemFromID(arrEntryId(i))

    If debug_flag = 1 Then
      MsgBox (myMsg.SenderEmailAddress)
      MsgBox (myMsg.Subject)
    End If

    'メールアドレス、件名を確認する
    If InStr (myMsg.Subject, AUTO_SAVE_TITLE) > 0 And InStr (myMsg.SenderEmailAddress, AUTO_SAVE_ADDRESS) Then
      If stmTxt Is Nothing Then
        'テキストオブジェクトの生成
        Set objFSO = CreateObject("Scripting.FileSystemObject")
        '[引数1]ファイル名
        '[引数2]1:RO、3:W、8:A
        '[引数3]ファイル無い場合 True：新規作成、False：エラーコード
        '[引数4]0：ASCII、-1：Unicode、-2：System value
        Set stmTxt = objFSO.OpenTextFile(TEXT_FILE, 2, True, -1)
      End If

      'Bodyを書き込み
      stmTxt.writeline myMsg.Body

      If debug_flag = 1 Then
        MsgBox (myMsg.Body)
      End If

    End if

  Next

  If Not stmTxt Is Nothing Then
    'ファイル開いていたらクローズ
    stmTxt.Close
  End If

End Sub