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

Question

こんにちは。
先日、こちらのサイトのVisualBasicのカテゴリで質問したのですが、
1件アドバイスが入ったのに、表示されず、削除も出来ず
困ってしまったので、もう一度質問させていただきます。

タイトルの通りなのですが、
ExcelVBAで、OutLookの受信トレイの「未読」の件名、本文、受信時間を
Excelに一覧として落としたいのです。

いろいろサイトを見たりして、参考サイトで見つけたコードを
使って、思うとおりにカスタマイズしてもみたのですが、
どうしても思っていた通りには出来ませんでした。
上記やりたいことが出来るコード、参考サイトをご教示願えませんか？
ちなみに、OSはWindows2002です。

どうぞよろしくお願い致します。

Wendy02 · Accepted Answer

#1　です。

こちらとしては、どなたが解決してもかまいませんので、ずるいようですが、#2,#3 で書かれているname_mm_ok　様のコードで様子を見させていただきます。

なお、
>セキュリティ関連のダイアログが開き、アクセス可能な時間を選択
>する必要がある事です。
>この件に関しては、私のレベルでは回避不可能でした。

Faq ですが、一応、セキュリティレベルなので、Outlook では、解決は出来ないというのが、一般的な回答です。他は知りません。

なお、
  .UnRead = True 
で、私の回答は、逆に書いてしまいました。間違えました。

name_mm_ok · Answer

これが、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

name_mm_ok · Answer

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)

Wendy02 · Answer

こんばんは。

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

で、未読のフラグを、取れるはずです。

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

#1 です。

これが、OfficeXP(2002)のOutlook、Excelで動作したコードです。

VisualBasicでご質問された際のコードを確認しました。

こんばんは。

この回答への補足

似たような質問が見つかりました

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング

#1　です。