人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

OUTLOOKのVBAで特定のアドレスもしくは件名でシステムから書きだされたデータをCSVにしたいです。
【環境】
OS:windows 7
OutLook:2010


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

●質問者: radioZJ
●カテゴリ:コンピュータ
○ 状態 :終了
└ 回答数 : 3/3件

▽最新の回答へ

1 ● きゃづみぃ
●100ポイント

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


radioZJさんのコメント
早速のご回答ありがとう御座います。 実は、上記ページの内容を行ったのですが、結果がきちんと取れずに 「,,,,,,,,,,」となってしまうのです。。。

きゃづみぃさんのコメント
strKubun = GetText("区分", myMsg.Body) strTCode = GetText("取引先コード", myMsg.Body) strSCode = GetText("商品コード", myMsg.Body) strKazu = GetText("数量", myMsg.Body) この箇所を 希望する内容のものに変更しないとダメですね。 strKubun = GetText("受付番号:", myMsg.Body) strTCode = GetText("[ ご予約 第1希望日 ] ", myMsg.Body) strSCode = GetText("[ 第1希望日時 ご希望時間 ] ", myMsg.Body) stmCsv.writeline strKubun & "," & strTCode & "," & strSCode & "," & dateRec

radioZJさんのコメント
ありがとう御座います。 確かに、内容変更が必要ですよね。 内容についても変更を行ったのですが。。。 なかなかうまくいきませんでした。。。 *************メール内容****************** 受付番号:00000001 [ ご予約 第1希望日 ] 2013/01/22 (火曜日) [ 第1希望日時 ご希望時間 ] 8:20 ******************************* Private Sub SaveToCsv(ByVal EntryIDCollection As String) Const AUTO_SAVE_TITLE = “お問い合せ” ‘ Const AUTO_SAVE_ADDRESS = “ooo@xxx.ne.jp” ‘ Const CSV_FILE = “C:\mailform\Data.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 strUketuke Dim strDate1 Dim strTime1 If stmCsv Is Nothing Then Dim objFSO Set objFSO = CreateObject(“Scripting.FileSystemObject”) Set stmCsv = objFSO.OpenTextFile(CSV_FILE, 8, True, 0) End If strUketuke = GetText(“受付番号”, myMsg.Body) strDate1 = GetText(“[ ご予約 第1希望日 ]“, myMsg.Body) strTime1 = GetText(“[ 第1希望日時 ご希望時間 ]“, myMsg.Body) stmCsv.writeline strUketuke & “,” & strDate1 & “,” & strTime1 End If Next If Not stmCsv Is Nothing Then stmCsv.Close End If End Sub Private Function GetText(strName As String, 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) GetText = Trim(Mid(strBody, ls, le - ls)) Else GetText = “” End If End Function *************************************************************

きゃづみぃさんのコメント
結果は どうなりました?

radioZJさんのコメント
,,,でした

きゃづみぃさんのコメント
GetTextの関数の中の ls = InStr(strBody, strName) の箇所で ブレイクさせてみしまょう。 その時、strBodyと strNameねは 何に なってますか? また その行を 実行すると lsは いくつになりますか?

radioZJさんのコメント
すみません。私はVBについてあまり詳しくないもので、 ・「ブレイクさせる」が正しくできているか判断がつかないです。 ・ご指示の行だけを実行はどのようにすればよいのでしょうか? 調べることろはキチンとしらべますのでご教授よろしくお願いいたします。

きゃづみぃさんのコメント
ls = InStr(strBody, strName) の行のところで F9を押してから最初から実行させると その行で とまります。 そのときに その変数の中身が 見れます。 イミディエイトの箇所で ? strBody ? strName とすれば それぞれの内容が 確認できます。 あとは F8を 押して ステップ実行させます。

radioZJさんのコメント
おっしゃるとおり F9→赤くアクティブになりました F8で実行し ls = InStr(strBody, strName) が黄色くなりカーソルを合わせると is = 0 とポップアップしてます

きゃづみぃさんのコメント
その時点の strBodyとstrNameの内容が重要なのです。

radioZJさんのコメント
理解に時間がかかりすみません ? strBody ? strName(ここでenterをおすと) 「受付番号」と文字がでました。

きゃづみぃさんのコメント
strBodyの内容がないのが 問題ですね。 ちゃんとリンク先のソースを貼りつけました? あと 指定した行まできたなら問題ないと思うけど Const AUTO_SAVE_TITLE = "受注情報" ' 自動処理するメールの件名 Const AUTO_SAVE_ADDRESS = "juchu@xxx.co.jp" ' 自動処理する送信元メールアドレス なども 設定しないとダメです。

きゃづみぃさんのコメント
ま、 Const AUTO_SAVE_TITLE = “お問い合せ” ‘ Const AUTO_SAVE_ADDRESS = “ooo@xxx.ne.jp” ‘ となっているから ちゃんとしているんだよね。

きゃづみぃさんのコメント
あと 新着メールが きたら 起動されるんだよね? 念のための確認です。

きゃづみぃさんのコメント
あ、もしかして ? strBody で エンターとしてないですよね? これをやって エンターとしてみてください。

radioZJさんのコメント
>あと 新着メールが きたら 起動されるんだよね? はい、手動で送受信しており 送受信するとCSVに追記(,,,と空で)されていってます。 イミディエイトの ? strBody(エンター) 空です

きゃづみぃさんのコメント
それが 入ってないのが 問題ですね。 最初のほうの arrEntryId = Split(EntryIDCollection, ",") の箇所で F9 あ、ちなみに もう一回 F9を押すと 解除されます。 ここで ? EntryIDCollection で 内容確認 F8で ステップ実行させ Set myMsg = Application.Session.GetItemFromID(arrEntryId(i)) を通過した時点で ? myMsg とやって 表示内容を確認してから ? myMsg.body として確認。 もちろん メールの本文は 記載されてますよね?

radioZJさんのコメント
> arrEntryId = Split(EntryIDCollection, ",") > の箇所で F9 > > あ、ちなみに もう一回 F9を押すと 解除されます。 > > ここで > ? EntryIDCollection > で 内容確認 ↓↓↓↓↓↓↓↓↓↓ 000000009A6A71664CD0E54892D9BE5698EEFC5784692000 > F8で ステップ実行させ > Set myMsg = Application.Session.GetItemFromID(arrEntryId(i)) > を通過した時点で F8で通過 エラー発生 「実行時エラー'-2147221233(8004010f)':処理が失敗しました。オブジェクトが見つかりません。【終了】or 【デバック】or【ヘルプ】」 となりました。

きゃづみぃさんのコメント
受信したメールが なかったのかな? Set myMsg = Application.Session.GetItemFromID(arrEntryId(i)) じゃなく Set myMsg = Application.Session.GetItemFromID(EntryIDCollection) にして If myMsg.SenderEmailAddress = AUTO_SAVE_ADDRESS Then で ブレイク(F9) エラーにならず 動きますか?

radioZJさんのコメント
おはようございます。昨日はありがとうございました。 受診したメールについてですが、新着はあります。 > Set myMsg = Application.Session.GetItemFromID(arrEntryId(i)) > じゃなく > > Set myMsg = Application.Session.GetItemFromID(EntryIDCollection) > > にして > If myMsg.SenderEmailAddress = AUTO_SAVE_ADDRESS Then > > で ブレイク(F9) > > エラーにならず 動きますか? はい動きます。

きゃづみぃさんのコメント
Set myMsg = Application.Session.GetItemFromID・・・・ という箇所で myMsg にメールの内容を入れています。 このときに myMsg.Bodyを確認すれば メールの本文が わかります。 このメールの本文から 指定した文字から改行まで取得するのが strUketuke = GetText(“受付番号”, myMsg.Body) とやってる箇所です。 つまり GetTextという関数で それを やってることになります。 とりあえず 内容があれば ちゃんと取得されて セットされるはずです。 内容がない場合は、また別の原因となります。

きゃづみぃさんのコメント
そして、その原因を 切り分けるために どういった状態なのかを 随時 確認する必要があります。

