id:radio1982
ポイントあり300ptベストアンサーあり
コンピュータ

OUTLOOKのVBAで特定のアドレスもしくは件名でシステムから書きだされたデータをCSVにしたいです。

【環境】
OS：windows 7
OutLook:2010


*************メール内容******************
受付番号：00000001
[ ご予約 第１希望日 ] 2013/01/22 (火曜日)
[ 第１希望日時　ご希望時間 ] 8:20
*******************************
どうぞよろしくおねがいいたします。

回答の条件
  • 1人50回まで
  • 登録：
  • 終了：2013/02/06 13:10:03
※ 有料アンケート・ポイント付き質問機能は2023年2月28日に終了しました。

ベストアンサー

id:Mook No.3

回答回数1314ベストアンサー獲得回数393

ポイント100pt

以前に回答したものをカスタマイズしたものですが、
http://q.hatena.ne.jp/1301122126

下記で受信したメールを処理できました（Outlook2010 で検証）。

OutLook の VBE で ThisOutlookSession の下にコードを置いて受信してみてください。

Option Explicit

'// 保存ファイルパス
'//------------------
Const CSVファイルパス = "D:\予約メール.csv"

Const ForReading = 1
Const ForWriting = 2
Const ForAppending = 8

'//---------------------------------------------------
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
'//---------------------------------------------------
    Const 保存件名 = "保存したいタイトル名" ' このタイトルを含むメールを保存
    
    Dim メール As MailItem
    Dim メールID As Variant
    For Each メールID In Split(EntryIDCollection, ",")
        Set メール = Session.GetItemFromID(メールID)
        If InStr(メール.Subject, 保存件名) > 0 Then
            CSVへ追記 メール.Body, メール.ReceivedTime
        End If
    Next
End Sub

'//---------------------------------------------------
Sub CSVへ追記(受信メッセージ, 受信時間)
'//---------------------------------------------------
    Dim fso
    Set fso = CreateObject("Scripting.FileSystemObject")

    Dim CSVファイル
    If fso.FileExists(CSVファイルパス) Then
        Set CSVファイル = fso.OpenTextFile(CSVファイルパス, ForAppending)
    Else
        Set CSVファイル = fso.CreateTextFile(CSVファイルパス)
        CSVファイル.WriteLine "受付番号,予約希望,希望時間,受信日時"
    End If

    Dim 一行
    
    Dim 受付番号 As String
    受付番号 = ""
    
    Dim 予約希望 As String
    予約希望 = ""
    
    Dim 希望時間 As String
    希望時間 = ""
    For Each 一行 In Split(受信メッセージ, vbNewLine)
        If InStr(一行, "受付番号：") > 0 Then
            受付番号 = Trim(Mid(一行, Len("受付番号：") + 1))
        End If
        
        If InStr(一行, "[ ご予約 第１希望日 ]") > 0 Then
            予約希望 = Trim(Mid(一行, Len("[ ご予約 第１希望日 ]") + 1))
        End If
        
        If InStr(一行, "[ 第１希望日時　ご希望時間 ]") > 0 Then
            希望時間 = Trim(Mid(一行, Len("[ 第１希望日時　ご希望時間 ]") + 1))
        End If
    Next

    CSVファイル.WriteLine """" & 受付番号 & """,""" & 予約希望 & """,""" & 希望時間 & """,""" & 受信時間 & """"
End Sub

--------------------------------------------------------------
コメントの関数を使用した修正コード
--------------------------------------------------------------

Option Explicit

'// 保存ファイルパス
'//------------------
Const CSVファイルパス = "D:\予約メール.csv"

Const ForReading = 1
Const ForWriting = 2
Const ForAppending = 8

'//---------------------------------------------------
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
'//---------------------------------------------------
    Const 保存件名 = "保存したいタイトル名" ' このタイトルを含むメールを保存
    
    Dim メール As MailItem
    Dim メールID As Variant
    For Each メールID In Split(EntryIDCollection, ",")
        Set メール = Session.GetItemFromID(メールID)
        If InStr(メール.Subject, 保存件名) > 0 Then
            CSVへ追記 メール.Body, メール.ReceivedTime
        End If
    Next
End Sub

