Last active
September 10, 2025 18:27
-
-
Save Ajedi32/eb00e0440ffa52f019375d8af5ea0348 to your computer and use it in GitHub Desktop.
VBA script to get a Gmail-style archive feature in Outlook (with the Inbox being a label rather than a folder)
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Sub ArchiveSelected() | |
| Call RemoveCategoryFromItems("Inbox", _ | |
| Application.ActiveExplorer.Selection) | |
| ' Also handle conversations if any are selected | |
| ' Oddly, conversations are not part of the regular selection | |
| Call RemoveCategoryFromItems("Inbox", _ | |
| Application.ActiveExplorer.Selection.GetSelection(olConversationHeaders)) | |
| End Sub | |
| Sub RemoveCategoryFromItems(categoryToRemove As String, selectedItems As Selection) | |
| Dim obj As Object | |
| Debug.Print "Removing '" & categoryToRemove; "' category from " & selectedItems.Count & " items." | |
| For Each obj In selectedItems | |
| If TypeOf obj Is mailItem Or TypeOf obj Is MeetingItem Then | |
| Call RemoveCategoryFromMail(obj, categoryToRemove) | |
| ElseIf TypeOf obj Is ConversationHeader Then | |
| Call RemoveCategoryFromConversation(obj.GetConversation, categoryToRemove) | |
| ElseIf Not obj Is Nothing Then | |
| MsgBox "Selected object is of unkown type '" & (TypeName(obj)) & "'", vbInformation | |
| End If | |
| Next obj | |
| ' MsgBox "Category '" & categoryToRemove & "' removed from selected emails and conversations.", vbInformation | |
| End Sub | |
| Private Sub RemoveCategoryFromMail(mail As Object, categoryToRemove As String) | |
| Dim categoriesArray() As String | |
| Dim newCategories As String | |
| Dim i As Integer | |
| If mail.Categories <> "" Then | |
| categoriesArray = Split(mail.Categories, ",") | |
| newCategories = "" | |
| For i = LBound(categoriesArray) To UBound(categoriesArray) | |
| If Trim(categoriesArray(i)) <> categoryToRemove Then | |
| If newCategories <> "" Then | |
| newCategories = newCategories & ", " | |
| End If | |
| newCategories = newCategories & Trim(categoriesArray(i)) | |
| End If | |
| Next i | |
| If mail.Categories <> newCategories Then | |
| mail.Categories = newCategories | |
| mail.Save | |
| End If | |
| End If | |
| End Sub | |
| Private Sub RemoveCategoryFromConversation(conv As Conversation, categoryToRemove As String) | |
| Dim table As table | |
| Dim row As row | |
| Dim item As Object | |
| Set table = conv.GetTable | |
| Do Until table.EndOfTable | |
| Set row = table.GetNextRow | |
| Set item = Application.Session.GetItemFromID(row("EntryID")) | |
| If TypeOf item Is mailItem Or TypeOf item Is MeetingItem Or TypeOf item Is AppointmentItem Then | |
| Call RemoveCategoryFromMail(item, categoryToRemove) | |
| ElseIf Not item Is Nothing Then | |
| MsgBox "Item in conversation is of unkown type '" & (TypeName(item)) & "'", vbInformation | |
| End If | |
| Loop | |
| End Sub |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment