OutLook本文を、VBAでExcelに落としたい

質問

こんにちは。
先日、こちらのサイトのVisualBasicのカテゴリで質問したのですが、
1件アドバイスが入ったのに、表示されず、削除も出来ず
困ってしまったので、もう一度質問させていただきます。

タイトルの通りなのですが、
ExcelVBAで、OutLookの受信トレイの「未読」の件名、本文、受信時間を
Excelに一覧として落としたいのです。

いろいろサイトを見たりして、参考サイトで見つけたコードを
使って、思うとおりにカスタマイズしてもみたのですが、
どうしても思っていた通りには出来ませんでした。
上記やりたいことが出来るコード、参考サイトをご教示願えませんか？
ちなみに、OSはWindows2002です。

どうぞよろしくお願い致します。

回答No.4

Wendy02 · ベストアンサー

#1　です。

こちらとしては、どなたが解決してもかまいませんので、ずるいようですが、#2,#3 で書かれているname_mm_ok　様のコードで様子を見させていただきます。

なお、
>セキュリティ関連のダイアログが開き、アクセス可能な時間を選択
>する必要がある事です。
>この件に関しては、私のレベルでは回避不可能でした。

Faq ですが、一応、セキュリティレベルなので、Outlook では、解決は出来ないというのが、一般的な回答です。他は知りません。

なお、
.UnRead = True
で、私の回答は、逆に書いてしまいました。間違えました。

お礼

再度のアドバイスありがとうございます！！
せっかくアドバイス頂いたのに、お礼が遅くなってしまってごめんなさい！！！
ちょっと別件で忙しくなってしまい、こちらは保留となっておりました。
お二人に頂いたアドバイスを元に、頑張ってやってみます。
まだ保留状態で、実動できる状態ではないので、結果報告が出来ないのですが
これ以上遅くなってしまうと申し訳ないので、一旦ここで閉じようと思います。
今後はもっと勉強して、今度は自分が誰かの質問に答えられるようになりたいと思います。
本当にありがとうございました！！！
またよろしければ、ご教示くださいね。

お礼に関しては、まだ結果が出ていない状態なので
勝手ですが順番に付けさせてください。
失礼でしたら申し訳ございません。

回答No.3

name_mm_ok

これが、OfficeXP(2002)のOutlook、Excelで動作したコードです。
このコードで回避できないのは、メール本文にアクセスした際、
セキュリティ関連のダイアログが開き、アクセス可能な時間を選択
する必要がある事です。
この件に関しては、私のレベルでは回避不可能でした。

Option Explicit

'Excelアプリケーション内にアクティブになっているワークシートが
'存在する事を前提に作りました。

Private Sub GetRcvMailInfo()

Dim objOApp As Object 'Outlook.Application
Dim objNameSpace As Object 'Outlook.NameSpace
Dim objDFld As Object 'Outlook.MAPIFolder
Dim objFld As Object 'Outlook.MAPIFolder
Dim objItem As Object 'Outlook.MailItem
Dim objEApp As Object 'Excel.Application
Dim objASht As Object 'Excel.Worksheet
Dim i As Long

'複数のデータフォルダを使用している場合
Const DATAFOLDER As String = "業務用フォルダ"
'抽出対象のフォルダ名称を指定
Const SUBFOLDER As String = "受信トレイ"

Set objOApp = CreateObject("Outlook.Application")

Set objNameSpace = objOApp.GetNamespace("MAPI")

For Each objDFld In objNameSpace.Folders

Debug.Print objDFld.Name

If objDFld.Name = DATAFOLDER Then

For Each objFld In objDFld.Folders
Debug.Print objFld.Name
If objFld.Name = SUBFOLDER Then
Exit For
End If
Next objFld

'objFld.Name = SUBFOLDER の判定でTrueとなったかを判定
If Not objFld Is Nothing Then
i = 1

Set objEApp = Excel.Application

objEApp.ScreenUpdating = False 'Excelの更新を一時的に停止

Set objASht = objEApp.ActiveSheet

For Each objItem In objFld.Items
If objItem.UnRead = True Then
objASht.Cells(i, 1) = objItem.Subject
objASht.Cells(i, 2) = objItem.Body
objASht.Cells(i, 3) = objItem.ReceivedTime
i = i + 1
End If
Next objItem

objEApp.ScreenUpdating = True 'Excelの更新を再開

Exit For
End If

End If

Next objDFld

objOApp.Quit