'//---------------------------------------------------
Sub CSVへ追記(受信メッセージ, 受信時間)
'//---------------------------------------------------
    Dim fso
    Set fso = CreateObject("Scripting.FileSystemObject")

    Dim CSVファイル
    If fso.FileExists(CSVファイルパス) Then
        Set CSVファイル = fso.OpenTextFile(CSVファイルパス, ForAppending)
    Else
        Set CSVファイル = fso.CreateTextFile(CSVファイルパス)
    End If

    Dim 受付番号 As String
    Dim 予約希望 As String
    Dim 希望時間 As String
    
    受付番号 = getText("受付番号：", 受信メッセージ)
    予約希望 = getText("[ ご予約 第１希望日 ]", 受信メッセージ)
    希望時間 = getText("[ 第１希望日時　ご希望時間 ]", 受信メッセージ)

    CSVファイル.WriteLine """" & 受付番号 & """,""" & 予約希望 & """,""" & 希望時間 & """,""" & 受信時間 & """"
End Sub


' 値を取得する getText()関数を定義
Private Function getText(strTarget As String, strBody As String) As String
    Dim leng_s As Long ' 指定文字の開始位置
    Dim leng_e As Long ' 指定文字の終了位置
    leng_s = InStr(strBody, strTarget) ' 本文から指定文字の位置を返す
    
    If leng_s > 0 Then
        leng_s = leng_s + Len(strTarget) ' 文字の開始位置に文字数を足す
        leng_e = InStr(leng_s, strBody, vbCrLf) ' 指定文字の末尾から改行文字までの位置を返す
        strAns = Trim(Mid(strBody, leng_s, leng_e - leng_s)) ' 指定の文字間を切り取り、空白文字を削除
        
        getText = Replace(strAns, vbTab, "") ' タブ文字を置換
    Else
        getText = ""
    End If
End Function
他22件のコメントを見る
id:radio1982

早速ですみません。

> getText の先頭にブレークポイントを設定してメールを受信し

背景黄色→　メール = Session.GetItemFromID(メールID)

↓　F8

「実行時エラー'-2147221233(8004010f)':処理が失敗しました。オブジェクトがみつかりません。」

となりました。

【イミディエイト】

?Session(Enter)
Mapi

?メールID(Enter)
000000009A6A71664CD0E54892D9BE5698EEFC5724CD2000

となり、この「Session」や「メールID」は値がとれているようです。（素人でとれているという表現がただしいのかわかりませんが。。。）

ここに問題があるのだろうということくらいしかわからず
この後の対応方法が不明なんです。通常であればどのように問題点を切り分け解決にすすめていくのでしょう。。。


?メール(Enter)
エラーが発生します
内容は「実行時エラー'91'オブジェクト変数またはWith ブロック変数が設定されていません。」

以上が、イミディエイトで行った内容です。



ステップイン・ステップオーバー・ステップアウトいずれを行なっても同じ結果なんですね。


ここに問題があるのではと思い
「受付番号 = getText("受付番号：", CStr(受信メッセージ))」

受付番号を選択した状態で「クイックウォッチ」を実行

ウォッチリストに
式：受付番号　値：＜対象範囲外＞　型：Empty　対象：ThisOutlookSesseion.CSVへ追記

と出ています。

参考になるかわかりませんが、現状は以上になります。

2013/02/07 15:54:29
id:Mook

コメント遅くなりました。

こちらでは現象が再現しないので、なかなか原因がわからないのですが、
2013/02/04 18:46:30 のコメントで提示されていた outputcsvのマクロ（VBS ではなく VBA ですよね？）単体で動かしたときは、上手く動いたんでしょうか。

これがちゃんと動くのであれば、起動時にこれを毎回動かしてあげるのも手かもしれません。

もっとも、イベント処理になると今回と同じ現象が出るかもしれませんが。

2013/02/09 18:22:51

その他の回答（2件）

id:taknt No.1

回答回数13539ベストアンサー獲得回数1198

ポイント100pt

http://individualpackage.blog41.fc2.com/blog-entry-47.html

他26件のコメントを見る
id:taknt

環境の違いと書きましたが OUTLOOK 2003、2007、2010の違いは なかったですね。

あとは ＯＳによるものかもしれませんが それも影響は 少なそうな感じがします。

2013/01/31 10:30:20
id:taknt

http://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q1251293197

