Excel ファイルのキーワードをもとに転送するマクロ


コメントにて以下のようなご要望をいただきました。


”本文に特定の文面を含む場合に、そのメールとファイルを添付して転送するマクロ”を参考にしたいのですが、”特定の文面”の条件をエクセルで複数指定して、そのすべての語句がふくまれる場合にそのメールをエクセルに記述したの指定のアドレスに転送するマクロを作りたいのですが、可能なのでしょうか?
環境:win7 outlook2010 excel2010 メール:exchange
開始トリガー・・上記VBAのまま新規メール受信時or指定ホルダー振り分け時のどちらか
条件語句・・単一→複数and指定(8個)
条件は直接記述→エクセルで指定管理
転送先アドレス→上記同一シートで条件指定の後ろのセルに指定
エクセルの記述(複数)
条件通しno、条件1、条件2、・・・条件8、転送アドレス1、転送アドレス2
このようなコントロールは可能なのでしょうか?



Outlook のマクロなら Excel ファイルを参照し、それによって転送することも可能です。
下記は、ご要望の動作を行うマクロのサンプルです。1 行目はヘッダーとして扱い、2 行目から 1 行ずつ条件および転送先指定を記述することを想定しています。
条件が8つに満たない場合は空白とし、転送アドレスは J 列から記載してください。

' ここをトリプルクリックでマクロ全体を選択できます。
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
    Dim objItem
    Set objItem = Session.GetItemFromID(EntryIDCollection)
    If objItem.MessageClass = "IPM.Note" Then
        ForwardByKeywords objItem
    End If
End Sub
'
Sub ForwardByKeywords(ByVal objMail As MailItem)
    Const KEYWORD_FILE = "c:\test\keywords.xlsx" ' Excel ファイルを指定
    Const START_ROW = 2
    Const KEYWORD_START = 2
    Const KEYWORD_END = 9
    Dim objWorkbook
    Dim objSheet
    Dim r As Integer
    Dim c As Integer
    Dim bFound As Boolean
    Dim objForward As MailItem
    ' Excel ファイルを開く
    Set objWorkbook = GetObject(KEYWORD_FILE)
    Set objSheet = objWorkbook.Sheets(1)
    r = START_ROW
    ' 項目番号が空白になるまで実行
    While objSheet.Cells(r, 1) <> ""
        bFound = True
        ' キーワードチェック
        For c = KEYWORD_START To KEYWORD_END
            If objSheet.Cells(r, c) = "" Then
                If c = KEYWORD_START Then
                    bFound = False
                End If
                Exit For
            End If
            ' キーワードが本文になければループを抜ける
            If InStr(objMail.Body, objSheet.Cells(r, c)) = 0 Then
                bFound = False
                Exit For
            End If
        Next
        ' すべて一致したら転送処理
        If bFound Then
            ' 転送メッセージを作成
            Set objForward = objMail.Forward
            c = KEYWORD_END + 1
            ' セルが空白になるまで宛先に追加
            While objSheet.Cells(r, c) <> ""
                objForward.Recipients.Add objSheet.Cells(r, c)
                c = c + 1
            Wend
            ' 転送メッセージを送信
            objForward.Send
        End If
        r = r + 1
    Wend
End Sub

マクロの登録方法やメニューへの追加について

広告

Excel ファイルのキーワードをもとに転送するマクロ」への1件のフィードバック

  1. ありがとうございました。
    実装できましたが少し手を入れ転送するメールの本文の頭に配信先名を追加すること、
    および簡単なメッセージを付けるように追加してみます

コメントを残す

以下に詳細を記入するか、アイコンをクリックしてログインしてください。

WordPress.com ロゴ

WordPress.com アカウントを使ってコメントしています。 ログアウト / 変更 )

Twitter 画像

Twitter アカウントを使ってコメントしています。 ログアウト / 変更 )

Facebook の写真

Facebook アカウントを使ってコメントしています。 ログアウト / 変更 )

Google+ フォト

Google+ アカウントを使ってコメントしています。 ログアウト / 変更 )

%s と連携中