Set objASht = Nothing
Set objEApp = Nothing
Set objASht = Nothing
Set objItem = Nothing
Set objFld = Nothing
Set objDFld = Nothing
Set objNameSpace = Nothing
Set objOApp = Nothing

End Sub

お礼

アドバイスありがとうございます！！
せっかくアドバイスいただいたのに、お礼が遅くなってしまい
本当に申し訳ございません！！！
ちょっと別件で忙しくなってしまい、こちらはいったん保留となっておりました。
詳しいコードをありがとうございます。
まだ、実動できてはいないのですが
このコードを解読して、頑張ってみたいと思います。
もっと勉強して、私も誰かの質問に答えられるようになりたいとおもいます。
本当にありがとうございました！
またどうしても解らないことがありましたら、ぜひご教示ください。

回答No.2

name_mm_ok

VisualBasicでご質問された際のコードを確認しました。
追加行（１～３）とコメントしている行の追加及び、追加行のＸＸＸを取得したいフォルダの名称に変更し、Wendy02 様が回答されている未読メールの判定を For Each objItem ～ のループ内に挿入すれば動作すると思います。
今のPCにはOutlookがインストールされていないため、動作しないようであれば、その旨回答への補足を頂ければ、動作確認可能な環境で確認後再度回答致します。
今後のためにも、オブジェクトブラウザ、ブレイク、ウォッチ等、VBAの動作確認する際の方法について調べられたほうがいいかと思います。

For nFCNT = 1 To olNameSPC.Folders(1).Folders.Count
'イミディエイトウィンドウにフォルダ名称が出力されます。
'この行は現在取得可能な正しいフォルダ名称を確認後削除して下さい。
debug.print olNameSPC.Folders(1).Folders(nFCNT).Name
if olNameSPC.Folders(1).Folders(nFCNT).Name = "受信トレイ" Then '追加行(1)

'フォルダーの名称を書き込む
Cells(nYLINE, 1) = olNameSPC.Folders(1).Folders(nFCNT).Name
nYLINE = nYLINE + 1
'見出しを書き込む
Cells(nYLINE, 1) = "No."
Cells(nYLINE, 2) = "タイプ"
Cells(nYLINE, 3) = "作成日"
Cells(nYLINE, 4) = "件名"
Cells(nYLINE, 5) = "内容"
nYLINE = nYLINE + 1

'メッセージ数分ループ
For Each objItem In olNameSPC.Folders(1).Folders(nFCNT).Items

intCounter = intCounter + 1

'変数に代入（セルに直接でもいいかも？）
With objItem
dteCreateDate = .CreationTime
strSubject = .Subject
strItemType = TypeName(objItem)
strBody = .Body
End With

'セルに代入
Cells(nYLINE, 1) = intCounter
Cells(nYLINE, 2) = strItemType
Cells(nYLINE, 3) = dteCreateDate
Cells(nYLINE, 4) = strSubject
Cells(nYLINE, 5) = strBody

'セット位置を移動
nYLINE = nYLINE + 1

Next objItem

exit for '追加行(2)

end if '追加行(3)

回答No.1

Wendy02

こんばんは。

VBカテゴリでは、その１件は、削除されてしまったようです。

たぶん、ここの部分では？

>Set olAPP = CreateObject("Outlook.Application")
>Set olNameSPC = olAPP.GetNamespace("MAPI") ' Namespace オブジェクト
>
>nYLINE = 1
>For nFCNT = 1 To olNameSPC.Folders(1).Folders.Count　　'←ここの部分

いきなりMapiの名前空間ではなくて、もう一度フォルダを取り直したらどうでしょうか？今、コードを動かしているわけではないので、あまり断定的に言えませんが。

Set olNameSPC = olAPP.GetNamespace("MAPI") ' Namespace オブジェクト
Set myFolder = olNameSPC.GetDefaultFolder(6)　　'olFolderInbox
For nFCNT =1 to myFolder.Items.Count

>OutLookの受信トレイの「未読」の件名

>という件に関しては、

If 　myFolder.Items(i).UnRead = False Then

で、未読のフラグを、取れるはずです。

補足

さっそくのお返事ありがとうございます。
そして、いつもご教示いただき、ありがとうございます。

現在、Wendy02さまのアドバイスに沿って、コードを見直しているのですが、
まだうまく動作できません。
もう少し頑張ってみますので、お礼＆締め切りはお待ち下さい。
思い通りの動作が出来たら、ここにアップして締め切りたいと思います。
もし、お手すきでしたら再度アドバイスして頂けたら嬉しいです。
本当にいつもありがとうございます。