我想制定VBA守则:
- Loops through all email items in mailbox
- If there are any type of other items say "Calendar Invitation" skips that item.
- Finds out the emails with attachments
- If attached file has ".xml" extension and a specific title in it, saves it to a directory, if not it keeps searching
- Puts all email includes .xml attachments to "Deleted Items" folder after doing step 4 and deletes all emails in that folder by looping.
Code works perfect EXCEPT; For example
- There are 8 email received with ".xml" file attached to each one of them in your mailbox.
- run the code
- you will see only 4 of the 8 items are processed successfully, other 4 remain in their positions.
- If you run the code again, now there would be 2 items processed successfully and other 2 remain in your mailbox.
问题 : 运行代码后, 它应该处理所有文件, 并删除所有文件, 而不是每个运行中一半的文件 。 我希望它能在一个运行中处理所有项目 。
BTW 每次我打开《展望》 都用这个代码
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