14

次のようなVBAコードを開発したかったのです。

  1. メールボックス内のすべての電子メールアイテムをループします
  2. 他の種類のアイテムがある場合は、「カレンダーの招待」はそのアイテムをスキップします。
  3. 添付ファイル付きのメールを検索します
  4. 添付ファイルに「.xml」拡張子と特定のタイトルが含まれている場合は、ディレクトリに保存します。そうでない場合は、検索を続行します
  5. 手順4を実行した後、すべての電子メールに含まれる.xml添付ファイルを「削除済みアイテム」フォルダーに配置し、ループによってそのフォルダー内のすべての電子メールを削除します。

コードは例外として完璧に機能します。例えば

  1. メールボックス内のそれぞれに「.xml」ファイルが添付された8通の電子メールが受信されます。
  2. コードを実行する
  3. 8つのアイテムのうち4つだけが正常に処理され、他の4つはその位置に残ります。
  4. コードを再度実行すると、2つのアイテムが正常に処理され、他の2つはメールボックスに残ります。

問題：コードを実行した後、すべてのファイルを処理し、実行ごとに半分ではなくすべてのファイルを削除することになっています。1回の実行ですべてのアイテムを処理する必要があります。

ところで、このコードはOutlookを開くたびに実行されます。

Private Sub Application_Startup()
'Initializing Application_Startup forces the macros to be accessible from other offic apps

'Process XML emails

Dim InboxMsg As Object

Dim DeletedItems As Outlook.Folder
Dim MsgAttachment As Outlook.Attachment
Dim ns As Outlook.NameSpace
Dim Inbox As Outlook.Folder

Dim fPathTemp As String
Dim fPathXML_SEM As String
Dim fPathEmail_SEM As String
Dim i As Long
Dim xmlDoc As New MSXML2.DOMDocument60
Dim xmlTitle As MSXML2.IXMLDOMNode
Dim xmlSupNum As MSXML2.IXMLDOMNode

    'Specify the folder where the attachments will be saved
    fPathTemp = "some directory, doesn't matter"
    fPathXML_SEM = "some directory, doesn't matter"
    fPathEmail_SEM = "some directory, doesn't matter"

    'Setup Outlook
    Set ns = GetNamespace("MAPI")
    Set Inbox = ns.Folders.Item("mailbox-name").Folders("Inbox")
    Set DeletedItems = ns.Folders.Item("mailbox-name").Folders("Deleted Items")


    'Loop through all Items in Inbox, find the xml attachements and process if they are the matching reponses
    'On Error Resume Next
    For Each InboxMsg In Inbox.Items
        If InboxMsg.Class = olMail Then 'if it is a mail item

            'Check for xml attachement
            For Each MsgAttachment In InboxMsg.Attachments

                If Right(MsgAttachment.DisplayName, 3) = "xml" Then

                    'Load XML and test for the title of the file
                    MsgAttachment.SaveAsFile fPathTemp & MsgAttachment.FileName
                    xmlDoc.Load fPathTemp & MsgAttachment.FileName
                    Set xmlTitle = xmlDoc.SelectSingleNode("//title")
                    Select Case xmlTitle.Text
                        Case "specific title"
                            'Get supplier number
                            Set xmlSupNum = xmlDoc.SelectSingleNode("//supplierNum")
                            'Save the XML to the correct folder
                            MsgAttachment.SaveAsFile fPathXML_SEM & xmlSupNum.Text & "_" & Format(Date, "yyyy-mm-dd") & ".xml"
                            'Save the email to the correct folder
                            InboxMsg.SaveAs fPathEmail_SEM & xmlSupNum.Text & "_" & Format(Date, "yyyy-mm-dd") & ".msg"
                            'Delete the message
                            InboxMsg.Move DeletedItems
                        Case Else

                    End Select
                    'Delete the temp file
                    On Error Resume Next
                    Kill fPathTemp & MsgAttachment.FileName
                    On Error GoTo 0
                    'Unload xmldoc
                    Set xmlDoc = Nothing
                    Set xmlTitle = Nothing
                    Set xmlSupNum = Nothing
                End If
            Next
        End If
    Next

    'Loop through deleted items and delete
    For Each InboxMsg In DeletedItems.Items
        InboxMsg.Delete
    Next

    'Clean-up
    Set InboxMsg = Nothing
    Set DeletedItems = Nothing
    Set MsgAttachment = Nothing
    Set ns = Nothing
    Set Inbox = Nothing
    i = 0

End Sub
4

2 に答える 2

24

考えられる原因: これを行うInboxMsg.Moveと、移動されたメッセージ以降の受信トレイ内のすべてのメッセージが、リスト内で 1 つ上に移動します。そのため、それらのいくつかをスキップすることになります。これは、VBA のFor Each構造にとって大きな問題です (また、一貫性もないようです)。

考えられる解決策: 交換

For Each InboxMsg In Inbox.Items

と

For i = Inbox.Items.Count To 1 Step -1 'Iterates from the end backwards
    Set InboxMsg = Inbox.Items(i)

このようにして、リストの最後から逆方向に繰り返します。メッセージを削除済みアイテムに移動すると、リスト内の次のアイテムがいつ 1 つ増えても問題ありません。それらはいずれにせよ既に処理されているからです。

于 2012-05-23T18:57:55.330 に答える
6

アイテムの（サブセット）セットの内容をループしながら変更することは、多くの場合、良い考えではありません。コードを変更して、最初に処理する必要のあるすべてのアイテムを識別し、それらをに追加することができますCollection。次に、そのコレクション内のすべてのアイテムを処理します。

基本的に、コンテンツをループしている間は、受信トレイからアイテムを削除しないでください。最初に（受信トレイループで）処理するすべてのアイテムを収集し、ループが完了したら、そのアイテムのコレクションを処理します。

これを示すいくつかの擬似コードは次のとおりです。

Private Sub Application_Startup()

    Dim collItems As New Collection

    'Start by identifying messages of interest and add them to a collection
    For Each InboxMsg In Inbox.Items
        If InboxMsg.Class = olMail Then 'if it is a mail item
            For Each MsgAttachment In InboxMsg.Attachments
                If Right(MsgAttachment.DisplayName, 3) = "xml" Then
                    collItems.Add InboxMsg
                    Exit For
                End If
            Next
        End If
    Next

    'now deal with the identified messages
    For Each InboxMsg In collItems
        ProcessMessage InboxMsg
    Next InboxMsg

    'Loop through deleted items and delete
    For Each InboxMsg In DeletedItems.Items
        InboxMsg.Delete
    Next

End Sub

Sub ProcessMessage(InboxMsg As Object)
    'deal with attachment(s) and delete message
End Sub
于 2012-05-23T18:36:39.723 に答える