きゃづみぃさんのコメント
ちなみに リンク先にあったプログラムで リンク先のメール内容で 送信したところ ちゃんと CSVファイルは できてました。 内容も 確認済みです。 ただ 確認した環境が ちょっと違うので それによる影響が もしかしたら あるのかもしれないと思うだけです。

radioZJさんのコメント
なるほど、環境ですか、 こちらWINDOWS 7 OUTLOOK 2010なんですが環境に問題はありませんか?

radioZJさんのコメント
リンク先の内容を(今もう一度)そのままこちらでやりました ただ少しだけ修正しています。 【1】 Const AUTO_SAVE_TITLE = "受注情報; ' 自動処理するメールの件名 ↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓ Const AUTO_SAVE_TITLE = "受注情報;" ' 自動処理するメールの件名 【2】 件名で処理を実行に変更 If myMsg.SenderEmailAddress = AUTO_SAVE_ADDRESS Then ↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓ If myMsg.Subject = AUTO_SAVE_TITLE Then 一度プロジェクト保存して、OUTLOOK 再起動で、新着読み込み ls = InStr(strBody, strName) ' 指定されたフィールド名を検索の箇所で ブレイク イミディエイト ?strBody (ここかやはり空白) ?strName 区分 となっており、GetTextのLen(strName)がうまくうごいていないのか書きだされた結果は ,,,,2013/01/31 10:11:18 でした。 こちらとtakntさん、同じ事をできてる(きっと)と思うのですがなぜなんでしょう。。。

きゃづみぃさんのコメント
環境の前に Set myMsg = Application.Session.GetItemFromID・・・・ をやったときに myMsg.Bodyに何が 入ってるのかを 確認したらいいですね。

きゃづみぃさんのコメント
環境の違いと書きましたが OUTLOOK 2003、2007、2010の違いは なかったですね。 あとは OSによるものかもしれませんが それも影響は 少なそうな感じがします。

きゃづみぃさんのコメント
http://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q1251293197 こちらでは ちゃんと本文がとれているようですから。

2 ● pretaroe
●100ポイント

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

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


radioZJさんのコメント
ありがとう御座います。 実は上記サイトも参考にさせていただきました。 OUTLOOKを立ち上げた時に新着メールだけを追記していくということがしたかったのですが わたしの能力では今回頂きましたサイトの内容をうまくカスタマイズできなかった為、 takntさんより頂いたURLのページ内容で頑張っておりまして。。。。 ご助言ありがとうございます。 もし可能でありましたら引き続きよろしくお願い致します。

3 ● Mook
●100ポイント ベストアンサー