こちらでは ちゃんと本文がとれているようですから。

2013/01/31 10:38:26
id:pretaroe No.2

回答回数531ベストアンサー獲得回数75

ポイント100pt

Outlook 2007 受信メールの本文（一部）をCSVに書き出す
http://dot-town-lab.com/laboratory/item.php?id=32

＞ objItem.Subject = "注文メール"
ここを好きな件名に

id:radio1982

ありがとう御座います。

実は上記サイトも参考にさせていただきました。

OUTLOOKを立ち上げた時に新着メールだけを追記していくということがしたかったのですが

わたしの能力では今回頂きましたサイトの内容をうまくカスタマイズできなかった為、

takntさんより頂いたURLのページ内容で頑張っておりまして。。。。

ご助言ありがとうございます。

もし可能でありましたら引き続きよろしくお願い致します。

2013/02/01 17:05:50
id:Mook No.3

回答回数1314ベストアンサー獲得回数393ここでベストアンサー

ポイント100pt

以前に回答したものをカスタマイズしたものですが、
http://q.hatena.ne.jp/1301122126

下記で受信したメールを処理できました（Outlook2010 で検証）。

OutLook の VBE で ThisOutlookSession の下にコードを置いて受信してみてください。

Option Explicit

'// 保存ファイルパス
'//------------------
Const CSVファイルパス = "D:\予約メール.csv"

Const ForReading = 1
Const ForWriting = 2
Const ForAppending = 8

'//---------------------------------------------------
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
'//---------------------------------------------------
    Const 保存件名 = "保存したいタイトル名" ' このタイトルを含むメールを保存
    
    Dim メール As MailItem
    Dim メールID As Variant
    For Each メールID In Split(EntryIDCollection, ",")
        Set メール = Session.GetItemFromID(メールID)
        If InStr(メール.Subject, 保存件名) > 0 Then
            CSVへ追記 メール.Body, メール.ReceivedTime
        End If
    Next
End Sub

'//---------------------------------------------------
Sub CSVへ追記(受信メッセージ, 受信時間)
'//---------------------------------------------------
    Dim fso
    Set fso = CreateObject("Scripting.FileSystemObject")

    Dim CSVファイル
    If fso.FileExists(CSVファイルパス) Then
        Set CSVファイル = fso.OpenTextFile(CSVファイルパス, ForAppending)
    Else
        Set CSVファイル = fso.CreateTextFile(CSVファイルパス)
        CSVファイル.WriteLine "受付番号,予約希望,希望時間,受信日時"
    End If

    Dim 一行
    
    Dim 受付番号 As String
    受付番号 = ""
    
    Dim 予約希望 As String
    予約希望 = ""
    
    Dim 希望時間 As String
    希望時間 = ""
    For Each 一行 In Split(受信メッセージ, vbNewLine)
        If InStr(一行, "受付番号：") > 0 Then
            受付番号 = Trim(Mid(一行, Len("受付番号：") + 1))
        End If
        
        If InStr(一行, "[ ご予約 第１希望日 ]") > 0 Then
            予約希望 = Trim(Mid(一行, Len("[ ご予約 第１希望日 ]") + 1))
        End If
        
        If InStr(一行, "[ 第１希望日時　ご希望時間 ]") > 0 Then
            希望時間 = Trim(Mid(一行, Len("[ 第１希望日時　ご希望時間 ]") + 1))
        End If
    Next

    CSVファイル.WriteLine """" & 受付番号 & """,""" & 予約希望 & """,""" & 希望時間 & """,""" & 受信時間 & """"
End Sub

--------------------------------------------------------------
コメントの関数を使用した修正コード
--------------------------------------------------------------

Option Explicit

'// 保存ファイルパス
'//------------------
Const CSVファイルパス = "D:\予約メール.csv"

Const ForReading = 1
Const ForWriting = 2
Const ForAppending = 8

'//---------------------------------------------------
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
'//---------------------------------------------------
    Const 保存件名 = "保存したいタイトル名" ' このタイトルを含むメールを保存
    
    Dim メール As MailItem
    Dim メールID As Variant
    For Each メールID In Split(EntryIDCollection, ",")
        Set メール = Session.GetItemFromID(メールID)
        If InStr(メール.Subject, 保存件名) > 0 Then
            CSVへ追記 メール.Body, メール.ReceivedTime
        End If
    Next
