[[20180615220600]]　『マクロが止まります』（むうこ）　ページの最後に飛ぶ

『マクロが止まります』（むうこ）

outlookの受信フォルダ下にあるいくつかのサブフォルダ内のメール
内容を書き出すマクロで、あるフォルダの内容を書き出すマクロだけ
途中で止まってしまいます。
エラーメッセージは
「クラスはオートメーションまたは予測したインターフェースをサポートしていません。」です。

ひとつのサブフォルダについて以下のコードを作成して
call　でくっつけています。
このコードのうち Bフォルダのメール内容を呼び出すマクロだけ
上記エラーで止まります。Bフォルダに1000くらいのメールがありその状態でマクロをかけるとエラーになりますが100くらいに減らすとちゃんと機能します。
他のフォルダは1000以上のメールがあっても思い通りに動きます。
何が原因なのか、どうすればいいのか、問題の切り分けでもご教授ください。

　sub folderA()

    Dim ol As Object
    Dim sht As Worksheet
    Dim rowCnt As Long

    Set ol = GetObject(, "Outlook.Application")
    If ol Is Nothing Then Exit Sub

    Set sht = Worksheets("Aメール取得")

    ' シートクリア
    With sht
            Columns("A:D").Select
    Selection.ClearContents
        .Cells(1, 1).Value = "受信日時"
        .Cells(1, 2).Value = "差出人"
        .Cells(1, 3).Value = "件名"
        .Cells(1, 4).Value = "本文"
    End With

    ' メール一覧取得
    rowCnt = 1
    For Each itms In ol.GetNamespace("MAPI").GetDefaultFolder(6).Folders("A").Items

        If itms.Class = 43 Then ' olMail:43
            sht.Cells(rowCnt + 1, 1).Value = itms.ReceivedTime  ' 受信日時
            sht.Cells(rowCnt + 1, 2).Value = itms.SenderName    ' 差出人
            sht.Cells(rowCnt + 1, 3).Value = itms.Subject            ' 件名
            sht.Cells(rowCnt + 1, 4).Value = itms.Body          ' 本文

            rowCnt = rowCnt + 1
        End If

    Next

    Set ol = Nothing
End Sub

Sub

＜使用 Excel：Excel2016、使用 OS：Windows10 ＞

 >Bフォルダに1000くらいのメールがありその状態でマクロをかけるとエラーになりますが
 >100くらいに減らすとちゃんと機能します。 
 >他のフォルダは1000以上のメールがあっても思い通りに動きます。

 ならBフォルダーの一部のメールそのものがエラーを引き起こしている原因では? 
 地道な作業になるけど100づつ別のフォルダーに分けて、個別に実行したらどうなりますか?

（sy） 2018/06/17(日) 10:17

Syさん
ご返答ありがとうございます。
業務の合間に作業してみてまた結果をお知らせします。
（むうこ） 2018/06/17(日) 22:59

Syさん

「取り消し」されたメールがあると、そこでエラーになりました。

ソートして「取り消し」メールを削除後に
マクロを実行するとちゃんと動きました。
アドバイス、どうもありがとうございました・
（むうこ） 2018/06/18(月) 12:48

回答らしい回答じゃないですが一応。