以前に回答したものをカスタマイズしたものですが、
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(一行, "[ ご予約 第1希望日 ]") > 0 Then
 予約希望 = Trim(Mid(一行, Len("[ ご予約 第1希望日 ]") + 1))
 End If
 
 If InStr(一行, "[ 第1希望日時 ご希望時間 ]") > 0 Then
 希望時間 = Trim(Mid(一行, Len("[ 第1希望日時 ご希望時間 ]") + 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("[ ご予約 第1希望日 ]", 受信メッセージ)
 希望時間 = getText("[ 第1希望日時 ご希望時間 ]", 受信メッセージ)

 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

Mookさんのコメント
コメントで頂いた内容であれば、コードと一致しているようですが、 For 文のところでブレークポイントを置き(F9)、メールを受信したら そこで黄色くなるので、ステップ実行(F8)してみてもらえますか。 一行 の中身を確認(マウスカーソルを文字の上に置く)して、メールを 一行ずつ処理していることと、If の中へ処理が行っていることを確認して 見てもらえるでしょうか。 現象からは、メール受信で処理は走っているけれども、各行のマッチングが 出来ていないように見えます。

Mookさんのコメント
>中の変数らしきところの日本語をカスタマイズしたほうがよいですか? こちらで確認したときには、上記のままで動作したので、問題ないと思いますが、 スペースや全角、半角は一致しているでしょうか。 (コピーしてもらったメールからは問題ないように見えますが。)

radioZJさんのコメント
ありがとうございます。 今実行しております。

radioZJさんのコメント
ありがとうございます。そのままつかわせていただきます。 > For 文のところでブレークポイントを置き(F9)、メールを受信したら > そこで黄色くなるので、ステップ実行(F8)してみてもらえますか。 この後 Set メール = Session.GetItemFromID(メールID) が黄色くなってF8で 実行時エラー '-2147221233(8004010f)'; 処理が失敗しました。オブジェクトが見つかりません となりました。

radioZJさんのコメント
すみません。会社から一旦退出しなくてはいけなくなりました。 ここまでお付き合い誠にありがとうございました。

Mookさんのコメント
うーん、不思議ですね。 コメントもらったメールと上記のコードで、Windows7 + Outlook2010 の環境で下記のように CSV ファイルが作成できているのですが。 ------------------------------------------------------------ 受付番号,予約希望,希望時間,受信日時 "00000001","2013/01/22 (火曜日)","8:20","2013/02/01 23:07:13" ------------------------------------------------------------ ブレークポイントまで来ているということは、マクロは機能していると思いますが、他にマクロを設定したりはしていないでしょうか。

radioZJさんのコメント
おはようございます。昨日はどうもありがとうございます。 本日は同じ環境で作業をすることができないのですがVISTA環境でチャレンジしてみます > うーん、不思議ですね。 そうなんです。とても不思議なんです。 なんか、キチンととれずEmptyとなるんです。 スペースの全角、半角を含めもう一度検証してみます。 これだけいろんな方にご指導いただいているのにできないのは やはり私のほうに問題があるように思えます。 もう一度ケアレスミスがないか確認を行ってみます。 ちなみにCSVの結果を ------------------------------------------------------- 00000001,2013/01/22 (火曜日),8:20,2013/02/01 23:07:13 ------------------------------------------------------- のように項目に対する値だけをとりたい場合 いただいた内容の Dim CSVファイル If fso.FileExists(CSVファイルパス) Then Set CSVファイル = fso.OpenTextFile(CSVファイルパス, ForAppending) Else Set CSVファイル = fso.CreateTextFile(CSVファイルパス) CSVファイル.WriteLine "受付番号,予約希望,希望時間,受信日時" End If をとることでかのうでしょうか? 何度もすみません。お手すきのさいで結構です。 よろしくお願いいたします。

Mookさんのコメント
タイトル行が不要な場合は CSVファイル.WriteLine "受付番号,予約希望,希望時間,受信日時" を削除ください。 データ行の中に Unicode が含まれたりしていないでしょうか。 その場合書き込みで Error が出ますので、ファイルフォーマットを Unicode にするなどの変更が必要です。 サンプルデータだけであれば問題ないのですが。 文字以外に不要なコードがないか、などを確認いただけるでしょうか。

radioZJさんのコメント
Mookさん どうも。文字以外に不要なコード等はとくに見つからなかったです。 Mookさんからいただきましたコードをコピペして作成しなおしました。 なんと "00000005","2013/01/22 (火曜日)","8:20","2013/02/04 15:17:59" データがとれました。 しかし、もう一度メールを自分宛にテストでもう一度(おなじ内容を)送ると "","","","2013/02/04 15:18:31 となってしまいました。 こちらで何度か検証をおこなったのですが、「これだ!」という原因がみあたりません ただなんとなくですが、メールを送受信するとき OUTLOOKだけをたちあげて「送受信」するよりも OUTLOOK + Microsoft Visual Basic for Applications も立ち上げながら テストメールを自分あてに送信して、送受信を行うほうがいいのかな?とかかんがえているんですが Mookさんの検証の仕方はどのような方法ですか? あともう一つ、データを "00000005","2013/01/22 (火曜日)","8:20","2013/02/04 15:17:59" ↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓ 00000005,2013/01/22 (火曜日),8:20,2013/02/04 15:17:59 したい場合は、 CSVファイル.WriteLine """" & 受付番号 & """,""" & 予約希望 & """,""" & 希望時間 & """,""" & 受信時間 & """" をどのように編集すればよろしいでしょうか? ざっとで結構ですのでお伺い出来れば幸いです。

Mookさんのコメント
「"」を付けたくない場合は、 CSVファイル.WriteLine """" & 受付番号 & """,""" & 予約希望 & """,""" & 希望時間 & """,""" & 受信時間 & """" を CSVファイル.WriteLine 受付番号 & "," & 予約希望 & "," & 希望時間 & "," & 受信時間 に変更下さい。 CSV ファイルが更新されているということは、マクロは実行されていると思いますが、VBE の起動の有無によって挙動が変わるというのは、にわかに信じがたいですね。 テストメールは、完全に同じものを同じ送り方で送ったのでしょうか。 送信側のソフトによっては文字コードや改行コードが変わることもあるので、それも少し懸念です。 キーワードは英数のほうがそういった懸念が少なくてすむので、変えられるのであればタイトル部分を変えてみて試せるでしょうか。

radioZJさんのコメント
早速お返事ありがとうございます。 「"」はご指示の通り外すことで解決しました。 生成したものが以下です。 ,,,2013/02/04 17:33:42 ,,,2013/02/04 17:34:19 ,,,2013/02/04 17:36:58 そして穂の他の挙動が変わるというものについては、信じがたいところではありますが、、、 同じように送信を行なっているとおもわれるのですが。。。 一連の作業を今一度ためし、うまく書き出された時の動作を記録してみます。 キーワードについては「受付番号」だけ「strUketuke」にかえてみました。 下記のみ、「受付番号」としています。 ++++++++++++++++++++++++++++++++++++++++++++++++++++ For Each 一行 In Split(受信メッセージ, vbNewLine) If InStr(一行, "受付番号:") > 0 Then ++++++++++++++++++++++++++++++++++++++++++++++++++++

radioZJさんのコメント
すいません。 ひとつ気になった事がありまして。。。 http://dot-town-lab.com/laboratory/item.php?id=32 のサイトも参考にカスタマイズしたんです。 そしたら 1,201301220000,2013/01/22 (火曜日),8:20,2013/01/22 (火曜日),8:30,2013/01/25 (金曜日),8:50,東京,太郎,トウキョウ,タロウ,男,1952,1,1 のようにデータが抽出できるんです。 VBSはこちら **************************************************************************** Public Sub outputcsv() Const CSV_PATH = "C:\mailform\Data.csv" Dim objItem Dim objFSO Dim csvfile Set csvfile = Nothing num = 0 Set objFSO = CreateObject("Scripting.FileSystemObject") ' foreach 文(表示中の受信フォルダ内のアイテム全て) For Each objItem In ActiveExplorer.CurrentFolder.Items If objItem.Subject = "お問い合せフォームから" Then itemUketuke = getText("受付番号:", objItem.Body) itemDate1 = getText("[ ご予約 第1希望日 ]", objItem.Body) itemTime1 = getText("[ 第1希望日時 ご希望時間 ]", objItem.Body) itemDate2 = getText("[ ご予約 第2希望日 ]", objItem.Body) itemTime2 = getText("[ 第2希望日時 ご希望時間 ]", objItem.Body) itemDate3 = getText("[ ご予約 第3希望日 ]", objItem.Body) itemTime3 = getText("[ 第3希望日時 ご希望時間 ]", objItem.Body) itemSeimei1 = getText("[ 姓 ]", objItem.Body) itemMyouji1 = getText("[ 名 ]", objItem.Body) itemSeimei2 = getText("[ セイ ]", objItem.Body) itemMyouji2 = getText("[ メイ ]", objItem.Body) itemSeibetu = getText("[ 性別 ]", objItem.Body) itemSeinen = getText("[ 生年月日(年) ]", objItem.Body) itemSeigetu = getText("[ 生年月日(月) ]", objItem.Body) itemSeiniti = getText("[ 生年月日(日) ]", objItem.Body) Set csvfile = objFSO.OpenTextFile(CSV_PATH, 8, True, 0) If num = 0 Then ' CSVのフィールド名定義 csvfile.writeline "" End If num = num + 1 ' CSV値定義 csvfile.writeline num & "," & itemUketuke & "," & itemDate1 & "," & itemTime1 & "," & itemDate2 & "," & itemTime2 & "," & itemDate3 & "," & itemTime3 & "," & itemSeimei1 & "," & itemMyouji1 & "," & itemSeimei2 & "," & itemMyouji2 & "," & itemSeibetu & "," & itemSeinen & "," & itemSeigetu & "," & itemSeiniti End If Next If Not csvfile Is Nothing Then csvfile.Close End If 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 **************************************************************************** サンプルメールがこちら **************************************************************************** 受付番号:201301220000 [ ご予約 第1希望日 ] 2013/01/22 (火曜日) [ 第1希望日時 ご希望時間 ] 8:20 [ ご予約 第2希望日 ] 2013/01/22 (火曜日) [ 第2希望日時 ご希望時間 ] 8:30 [ ご予約 第3希望日 ] 2013/01/25 (金曜日) [ 第3希望日時 ご希望時間 ] 8:50 [ 姓 ] 東京 [ 名 ] 太郎 [ セイ ] トウキョウ [ メイ ] タロウ [ 性別 ] 男 [ 生年月日(年) ] 1952 [ 生年月日(月) ] 1 [ 生年月日(日) ] 1 **************************************************************************** ただこのVBAの欠点はOUTLOOK起動時に受信したものだけを書き出し 新着のメールが到着しても、書き出しがうまくできず、運用方法そのものが解りづらいのです。 ◆理想はデータがだぶることなく新着のものだけが追記されないのです。 そういう意味で、Mookさんのコードのほうが新着のメールを見落とすことなく記録していけるので助かります。 お伝えしたかったのは、このコードであれば値がうまくとれてしまうので何か「ヒントが無いかなぁ」とおもいつき、書き込みました。

Mookさんのコメント
上記の関数部分を使うように書き換えてどうでしょうか。

radioZJさんのコメント
解りづらい書き方でもうしわけありません。 上記を試したところ 例えばサンプルで内容を少し変えたメールで メールA メールB メールC を受信した後に書き出される内容が「メールA」のものだけになってしまうのです。 そして一度、OUTLOOKからメールを削除して 今度、メールDを受信してその後書き出されるCSVがなぜか「メールA」の内容なのです。

Mookさんのコメント
結果だけではなく、どういうようにコードを変更したら、こうなったという説明が必要かと思いますが、修正の仕方がおかしい気がします。 失礼ながら、どうもVBAで書かれている内容を把握されていないように見受けられるのですが、であれば現在のコードと、データとなるべく細かく説明していただければと思います。 こちらが意図した修正案を、回答に追記いたしますのでご確認ください。

radioZJさんのコメント
> 結果だけではなく、どういうようにコードを変更したら、こうなったという説明が必要かと思いますが> 、修正の仕方がおかしいかもしれません。 お手数おかけして申し訳ありません。 VBAについて初心者な為、正直大体の流れしかわからず。 申し訳ありませんが理解しきれていません。 どう変更を行ったか記載しておきます 変更したところは5点(???)になります。※途中のコメントは一部削除しています。 **************************************************************************** Public Sub outputcsv() Const CSV_PATH = "c:\outlook_csv\output.csv" ?→ 【c:\mailform\csv】 Dim objItem Dim objFSO Dim csvfile Set csvfile = Nothing num = 0 Set objFSO = CreateObject("Scripting.FileSystemObject") For Each objItem In ActiveExplorer.CurrentFolder.Items If objItem.Subject = "注文メール" Then ?→ 【お問い合せフォームから】 itemQA = getText("アンケート", objItem.Body) ?→【受付番号・[ ご予約 第1希望日 ]などへ変更】 itemDatetime = Format(objItem.ReceivedTime, "yyyy-mm-dd hh:nn:ss") ?→【トリ】 Set csvfile = objFSO.OpenTextFile(CSV_PATH, 8, True, 0) If num = 0 Then csvfile.writeline "id,qa,datetime" ?→【"の中だけトリ】 End If num = num + 1 csvfile.writeline num & "," & itemQA & "," & itemDateTime End If Next If Not csvfile Is Nothing Then csvfile.Close End If End Sub 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 **************************************************************************** 以上のようにコードを変更してCSVに書きだしました。 > こちらが意図した修正案を、回答に追記いたしますのでご確認ください。 で内容を実行したのですが、 黄色マーカーで「→Sub CSVへ追記(受信メッセージ, 受信時間)」 青色マーカーで 受付番号 = getText("受付番号:", 受信メッセージ)」の”受信メッセージ”だけに青マーカーがついています。 ポップアップウィンドウには「コンパイルエラー:ByRef引数の型が一致しません。」 となりました。

Mookさんのコメント
詳細は後でコメントしますが、説明ありがとうございます。 受付番号 = getText("受付番号:", 受信メッセージ) を 受付番号 = getText("受付番号:", CStr(受信メッセージ)) としても一緒でしょうか。 詳細は内容を確認して、後ほど再コメントいたします。

radioZJさんのコメント
とんでもありません。 上記実行いたしました。 エラーで 黄色マーカー 「Private Function getText(strTarget As String, strBody As String) As String」 青色マーカー 「strAns =」コメントで「コンパイルエラー:変数が定義されていません」 となりました。

Mookさんのコメント
本来であれば、変数宣言をしたほうが良いのですが、とりあえず 先頭の Option Explicit を外して試してください。

radioZJさんのコメント
はずしました。 値がやはりとれずに,,, となしました。

Mookさんのコメント
返信遅くなっていてすみません。 質問の方はタイムアウトになってしまいましたね。 まだ、コメントはかけるようなので、問題なければ続けましょうか。 ただ、提示のコードだと取れて、マクロのイベントだと取れないというのが、 よく分かりません。 これ以上は、実際にデバッグをしないと難しそうですが、getText の先頭にブレークポイントを設定してメールを受信し、変数の中身を確認しながらトレースできないでしょうか。 そこでどのようなステップを通ったか報告いただけますか。

radioZJさんのコメント
こんにちは、こちらもお返事が遅くなり申し訳ありません。 時間切れにも関わらず、ご対応いただきましてありがとうございます。 うれしいです。 上記、教示いただいた内容を実行してみます。 お忙しい中ありがとうございます。

radioZJさんのコメント
早速ですみません。 > getText の先頭にブレークポイントを設定してメールを受信し 背景黄色→ メール = Session.GetItemFromID(メールID) ↓ F8 「実行時エラー'-2147221233(8004010f)':処理が失敗しました。オブジェクトがみつかりません。」 となりました。 【イミディエイト】 ?Session(Enter) Mapi ?メールID(Enter) 000000009A6A71664CD0E54892D9BE5698EEFC5724CD2000 となり、この「Session」や「メールID」は値がとれているようです。(素人でとれているという表現がただしいのかわかりませんが。。。) ここに問題があるのだろうということくらいしかわからず この後の対応方法が不明なんです。通常であればどのように問題点を切り分け解決にすすめていくのでしょう。。。 ?メール(Enter) エラーが発生します 内容は「実行時エラー'91'オブジェクト変数またはWith ブロック変数が設定されていません。」 以上が、イミディエイトで行った内容です。 ステップイン・ステップオーバー・ステップアウトいずれを行なっても同じ結果なんですね。 ここに問題があるのではと思い 「受付番号 = getText("受付番号:", CStr(受信メッセージ))」 受付番号を選択した状態で「クイックウォッチ」を実行 ウォッチリストに 式:受付番号 値:<対象範囲外> 型:Empty 対象:ThisOutlookSesseion.CSVへ追記 と出ています。 参考になるかわかりませんが、現状は以上になります。

Mookさんのコメント
コメント遅くなりました。 こちらでは現象が再現しないので、なかなか原因がわからないのですが、 2013/02/04 18:46:30 のコメントで提示されていた outputcsvのマクロ(VBS ではなく VBA ですよね?)単体で動かしたときは、上手く動いたんでしょうか。 これがちゃんと動くのであれば、起動時にこれを毎回動かしてあげるのも手かもしれません。 もっとも、イベント処理になると今回と同じ現象が出るかもしれませんが。
関連質問

●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