End Sub

'//---------------------------------------------------
Sub CSVへ追記(受信メッセージ, 受信時間)
'//---------------------------------------------------
    Dim fso
    Set fso = CreateObject("Scripting.FileSystemObject")

    Dim CSVファイル
    If fso.FileExists(CSVファイルパス) Then
        Set CSVファイル = fso.OpenTextFile(CSVファイルパス, ForAppending)
    Else
        Set CSVファイル = fso.CreateTextFile(CSVファイルパス)
    End If

    Dim 受付番号 As String
    Dim 予約希望 As String
    Dim 希望時間 As String
    
    受付番号 = getText("受付番号：", 受信メッセージ)
    予約希望 = getText("[ ご予約 第１希望日 ]", 受信メッセージ)
    希望時間 = getText("[ 第１希望日時　ご希望時間 ]", 受信メッセージ)

    CSVファイル.WriteLine """" & 受付番号 & """,""" & 予約希望 & """,""" & 希望時間 & """,""" & 受信時間 & """"
End Sub


' 値を取得する getText()関数を定義
Private Function getText(strTarget As String, strBody As String) As String
    Dim leng_s As Long ' 指定文字の開始位置
    Dim leng_e As Long ' 指定文字の終了位置
    leng_s = InStr(strBody, strTarget) ' 本文から指定文字の位置を返す
    
    If leng_s > 0 Then
        leng_s = leng_s + Len(strTarget) ' 文字の開始位置に文字数を足す
        leng_e = InStr(leng_s, strBody, vbCrLf) ' 指定文字の末尾から改行文字までの位置を返す
        strAns = Trim(Mid(strBody, leng_s, leng_e - leng_s)) ' 指定の文字間を切り取り、空白文字を削除
        
        getText = Replace(strAns, vbTab, "") ' タブ文字を置換
    Else
        getText = ""
    End If
End Function
他22件のコメントを見る
id:radio1982

早速ですみません。

> getText の先頭にブレークポイントを設定してメールを受信し

背景黄色→　メール = Session.GetItemFromID(メールID)

↓　F8

「実行時エラー'-2147221233(8004010f)':処理が失敗しました。オブジェクトがみつかりません。」

となりました。

【イミディエイト】

?Session(Enter)
Mapi

?メールID(Enter)
000000009A6A71664CD0E54892D9BE5698EEFC5724CD2000

となり、この「Session」や「メールID」は値がとれているようです。（素人でとれているという表現がただしいのかわかりませんが。。。）

ここに問題があるのだろうということくらいしかわからず
この後の対応方法が不明なんです。通常であればどのように問題点を切り分け解決にすすめていくのでしょう。。。


?メール(Enter)
エラーが発生します
内容は「実行時エラー'91'オブジェクト変数またはWith ブロック変数が設定されていません。」

以上が、イミディエイトで行った内容です。



ステップイン・ステップオーバー・ステップアウトいずれを行なっても同じ結果なんですね。


ここに問題があるのではと思い
「受付番号 = getText("受付番号：", CStr(受信メッセージ))」

受付番号を選択した状態で「クイックウォッチ」を実行

ウォッチリストに
式：受付番号　値：＜対象範囲外＞　型：Empty　対象：ThisOutlookSesseion.CSVへ追記

と出ています。

参考になるかわかりませんが、現状は以上になります。

2013/02/07 15:54:29
id:Mook

コメント遅くなりました。

こちらでは現象が再現しないので、なかなか原因がわからないのですが、
2013/02/04 18:46:30 のコメントで提示されていた outputcsvのマクロ（VBS ではなく VBA ですよね？）単体で動かしたときは、上手く動いたんでしょうか。

これがちゃんと動くのであれば、起動時にこれを毎回動かしてあげるのも手かもしれません。

もっとも、イベント処理になると今回と同じ現象が出るかもしれませんが。

2013/02/09 18:22:51

コメント（2件)

この質問への反応（ブックマークコメント）

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

回答リクエストを送信したユーザーはいません
ユーザー登録をして使いはじめる!無料
すでに登録されている方はこちらからログイン
この質問に含まれるキーワード
知りたいことを検索してみよう
▲ページトップへ