（１）
たぶんだけど、なかなか回答つかなかったのは、「GetObject(, "Outlook.Application")」ってやってるから解ってると思いますが、掲示板の趣旨である”エクセル”の質問じゃ無くて”Outlook”の質問だよなぁと思われてるだとおもいます。(少なくともわたしはそう思いました）
なので、今回はこちらで欲しい回答が得られたようですが、問題がOutlookにあることが濃厚な場合は、最初から、moug（http://www.moug.net/）などOutlookの質問にも対応できるような質問サイトで聞いてみるのも手なんじゃないかとおもいます。

（２）
提示されたコードってご自身で作成されたものですか？
私も詳しいわけではないですが、ExcelVBAで他のアプリケーションを操作しようとするレベルの方が

 Columns("A:D").Select
 Selection.ClearContents

や

 sht.Cells(rowCnt + 1, 1).Value = itms.ReceivedTime  ' 受信日時
 sht.Cells(rowCnt + 1, 2).Value = itms.SenderName    ' 差出人
 sht.Cells(rowCnt + 1, 3).Value = itms.Subject       ' 件名
 sht.Cells(rowCnt + 1, 4).Value = itms.Body          ' 本文

という書き方を選択するようにも思えず、
・前者は .Columns("A:D").ClearContents
・後者は　いちいちセルに出力せず、配列を経由（メモリ上で処理してから）させてセルへの出力は１回だけやる
という設計にされる方が多いように思います。（格納する件数が多いと逆に逐一出力した方がいいのかなぁ・・・）

（３）
Outlook側に問題があるとすれば、
http://www.ken3.org/cgi-bin/group/vba_outlook.asp
こちらとか研究の参考にならないでしょうか

（４）
「.GetNamespace("MAPI").GetDefaultFolder(6).Folders("A").Items」

 ' olMail:43
これら↑の部分がそれぞれ、これでよいのか私のスキルだと解らないですが、（２）の部分を中心に改造、コメント付けしてみました。よかったら研究の足しにしてください。

※「ひとつのサブフォルダについて以下のコードを作成して call　でくっつけています。」とのことでしたので、サブフォルダを取得する部分と、メールアイテムを取得＆出力する部分でプロシージャを分けてみました。

    Sub メインルーチン()
        Dim ol As Object
        Dim MyFolder As Object

        'Outlookが起動してなかったら終了
        On Error Resume Next
        Set ol = GetObject(, "Outlook.Application")
        If ol Is Nothing Then Exit Sub
        On Error GoTo 0

        '受信トレイ配下のサブフォルダを順に取得して処理
        For Each MyFolder In ol.GetNamespace("MAPI").GetDefaultFolder(6).Folders

            'サブフォルダの中にメールが1つ以上ある場合だけ処理
            If MyFolder.Items.Count > 0 Then Call サブルーチン(MyFolder)

        Next MyFolder

        Set ol = Nothing
    End Sub

    Sub サブルーチン(MyFolder As Object)
        Dim Myarr As Variant
        Dim dstSH As Worksheet
        Dim i As Long, c As Long

        c = MyFolder.Items.Count

        'Myarrを2次元配列として定義してメールのデータを格納
        ReDim Myarr(1 To c, 1 To 4)
        For i = 1 To c
            With MyFolder.Items(i)
                Application.StatusBar = MyFolder.Name & "を処理中......" & i & "/" & c
                If .Class = 43 Then     '←★私のスキルだと何をしたいのか解らず
                    Myarr(i, 1) = .ReceivedTime     ' 受信日時
                    Myarr(i, 2) = .SenderName       ' 差出人
                    Myarr(i, 3) = .Subject          ' 件名
                    Myarr(i, 4) = .Body             ' 本文
                End If
            End With
        Next i

        '出力用シートの用意
        On Error GoTo シート生成
        Set dstSH = ThisWorkbook.Worksheets(MyFolder.Name & "メール取得")
        On Error GoTo 0

        '出力用シートへ出力
        With dstSH
            .Range("A:D").Cells.ClearContents
            .Range("A1:D1").Value = Array("受信日時", "差出人", "件名", "本文")
            .Range("A2").Resize(c, 4).Value = Myarr
        End With

        Application.StatusBar = False
    Exit Sub

    シート生成:
        Application.StatusBar = "出力用のシートを生成しています"
        Set dstSH = ThisWorkbook.Worksheets.Add
        dstSH.Name = MyFolder.Name & "メール取得"

        Resume

    End Sub

（もこな２） 2018/06/18(月) 18:28

コメント返信：

[ 一覧(最新更新順) ]

[[20180615220600]] 『マクロが止まります』（むうこ） ページの最後に飛ぶ

[[20180615220600]]　『マクロが止まります』（むうこ）　ページの最後に飛ぶ