[英]Outlook 2010 VBA to save selected email to a folder other emails in that conversation have already been moved to
I am attempting to code a way to automate filing of emails.我正在尝试编写一种自动归档电子邮件的方法。 I file all of my emails in a pretty detailed set of sub-folders in my inbox.
我将所有电子邮件归档到收件箱中一组非常详细的子文件夹中。 I have MANY subfolders that help me organize my emails but this leads to a lot of extra time being spent in cleaning out my inbox (by filing emails to the relevant sub-folder).
我有许多子文件夹可以帮助我整理电子邮件,但这会导致我花费大量额外时间清理收件箱(通过将电子邮件归档到相关子文件夹)。 I would like to automate this so that I can select an email in my inbox and run the macro to display a list of folders that emails in the same conversation thread have already been filed in and allow me to select which one to save the selected email to.
我想自动执行此操作,以便我可以在收件箱中选择一封电子邮件并运行宏以显示同一对话线程中的电子邮件已归档的文件夹列表,并允许我选择保存所选电子邮件的文件夹到。 I have found several sample codes that are close but nothing that really does this action.
我发现了几个很接近但没有真正执行此操作的示例代码。
http://blog.saieva.com/2010/03/27/move-messages-to-folders-with-outlook-vba/ shows how to move messages to sub-folders when you know what sub-folder you want the email to go to. http://blog.saieva.com/2010/03/27/move-messages-to-folders-with-outlook-vba/显示了当您知道您想要电子邮件的子文件夹时如何将消息移动到子文件夹要去。 This doesn't work for my situation because I want the macro to give me a list of "recommended" folders.
这对我的情况不起作用,因为我希望宏给我一个“推荐”文件夹列表。
I thought the below code may be a good place to start if I could figure out a way to loop through each "child" (not sure if that is the right word) of the conversation for the selected email and move the selected to the folder if the user selects "Yes" in the MsgBox.我认为下面的代码可能是一个很好的起点,如果我能找到一种方法来循环遍历所选电子邮件的对话的每个“子”(不确定这是否是正确的词)并将所选电子邮件移动到文件夹如果用户在 MsgBox 中选择“是”。
Public Sub GetItemsFolderPath()
Dim obj As Object
Dim F As Outlook.MAPIFolder
Dim convItemFolders As Outlook.MAPIFolder
Dim msg$
Dim rootitemcount
Set obj = Application.ActiveWindow
If TypeOf obj Is Outlook.Inspector Then
Set obj = obj.CurrentItem
Else
Set obj = obj.Selection(1)
End If
Set F = obj.Parent
msg = " The path is: " & F.FolderPath & rootitemcount & vbCrLf
msg = msg & "Switch to the folder?"
If MsgBox(msg, vbYesNo) = vbYes Then
Set Application.ActiveExplorer.CurrentFolder = F
End If
End Sub
I am having trouble putting together the loop that could make this work.我在整理可能使这项工作的循环时遇到了麻烦。 Does anyone have any suggestions for how to use the above or any other options?
有没有人对如何使用上述或任何其他选项有任何建议?
Not sure really how to show my next steps on this without "answering" my own question.不确定如何在不“回答”我自己的问题的情况下展示我的下一步。 This is my first question so I don't know all of the rules yet, if this is wrong please let me know so I can fix it.
这是我的第一个问题,所以我还不知道所有规则,如果这是错误的,请告诉我,以便我可以解决它。 I'm not fully finished but I've gotten a lot closer with the help of the below answer.
我还没有完全完成,但在以下答案的帮助下,我已经走得更近了。 Below is my updated code:
下面是我更新的代码:
Public Sub GetConverstationInformation()
Dim host As Outlook.Application
Set host = ThisOutlookSession.Application
' Check for Outlook 2010
If Left(host.Version, 2) = "14" Then
Dim selectedItem As Object
Dim theMailItem As Outlook.mailItem
' Get the user's currently selected item.
Set selectedItem = host.ActiveExplorer.Selection.item(1)
' Check to see if the item is a MailItem.
If TypeOf selectedItem Is Outlook.mailItem Then
Set theMailItem = selectedItem
' Check to see that the item's current folder
' has conversations enabled.
Dim parentFolder As Outlook.folder
Dim parentStore As Outlook.store
Set parentFolder = theMailItem.Parent
Set parentStore = parentFolder.store
If parentStore.IsConversationEnabled Then
' Try and get the conversation.
Dim theConversation As Outlook.conversation
Set theConversation = theMailItem.GetConversation
If Not IsNull(theConversation) Then
' Outlook provides a table object
' the contains all of the items in the
' conversation.
Dim itemsTable As Outlook.table
Set itemsTable = theConversation.GetTable
' Get the Root Items
' Enumerate the list of items
' only writing out data for MailItems.
' A conversation can contain other items
' like MeetingItems.
' Then use a helper method and recursion
' to walk all the items in the conversation.
Dim group As Outlook.simpleItems
Set group = theConversation.GetRootItems
Dim obj As Object
Dim fld As Outlook.folder
Dim mi As Outlook.mailItem
'Dim i As Long
For Each obj In group
If TypeOf obj Is Outlook.mailItem Then
Set mi = obj
Set fld = mi.Parent
'For i = 1 To group.Count
Me.ListBox1.AddItem fld.Name
'mi.Sender & _
'" sent the message '" & mi.Subject & _
'"' which is in '" &
'& "'."
'Next i
End If
GetConversationDetails mi, theConversation
Next obj
Else
MsgBox "The currently selected item is not a part of a conversation."
End If
Else
MsgBox "The currently selected item is not in a folder with conversations enabled."
End If
Else
MsgBox "The currently selected item is not a mail item."
End If
Else
MsgBox "This code only works with Outlook 2010."
End If
End Sub
Private Sub GetConversationDetails(anItem As Object, theConversation As Outlook.conversation)
Dim group As Outlook.simpleItems
Set group = theConversation.GetChildren(anItem)
If group.Count > 0 Then
Dim obj As Object
Dim fld As Outlook.folder
Dim mi As Outlook.mailItem
'Dim i As Long
'For i = 1 To group.Count(obj)
For Each obj In group
If TypeOf obj Is Outlook.mailItem Then
Set mi = obj
Set fld = mi.Parent
'Dim counter
Me.ListBox1.AddItem fld.Name
'mi.Sender & _
'" sent the message '" & mi.Subject & _
'"' which is in '" &
'& "'."
End If
GetConversationDetails mi, theConversation
Next obj
'Next i
End If
End Sub
Private Sub UserForm_Initialize()
GetConverstationInformation
End Sub
I dropped this into a userform with a listbox.我把它放到一个带有列表框的用户表单中。 My intention is to allow only unique folder names to be added.
我的意图是只允许添加唯一的文件夹名称。 Once that is accomplished I would like to add a button that can be clicked to file the selected email in the folder chosen from the listbox.
完成后,我想添加一个按钮,可以单击该按钮将选定的电子邮件归档到从列表框中选择的文件夹中。 Does anyone have any notes/good starting places on these next steps?
有没有人对这些后续步骤有任何注意事项/好的起点? I have been searching online for different ways to do this but I keep coming across long sub's and I have to imagine there is a more elegant solution.
我一直在网上搜索不同的方法来做到这一点,但我不断遇到长潜艇,我不得不想象有一个更优雅的解决方案。 I'll update again if I find something that works.
如果我找到有用的东西,我会再次更新。 Thanks again for your help!
再次感谢你的帮助!
It looks like you are interested in the GetConversation method which returns a Conversation object that represents the conversation to which this item belongs.看起来您对GetConversation方法感兴趣,该方法返回一个Conversation对象,该对象表示该项目所属的对话。
Private Sub DemoConversation()
Dim selectedItem As Object = Application.ActiveExplorer().Selection(1)
' For this example, you will work only with
'MailItem. Other item types such as
'MeetingItem and PostItem can participate
'in Conversation.
If TypeOf selectedItem Is Outlook.MailItem Then
' Cast selectedItem to MailItem.
Dim mailItem As Outlook.MailItem = TryCast(selectedItem, Outlook.MailItem)
' Determine store of mailItem.
Dim folder As Outlook.Folder = TryCast(mailItem.Parent, Outlook.Folder)
Dim store As Outlook.Store = folder.Store
If store.IsConversationEnabled = True Then
' Obtain a Conversation object.
Dim conv As Outlook.Conversation = mailItem.GetConversation()
' Check for null Conversation.
If conv IsNot Nothing Then
' Obtain Table that contains rows
' for each item in Conversation.
Dim table As Outlook.Table = conv.GetTable()
Debug.WriteLine("Conversation Items Count: " + table.GetRowCount().ToString())
Debug.WriteLine("Conversation Items from Table:")
While Not table.EndOfTable
Dim nextRow As Outlook.Row = table.GetNextRow()
Debug.WriteLine(nextRow("Subject") + " Modified: " + nextRow("LastModificationTime"))
End While
Debug.WriteLine("Conversation Items from Root:")
' Obtain root items and enumerate Conversation.
Dim simpleItems As Outlook.SimpleItems = conv.GetRootItems()
For Each item As Object In simpleItems
' In this example, enumerate only MailItem type.
' Other types such as PostItem or MeetingItem
' can appear in Conversation.
If TypeOf item Is Outlook.MailItem Then
Dim mail As Outlook.MailItem = TryCast(item, Outlook.MailItem)
Dim inFolder As Outlook.Folder = TryCast(mail.Parent, Outlook.Folder)
Dim msg As String = mail.Subject + " in folder " + inFolder.Name
Debug.WriteLine(msg)
End If
' Call EnumerateConversation
' to access child nodes of root items.
EnumerateConversation(item, conv)
Next
End If
End If
End If
End Sub
Private Sub EnumerateConversation(item As Object, conversation As Outlook.Conversation)
Dim items As Outlook.SimpleItems = conversation.GetChildren(item)
If items.Count > 0 Then
For Each myItem As Object In items
' In this example, enumerate only MailItem type.
' Other types such as PostItem or MeetingItem
' can appear in Conversation.
If TypeOf myItem Is Outlook.MailItem Then
Dim mailItem As Outlook.MailItem = TryCast(myItem, Outlook.MailItem)
Dim inFolder As Outlook.Folder = TryCast(mailItem.Parent, Outlook.Folder)
Dim msg As String = mailItem.Subject + " in folder " + inFolder.Name
Debug.WriteLine(msg)
End If
' Continue recursion.
EnumerateConversation(myItem, conversation)
Next
End If
End Sub
Thanks for your hard work!感谢您的辛勤工作! I wanted the same functionality and expanded on your code to add a listbox to select a folder and only allow unique folder names to be added to the listbox.
我想要相同的功能并扩展您的代码以添加一个列表框来选择一个文件夹,并且只允许将唯一的文件夹名称添加到列表框中。 I also added code to move the emails after a folder is selected.
我还添加了在选择文件夹后移动电子邮件的代码。 The finished code is working in Outlook 2016 and hosted on GitHub since listbox files are stored as binaries and cannot be shown here.
完成的代码在 Outlook 2016 中运行并托管在 GitHub 上,因为列表框文件存储为二进制文件,无法在此处显示。
GitHub: outlook-move-to-thread GitHub: Outlook 移动到线程
To update listbox and not allow duplicates in GetConversationInformation()
,要更新列表框并且不允许在
GetConversationInformation()
重复,
For Each obj In group
If TypeOf obj Is Outlook.mailItem Then
' If ROOT item is an email, add it to ListBox1
Set mi = obj
Set fld = mi.Parent
' Don't include duplicate folders
IsInListBox = False
For i = 0 To Me.ListBox1.ListCount - 1
If Me.ListBox1.Column(0, i) = fld.FolderPath Then
IsInListBox = True
End If
Next
If (InStr(fld.FolderPath, "Inbox") = 0) And _
(InStr(fld.FolderPath, "Sent Items") = 0) And _
(IsInListBox = False) Then
Me.ListBox1.AddItem fld.FolderPath
End If
End If
GetConversationDetails mi, theConversation
Next obj
To update listbox and not allow duplicates in GetConversationDetails()
,要更新列表框并且不允许在
GetConversationDetails()
重复,
' Don't include generic folders
If (InStr(fld.FolderPath, "Inbox") = 0) And _
(InStr(fld.FolderPath, "Sent Items") = 0) Then
' Don't include duplicate folders
IsInListBox = False
For i = 0 To Me.ListBox1.ListCount - 1
If Me.ListBox1.Column(0, i) = fld.FolderPath Then
IsInListBox = True
End If
Next
' Add to ListBox1
If IsInListBox = False Then
Me.ListBox1.AddItem fld.FolderPath
End If
End If
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.