├── LICENSE ├── ListThread.bas ├── ListThreadFolders.frm ├── ListThreadFolders.frx ├── README.md └── images ├── moved_emails.png └── select_folder.png /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2019 Kyle Johnston 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /ListThread.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "ListThread" 2 | ' Displays a list of folders that other messages in the conversation belong to 3 | ' Clicking on a folder moves the messages to that folder 4 | 5 | Sub MoveToThread() 6 | ' Start process to show the list of folders 7 | 8 | Debug.Print 9 | Debug.Print 10 | Debug.Print ("Running ListThread.MoveToThread") 11 | 12 | ' Start ListThreadFolders.UserForm_Initialize() 13 | ListThreadFolders.Show 14 | 15 | Debug.Print 16 | Debug.Print 17 | 18 | End Sub 19 | -------------------------------------------------------------------------------- /ListThreadFolders.frm: -------------------------------------------------------------------------------- 1 | VERSION 5.00 2 | Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} ListThreadFolders 3 | Caption = "Select folder to move emails to" 4 | ClientHeight = 3015 5 | ClientLeft = 120 6 | ClientTop = 465 7 | ClientWidth = 11190 8 | OleObjectBlob = "ListThreadFolders.frx":0000 9 | StartUpPosition = 1 'CenterOwner 10 | End 11 | Attribute VB_Name = "ListThreadFolders" 12 | Attribute VB_GlobalNameSpace = False 13 | Attribute VB_Creatable = False 14 | Attribute VB_PredeclaredId = True 15 | Attribute VB_Exposed = False 16 | 17 | Public Sub UserForm_Initialize() 18 | 19 | GetConversationInformation 20 | 21 | End Sub 22 | 23 | Public Sub GetConversationInformation() 24 | 25 | ' Original code obtained from the following site (credit user TimO): 26 | ' https://stackoverflow.com/questions/29304844/outlook-2010-vba-to-save-selected-email-to-a-folder-other-emails-in-that-convers?rq=1 27 | 28 | ' Get root items in conversation 29 | 30 | Dim host As Outlook.Application 31 | Set host = ThisOutlookSession.Application 32 | 33 | ' Get the user's currently selected item 34 | Set selectedItem = host.ActiveExplorer.Selection.item(1) 35 | Debug.Print ("Selected item: " & selectedItem.ConversationTopic) 36 | 37 | ' Check to see that the item's current folder has conversations enabled 38 | Dim parentFolder As Outlook.folder 39 | Dim parentStore As Outlook.store 40 | Set parentFolder = selectedItem.Parent 41 | Set parentStore = parentFolder.store 42 | If parentStore.IsConversationEnabled Then 43 | ' Try and get the conversation. 44 | Dim theConversation As Outlook.conversation 45 | Set theConversation = selectedItem.GetConversation 46 | If Not IsNull(theConversation) Then 47 | ' Outlook provides a table object the contains all of the items in the conversation 48 | Dim itemsTable As Outlook.table 49 | Set itemsTable = theConversation.GetTable 50 | 51 | ' Start with the Root Items 52 | ' Then use recursion to walk all the items in the conversation 53 | GetConversationDetails theConversation, theConversation.GetRootItems, "" 54 | Else 55 | MsgBox "The currently selected item is not a part of a conversation." 56 | End If 57 | Else 58 | MsgBox "The currently selected item is not in a folder with conversations enabled." 59 | End If 60 | 61 | ' Display message box and/or move emails 62 | If Me.ListBox1.ListCount = 0 Then 63 | ' Don't open the window 64 | MsgBox ("No folders found") 65 | End 66 | End If 67 | If Me.ListBox1.ListCount = 1 Then 68 | ' Move emails and don't open window 69 | Call MoveMail(Me.ListBox1.Column(0, 0)) 70 | MsgBox ("Moved email(s) to " & Me.ListBox1.Column(0, 0)) 71 | End 72 | End If 73 | 74 | End Sub 75 | 76 | Private Sub GetConversationDetails(theConversation As Outlook.conversation, group As Outlook.SimpleItems, indent As String) 77 | 78 | ' Original code obtained from the following site (credit user TimO): 79 | ' https://stackoverflow.com/questions/29304844/outlook-2010-vba-to-save-selected-email-to-a-folder-other-emails-in-that-convers?rq=1 80 | 81 | ' From the root items, find all the messages and add to ListBox1 82 | 83 | If group.Count > 0 Then 84 | Debug.Print (indent & "Getting conversation details...") 85 | Dim obj As Object ' an email 86 | Dim fld As Outlook.folder ' full path to the folder the email is in (\\AcountName\Folder) 87 | Dim sfld As String ' path to the folder the email is in excluding the account name (\Folder) 88 | Dim IsInListBox As Boolean 89 | For Each obj In group 90 | If TypeOf obj Is Outlook.MailItem Or TypeOf obj Is Outlook.AppointmentItem Or TypeOf obj Is Outlook.MeetingItem Then 91 | ' If item is an email, add it to ListBox1 92 | 93 | Set fld = obj.Parent 94 | FolderPathEncoded = Replace(fld.FolderPath, "%2F", "/") 95 | Debug.Print (indent & "FolderPathEncoded: " & FolderPathEncoded & " (" & TypeName(obj) & ")") 96 | 97 | ' Don't include generic folders 98 | ' Localized to: Portuguese (PT) 99 | sfld = Mid(FolderPathEncoded, InStr(3, FolderPathEncoded, "\") + 1) 100 | If (sfld <> "Inbox") And _ 101 | (sfld <> "Drafts") And _ 102 | (sfld <> "Sent Items") And _ 103 | (sfld <> "Calendar") And _ 104 | (sfld <> "Auto Replies") And _ 105 | (InStr(sfld, "Shared Data") = 0) And _ 106 | (InStr(1, ",Caixa de Entrada,Rascunhos,Itens Enviados,Calendário,Arquivo,", "," & sfld & ",", vbTextCompare) = 0) Then 107 | 108 | ' Make IsInListBox true if folder has already been added 109 | IsInListBox = False 110 | For i = 0 To Me.ListBox1.ListCount - 1 111 | If Me.ListBox1.Column(0, i) = FolderPathEncoded Then 112 | IsInListBox = True 113 | End If 114 | Next 115 | 116 | ' Add folder to ListBox if IsInListBox is false 117 | If (IsInListBox = False) Then 118 | Me.ListBox1.AddItem FolderPathEncoded 119 | Debug.Print (indent & "Added " & FolderPathEncoded & " to ListBox") 120 | End If 121 | 122 | End If 123 | 124 | Else 125 | Debug.Print (indent & "Skipping obj of type " & TypeName(obj)) 126 | End If 127 | 128 | ' Repeat the process if this email is also a root item 129 | GetConversationDetails theConversation, theConversation.GetChildren(obj), indent & " " 130 | 131 | Next obj 132 | End If 133 | 134 | End Sub 135 | 136 | Private Sub ListBox1_Click() 137 | 138 | ' Move mail to selected folder 139 | Call MoveMail(Me.ListBox1.Value) 140 | 141 | ' Close UserForm 142 | Unload Me 143 | 144 | End Sub 145 | 146 | Sub MoveMail(inputfolder As String) 147 | 148 | ' Original code obtained from the following site (credit Diane Poremsky): 149 | ' https://www.slipstick.com/outlook/macro-move-folder/ 150 | 151 | Dim objOutlook As Outlook.Application 152 | Dim objNamespace As Outlook.NameSpace 153 | Dim objSourceFolder As Outlook.MAPIFolder 154 | Dim objDestFolder As Outlook.MAPIFolder 155 | Dim objItems As MailItem 156 | 157 | Set objOutlook = Application 158 | Set objNamespace = objOutlook.GetNamespace("MAPI") 159 | Set objSourceFolder = objNamespace.GetDefaultFolder(olFolderDrafts) 160 | Set objDestFolder = GetFolder(inputfolder) 161 | 162 | For Each objItem In objOutlook.ActiveExplorer.Selection 163 | 164 | ' Move folder if destination is different than current 165 | If objItem.Parent <> objDestFolder Then 166 | objItem.Move objDestFolder 167 | Debug.Print ("Moved '" & objItem.ConversationTopic & "' to '" & objDestFolder.name & "'") 168 | Else 169 | Debug.Print ("Skipped moving '" & objItem.ConversationTopic & "' to '" & objDestFolder.name & "' (same folder)") 170 | End If 171 | 172 | Next 173 | 174 | Set objDestFolder = Nothing 175 | 176 | End Sub 177 | 178 | Function GetFolder(ByVal FolderPath As String) As Outlook.folder 179 | 180 | ' Original code obtained from the following site (credit users "office 365 dev account", "Office GSX", Kim Brandl - MSFT, JiayueHu): 181 | ' https://docs.microsoft.com/en-us/office/vba/outlook/how-to/items-folders-and-stores/obtain-a-folder-object-from-a-folder-path 182 | 183 | ' Convert folder path in form of "\\folder1\folder2\folder3" to a folder object 184 | 185 | Dim TestFolder As Outlook.folder 186 | Dim FoldersArray As Variant 187 | Dim i As Integer 188 | 189 | On Error GoTo GetFolder_Error 190 | If Left(FolderPath, 2) = "\\" Then 191 | FolderPath = Right(FolderPath, Len(FolderPath) - 2) 192 | End If 193 | 194 | ' Convert folderpath to array 195 | FoldersArray = Split(FolderPath, "\") 196 | Set TestFolder = Application.Session.Folders.item(FoldersArray(0)) 197 | If Not TestFolder Is Nothing Then 198 | For i = 1 To UBound(FoldersArray, 1) 199 | Dim SubFolders As Outlook.Folders 200 | Set SubFolders = TestFolder.Folders 201 | Set TestFolder = SubFolders.item(FoldersArray(i)) 202 | If TestFolder Is Nothing Then 203 | Set GetFolder = Nothing 204 | End If 205 | Next 206 | End If 207 | 208 | ' Return the TestFolder 209 | Set GetFolder = TestFolder 210 | Exit Function 211 | 212 | GetFolder_Error: 213 | Set GetFolder = Nothing 214 | Exit Function 215 | 216 | End Function 217 | -------------------------------------------------------------------------------- /ListThreadFolders.frx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/k4j8/outlook-move-to-thread/4937c540d71678f36ff067016a6a72dff2309d6b/ListThreadFolders.frx -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # outlook-move-to-thread 2 | Microsoft Outlook VBA to move emails to the same folder as the rest of the email thread 3 | 4 | When this macro is run within the main window of Microsoft Outlook, the user will be prompted with a pop-up containing a list of folders that emails within the thread already reside in, excluding default folders such as "Inbox" and "Sent Items". The user picks a folder from the list and emails will be moved to the selected folder. 5 | 6 | ![Example of selecting the folder](images/select_folder.png) 7 | 8 | If there would only be one folder in the list, then the emails will be moved without prompting the user and the macro displays a message box confirming the move. 9 | 10 | ![Example of moving emails](images/moved_emails.png) 11 | 12 | ## Installation 13 | Open Outlook VBA window using a method such as Alt+F11. 14 | 15 | Import files by selecting "File" -> "Import File...". Import `ListThread.bas` and `ListThreadFolders.frm`. `ListThreadFolders.frx` must be in the same directory as `ListThreadFolders.frm` when it is imported. 16 | 17 | ### Signing the Macro 18 | If you receive a warning stating "The macros in this project are disabled," you probably have security settings that only allow signed macros. 19 | 20 | To sign the macro, see [Digitally sign your VBA macro project | Microsoft Support](https://support.microsoft.com/en-us/office/digitally-sign-your-macro-project-956e9cc8-bbf6-4365-8bfa-98505ecd1c01). 21 | 22 | After signing and saving the project, restart Outlook. You may get a warning because the certificate is self-signed (depending on your security settings). If you trust the publisher (yourself), the notice will not appear again. 23 | 24 | ## Usage 25 | Run `MoveToThread` in `ListThread.bas` to start the macro. 26 | 27 | For easy access to run the macro, create a [ribbon](https://support.microsoft.com/en-us/office/customize-the-ribbon-in-office-00f24ca7-6021-48d3-9514-a31a460ecb31) or [quick access](https://support.microsoft.com/en-us/office/customize-the-quick-access-toolbar-43fff1c9-ebc4-4963-bdbd-c2b6b0739e52) shortcut. The macro will be available under "Macros" as `Project1.MoveToThread`. 28 | 29 | ## Localization 30 | The macro ignores default folders for the following languages: 31 | - English (US) 32 | - Portuguese (PT) 33 | 34 | See commit [744c4ed](https://github.com/k4j8/outlook-move-to-thread/commit/744c4ed46bf76bec88b0b302f0f358a96817cef1#diff-934591ddc75022ac0b12b82d1a44f7d572d3724183229b594a0829036ea899e3) to understand how to localize for a language and then submit a pull request. Or, create an issue for additional languages. 35 | 36 | ## Limitations 37 | The macro crashes if certain symbols such as the percent sign (%) or backslash (\\) are within a folder name. 38 | 39 | ## Contributing 40 | Pull requests, issues, and feature suggestions are welcome. All code in pull requests must be tested in Outlook and exported directly from the program to ensure import compatibility. 41 | 42 | ## Acknowledgements 43 | Much of the code has been copied and edited from various sites and forums. Credit to original sources is given in the code where applicable. 44 | -------------------------------------------------------------------------------- /images/moved_emails.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/k4j8/outlook-move-to-thread/4937c540d71678f36ff067016a6a72dff2309d6b/images/moved_emails.png -------------------------------------------------------------------------------- /images/select_folder.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/k4j8/outlook-move-to-thread/4937c540d71678f36ff067016a6a72dff2309d6b/images/select_folder.png --------------------------------------------------------------------------------