三流君 ken3のmemo置き場

三流プログラマーのメモ書きです。主にVBAやWindowsの話題が多いです

挨拶・自己紹介:
失敗続きのAB型の変わり者 :三流プログラマー Ken3です
フリーのエンジニア・個人事業主です・・と書くと聞こえはイイが(それとなくカッコよく聞こえるが)、 現在は小さな案件の受注請負 と 短期派遣 で 日々つつましく?ほそぼそと暮らしてます。
よく検索されるキーワード: [質問回答XXXXさんへ] [CreateObject] [VBA] [JRA競馬オッズ]

Outlook VBA 受信メールを .Move 移動先Folderオブジェクトで移動させる ループに注意

処理済みのメールを他のフォルダー
ここでは、受信トレイの下の
名称"処理済み"に.Move 移動先Folderオブジェクト を使って移動させました。

'処理が終わったメールを移動する ※6 ループの中で移動させる時は注意する
mITEM.Move oFolder.Folders("処理済み")

ここで、ありがちな不具合・問題点を実演してみます。
https://www.youtube.com/watch?v=I4XZYWltfqA

001 .Moveでメール移動のテスト

'メールアイテムの処理 サブフォルダーを.Folders("写真テスト").Itemsで指定
For Each mITEM In oFolder.Folders("写真テスト").Items 'アイテム数分ループ

いつものように、ループを作り、
処理後、
mITEM.Move oFolder.Folders("処理済み")
で、メールを移動させます。

すると、全てのメールが移動されずに処理が歯抜けになってしまいます。

原因は、みなさんの心の中で、想像ついたと思いますが、
For Each mITEM In oFolder
でアイテムを取り出しているループの中で、
mITEM.Move で別のフォルダーにアイテムを移動させると、
状態が変わってしまい、Nextで次のアイテムを正しく取り出せない、
そんな状態になってしまいます。

下記、しくじりコード・・・

'Outlook で メールに添付された写真をExcelに貼る
'サブフォルダ ここでは 写真テスト 固定です の 受信メール読み込むサンプル
'件名と添付ファイル名(複数)を取り出す(表示する)
'添付ファイルを固定の D:\VBA\ に書き出すテスト
'新規起動したExcelブック・シートに書き込むテスト
'2019-06-06 .Move でメールを移動させるが不具合作成をテスト
Sub outlook_test20190606_001()

'Excel 起動処理
    Dim objEXCEL As Excel.Application 'アプリケーションを入れる箱

    Set objEXCEL = CreateObject("Excel.Application") 'エクセルのアプリケーションを作る
    objEXCEL.Visible = True      '可視、見えるようにする。お約束/呪文?
    objEXCEL.UserControl = True  'マクロ終了後、ユーザー操作可能とする。※最近見かけないのでなくていいかも
    
    objEXCEL.Workbooks.Add  '新規のブック作成
    objEXCEL.Sheets.Add     '新規のシート追加

