決まった件名のメッセージを受信したら、データを CSV ファイルに保存するマクロ-複数対応版


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


はじめて投稿させていただきます。過去の内容を参考に受信したメールの本文をSCVに出力しております。
過去内容:

メールの受信時に、決まった件名であれば、ある文字列以降の文字列を抽出し、
CSVファイルの最後に追加したいのです。
例えば、このような感じです。
件名 受注メール
商品番号 1234
商品名 ぽーしょん
数量 2
1234,ぽーしょん,2
このようなことができれば、メールから受注データを作成できるので、とても助かります。
よろしくお願いいたします。

ここでご質問なんですが、メール本文に
件名 受注メール
商品番号 1234
商品名 ぽーしょん
数量 2
——————————
件名 受注メール
商品番号 1234
商品名 ぽーしょん
数量 2

と複数存在した場合、
1234,ぽーしょん,2
1234,ぽーしょん,2

と2件存在させたいのですが試行錯誤しましたが出来ませんでした。
ご教授頂けると助かります。宜しくお願い致します。

■使用環境
Windows7
outlook2007

です。



元の投稿内容に該当するマクロは「決まった件名のメッセージを受信したら、データを CSV ファイルに保存するマクロ」ですね。
本文中に同じフォーマットで複数のデータが存在する場合の処理方法としては以下のようなものが考えられます。

  1. 本文のデータを文字列変数に入れ、処理が終わった分は削除して最初から繰り返す。
  2. 最初のデータを処理したところで処理が終わった分までの位置を記録し、その位置から次のデータの取得処理を繰り返す。

今回は 1 の方法で実装してみました。マクロは以下の通りです。

' ここをトリプルクリックでマクロ全体を選択できます。
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
    SaveToCsvMulti EntryIDCollection
End Sub
'
Private Sub SaveToCsvMulti(ByVal EntryIDCollection As String)
    Const AUTO_SAVE_TITLE = "受注メール" ' 自動処理するメールの件名
    Const CSV_FILE = "c:\orders\data.csv" ' データを保存する CSV ファイルの名前
    Dim i As Integer
    Dim arrEntryId
    Dim myMsg
    Dim stmCsv
    Set stmCsv = Nothing
    arrEntryId = Split(EntryIDCollection, ",")
    For i = LBound(arrEntryId) To UBound(arrEntryId)
        Set myMsg = Application.Session.GetItemFromID(arrEntryId(i))
        If myMsg.Subject = AUTO_SAVE_TITLE Then
            Dim strBody As String
            Dim strCode As String
            Dim strName As String
            Dim strQuantity As String
            If stmCsv Is Nothing Then
                Dim objFSO
                Set objFSO = CreateObject("Scripting.FileSystemObject")
                Set stmCsv = objFSO.OpenTextFile(CSV_FILE, 8, True, 0)
            End If
            strBody = myMsg.Body
            While InStr(strBody, "商品番号") > 0
                strCode = CutText("商品番号", strBody)
                strName = CutText("商品名", strBody)
                strQuantity = CutText("数量", strBody)
                stmCsv.WriteLine strCode & "," & strName & "," & strQuantity
            Wend
        End If
    Next
    If Not stmCsv Is Nothing Then
        stmCsv.Close
    End If
End Sub
' 本文からデータを取得し、取得した部分までの文字列を削除する関数
Private Function CutText(strName As String, ByRef strBody As String) As String
    Dim ls As Long
    Dim le As Long
    ls = InStr(strBody, strName) ' 指定されたフィールド名を検索
    If ls > 0 Then
        ls = ls + Len(strName) ' フィールド名の次の文字から
        le = InStr(ls, strBody, vbCrLf) ' 改行コードまでを取得
        CutText = Trim(Mid(strBody, ls, le - ls)) ' 前後の空白を削除
        strBody = Mid(strBody, le) ' 取得した部分までの文字列を削除
    Else
        CutText = ""
    End If
End Function

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

コメントを残す

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

WordPress.com ロゴ

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

Twitter 画像

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

Facebook の写真

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

Google+ フォト

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

%s と連携中