'サブフォルダからメールを読み込みながら、Excelへ添付画像を貼り付ける
    Dim oNamespace As NameSpace
    Dim oFolder As Outlook.Folder 'フォルダー
    
    ' NameSpace オブジェクトへの参照を取得します。
    Set oNamespace = Application.GetNamespace("MAPI")

    ' 既定のフォルダへの参照を取得し、フォルダを表示します。
    Set oFolder = oNamespace.GetDefaultFolder(olFolderInbox) '受信トレイを指定
    oFolder.Display   '選択したフォルダーの表示

    Dim mITEM       As Outlook.MailItem    'メールアイテム
    Dim oAttachment As Outlook.Attachment  'Attachment 添付 アタッチメント
    Dim n As Integer  'n件目の写真
    Dim yROW As Integer  'セットする行数

    'テストで名前の表示
    Debug.Print oFolder.Name

    n = 0  '処理件数の初期化
    'メールアイテムの処理 サブフォルダーを.Folders("写真テスト").Itemsで指定
    For Each mITEM In oFolder.Folders("写真テスト").Items 'アイテム数分ループ
        '↑代入が終わったので、各プロパティに mITEM.XXXX で アクセスする
        
        'デバッグでイミディエイトに表示
        Debug.Print "件名:" & mITEM.Subject '件名表示
        'MsgBox "件名:" & mITEM.Subject & "処理"
        
        '添付ファイルの処理 ※添付ファイルは複数あるよ
        For Each oAttachment In mITEM.Attachments 'メールの添付複数.Attachments
            '添付ファイルのファイル名が、 oAttachment.FileNameでわかります。
            Debug.Print ".FileName " & oAttachment.FileName
            '拡張子が.jpgだけ処理します
            If Right(oAttachment.FileName, 4) = ".jpg" Or Right(oAttachment.FileName, 4) = ".JPG" Then
                'Dドライブの固定フォルダ D:\VBA\ に テストで保存してます
                '自分の環境で、テンポラリのフォルダを作ってください
                oAttachment.SaveAsFile "d:\VBA\" & oAttachment.FileName
                '↑.SaveAsFile "ドライブ:\フォルダー\ファイル名.xxx" で書き込めます
                '↑で、書き込んだファイルをExcel↓で読み込みます
                DoEvents
                yROW = n * 10 + 1  'セットする行位置 ※1 苦肉の策で50行単位にセット改善する
                objEXCEL.Cells(yROW, 1) = "件名:" & mITEM.Subject '件名セット
                objEXCEL.Cells(yROW + 1, 1).Select  '写真のセット位置
                '保存されたファイル名の写真を挿入する。
                With objEXCEL.ActiveSheet.Pictures.Insert("d:\VBA\" & oAttachment.FileName)
                    .Height = 100
                    .Left = 0
                End With
                objEXCEL.Cells(yROW, 1).Select
                
                '※2 ここで.jpgファイルを消す処理を入れないと、処理済みのゴミがたまるかな
                
                n = n + 1  '最後に処理件数を増やす
            End If
        Next
        
        '※3
        '処理済みのメールを移動させた方が便利かも
        '受信指定サブフォルダーから添付写真を取り出したら、
        '処理済みなどのフォルダーに移動したほうが便利かも?
        '処理が終わったメールを移動する ※6 ループの中で移動させる時は注意する
        mITEM.Move oFolder.Folders("処理済み")

        Debug.Print ""
    Next

    '使用したオブジェクトの解放 = Nothing
    Set mITEM = Nothing
    
    Application.ActiveExplorer.Close   '新しく開いてしまったフォルダーを閉じる
    Set oFolder = Nothing
    Set oNamespace = Nothing

End Sub

蛇足:削除処理のカウンター管理に似てるかな?※何それ?


002 ループをカウンターを使い、後ろから処理する

原因がわかったので、対策を
ループの中で、アイテムを移動させても順番が狂わないように
後ろから アイテムを処理していきます。

後ろから?
ループを For Each mITEM In oFolder のループから、
カウンターを使ったループに修正してみます

'メールの件数が .Count でわかるので、後ろから処理する
For nMAILCNT = oFolder.Folders("写真テスト").Items.Count To 1 Step -1
    Set mITEM = oFolder.Folders("写真テスト").Items(nMAILCNT) 'アイテムを代入
    '↑.Item(nMAILCNT)の代入が終わったので、各プロパティに mITEM.XXXX で アクセスする

.Items.Countで件数がわかるので、
最大値からStep -1のループを作成しました。

下記、カウンターを使い、ループを後ろからに修正したソース

'2019-06-06 .Move でメールを移動させる
'カウンターを使用して、後ろからメールを処理する
Sub outlook_test20190606_002()

'Excel 起動処理
    Dim objEXCEL As Excel.Application 'アプリケーションを入れる箱

    Set objEXCEL = CreateObject("Excel.Application") 'エクセルのアプリケーションを作る
    objEXCEL.Visible = True      '可視、見えるようにする。お約束/呪文?
    objEXCEL.UserControl = True  'マクロ終了後、ユーザー操作可能とする。※最近見かけないのでなくていいかも
    
    objEXCEL.Workbooks.Add  '新規のブック作成
    objEXCEL.Sheets.Add     '新規のシート追加

'サブフォルダからメールを読み込みながら、Excelへ添付画像を貼り付ける
    Dim oNamespace As NameSpace
    Dim oFolder As Outlook.Folder 'フォルダー
    
    ' NameSpace オブジェクトへの参照を取得します。
    Set oNamespace = Application.GetNamespace("MAPI")

    ' 既定のフォルダへの参照を取得し、フォルダを表示します。
    Set oFolder = oNamespace.GetDefaultFolder(olFolderInbox) '受信トレイを指定
    oFolder.Display   '選択したフォルダーの表示

    Dim mITEM       As Outlook.MailItem    'メールアイテム
    Dim oAttachment As Outlook.Attachment  'Attachment 添付 アタッチメント
    Dim n As Integer  'n件目の写真
    Dim yROW As Integer  'セットする行数

    Dim nMAILCNT As Integer 'メールの位置 2019/06/06 追加

    'テストで名前の表示
    Debug.Print oFolder.Name

    n = 0  '処理件数の初期化
    'メールアイテムの処理 サブフォルダーを.Folders("写真テスト").Itemsで指定
    'メールの件数が .Count でわかるので、後ろから処理する
    For nMAILCNT = oFolder.Folders("写真テスト").Items.Count To 1 Step -1
        Set mITEM = oFolder.Folders("写真テスト").Items(nMAILCNT) 'アイテムを代入
        '↑.Item(nMAILCNT)の代入が終わったので、各プロパティに mITEM.XXXX で アクセスする
        
        'デバッグでイミディエイトに表示
        Debug.Print "件名:" & mITEM.Subject '件名表示
        'MsgBox "件名:" & mITEM.Subject & "処理"
        
        '添付ファイルの処理 ※添付ファイルは複数あるよ
        For Each oAttachment In mITEM.Attachments 'メールの添付複数.Attachments
            '添付ファイルのファイル名が、 oAttachment.FileNameでわかります。
            Debug.Print ".FileName " & oAttachment.FileName
            '拡張子が.jpgだけ処理します
            If Right(oAttachment.FileName, 4) = ".jpg" Or Right(oAttachment.FileName, 4) = ".JPG" Then
                'Dドライブの固定フォルダ D:\VBA\ に テストで保存してます
                '自分の環境で、テンポラリのフォルダを作ってください
                oAttachment.SaveAsFile "d:\VBA\" & oAttachment.FileName
                '↑.SaveAsFile "ドライブ:\フォルダー\ファイル名.xxx" で書き込めます
                '↑で、書き込んだファイルをExcel↓で読み込みます
                DoEvents
                yROW = n * 10 + 1  'セットする行位置 ※1 苦肉の策で50行単位にセット改善する
                objEXCEL.Cells(yROW, 1) = "件名:" & mITEM.Subject '件名セット
                objEXCEL.Cells(yROW + 1, 1).Select  '写真のセット位置
                '保存されたファイル名の写真を挿入する。
                With objEXCEL.ActiveSheet.Pictures.Insert("d:\VBA\" & oAttachment.FileName)
                    .Height = 100
                    .Left = 0
                End With
                objEXCEL.Cells(yROW, 1).Select
                
                '※2 ここで.jpgファイルを消す処理を入れないと、処理済みのゴミがたまるかな
                
                n = n + 1  '最後に処理件数を増やす
            End If
        Next
        
        '※3
        '処理済みのメールを移動させた方が便利かも
        '受信指定サブフォルダーから添付写真を取り出したら、
        '処理済みなどのフォルダーに移動したほうが便利かも?
        '処理が終わったメールを移動する ※6 ループの中で移動させる時は注意する
        mITEM.Move oFolder.Folders("処理済み")

        Debug.Print ""
    Next

    '使用したオブジェクトの解放 = Nothing
    Set mITEM = Nothing
    
    Application.ActiveExplorer.Close   '新しく開いてしまったフォルダーを閉じる
    Set oFolder = Nothing
    Set oNamespace = Nothing

End Sub

003 .Itemsは0 ゼロからじゃないの?少々疑問・・・

蛇足:
デバッグ中に私自身も疑問だったのが、
配列が1から?始まっていることかな?

んっ?なにそれ
For nMAILCNT = oFolder.Folders("写真テスト").Items.Count To 1 Step -1
何か違和感ない?ですか?わたしだけ?

Set mITEM = oFolder.Folders("写真テスト").Items(nMAILCNT) 'アイテムを代入

.Items(nMAILCNT)
.Items(0) から、ゼロから始まらないのかなぁと・・・
なので、

For nMAILCNT = oFolder.Folders("写真テスト").Items.Count -1 To 0 Step -1

.Countからマイナス-1して 0までのループにしてたらエラーだった。

やってみるのが、はやいか。
※後ろから処理、ループの条件を変えてテストしてみる

終わりの挨拶:

まぁ、こんな感じで、デバッグしています。
メール移動処理は後ろから?
一つでも、少しでも処理の参考となればうれしいです。

Ken3 ホームページ 目次

分類:HPを大きく分けると4つの柱(分類)です。
・[Excel/Access VBA]の解説
・[ASP(Active Server Pages)]の解説。
・[元コンビニ店長時代の話]が弟に巻き込まれ、失敗した脱サラ、畑違い?の仕事で失敗。
・[プログラマーの愚痴]では、あまり見せたくない三流プログラマーの内面かな。
三流君を踏み台にする
主に上記4つの分類でHP作成やメルマガの発行を行ってます。
※更新頻度が落ちていて情報の鮮度が悪いです。



Googleを使用して検索する

読者の声:三流君の説明・解説じゃ よくわからなかったから、Googleを使って、自分で検索します。
三流君:残念です。あっ、下記にGoogleの検索窓を設置しました。
いろいろ指定して試してみてください。

Google
探す言葉:気になる単語や,オブジェクト(Document),プロパティ(.Busy)やメソッド(.Navigate)などを入れて検索してみてください。


言語を指定:見つからない時は指定無しで探す

サイト指定:人気QAサイト や 一次情報MS本家を指定する
一次情報・二次情報まとめから探る
QAサイトの質問から探る
検索実行: ←オプション確認後に検索ボタンを押してください

期間指定:情報の鮮度も大切?
検索実行: ←オプション確認後に検索ボタンを押してください


本当に三流なんです(笑):たまにスゴイですねなんて言われることもありますが、
真実は→ [三流君の真実は...] ←を初めに見てくださるとわかると思います。
(からくりは、成功例↑しか載せてなくて ヒドイ失敗例はお蔵入り迷宮入りが多かったりします)