Remove an email from outbox and re-edit - vba

I have VBA code to delay sending messages by five minutes.
Dim obj As Object
Dim Mail As Outlook.MailItem
Dim WkDay As Integer
Dim MinNow As Integer
Dim SendHour As Integer
Dim SendDate As Date
Dim SendNow As String
Dim UserDeferOption As Integer
Function getActiveMessage() As Outlook.MailItem
Dim insp As Outlook.Inspector
If TypeOf Application.ActiveWindow Is Outlook.Inspector Then
Set insp = Application.ActiveWindow
End If
If insp Is Nothing Then
Dim inline As Object
Set inline = Application.ActiveExplorer.ActiveInlineResponse
If inline Is Nothing Then Exit Function
Set getActiveMessage = inline
Else
Set insp = Application.ActiveInspector
If insp.CurrentItem.Class = olMail Then
Set getActiveMessage = insp.CurrentItem
Else
Exit Function
End If
End If
End Function
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
SendDate = Now()
SendHour = Hour(Now)
MinNow = Minute(Now)
Set obj = getActiveMessage()
If obj Is Nothing Then
'Do Nothing'
Else
If TypeOf obj Is Outlook.MailItem Then
Set Mail = obj
SendMin = 5
SendDate = DateAdd("n", SendMin, SendDate)
Mail.DeferredDeliveryTime = SendDate
End If
End If
Exit Sub
End Sub
I need a way to stop the item from sending. We can't delete it and start again as emails take a long time to compose and are highly detailed.
I'd like to add a button to the ribbon or context menu of Outlook 365, to re-open the email for editing and stop the deferred send.
I get
an object can't be found
Sub MoveEmail()
Dim OutboxFolder As Outlook.Folder
Set OutboxFolder = GetNamespace("MAPI").GetDefaultFolder(olFolderOutbox)
Set MoveFolder = GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders("Drafts")
Dim CurrentItem As Object
For Each CurrentItem In OutboxFolder.Items
CurrentItem.Move MoveFolder
Next CurrentItem
End Sub

Got it sorted, for anyone else...
Sub MoveEmail()
Dim myNamespace As Outlook.NameSpace
Set myNamespace = Application.GetNamespace("MAPI")
Set OutboxFolder = myNamespace.GetDefaultFolder(olFolderOutbox)
Set MoveFolder = myNamespace.GetDefaultFolder(olFolderDrafts)
Dim CurrentItem As Object
For Each CurrentItem In OutboxFolder.Items
CurrentItem.Move MoveFolder
Next CurrentItem
End Sub

Related

Set mails read if they were read in another folder

I'm trying to make an outlook macro, which will 'update' the mails. I have an Inbox folder and an another one. (2 mail accunts)
There is a rule, which is copying the mail from another folder to my inbox.
My goal is to set the mail as read in another folder, if it was read in the Inbox folder.
Sub precitane()
Dim myNameSpace As Outlook.NameSpace
Dim myInbox As Outlook.Folder
Dim myDestFolder As Outlook.Folder
Dim mydeffolder As Outlook.Folder
Dim items As Object
Dim defitems As Object
Set myNameSpace = Application.GetNamespace("MAPI")
Set myDestFolder = myNameSpace.Folders("") 'mymail
Set mydeffolder = myNameSpace.GetDefaultFolder(olFolderInbox)
For Each items In myDestFolder.items
For Each defitems In mydeffolder.items
If TypeOf items Is Outlook.MailItem & TypeOf defitems Is Outlook.MailItem Then
Dim oMail As Outlook.MailItem: Set oMail = items
Dim defMail As Outlook.MailItem: Set defMail = defitems
If oMail.SenderEmailAddress = "" & defMail.SenderEmailAddress = "" & defMail.Body = oMail.Body & defMail.UnRead = False Then
oMail.UnRead = True
oMail.Save
End If
End If
Next
Next
On Error GoTo 0
End Sub
"" contains my mail...
It looks like you tried with code from other than VBA.
I broke the If statement into separate parts as it is easier to follow and to debug.
Option Explicit
Sub precitane()
Dim myDestFolder As Folder
Dim mydeffolder As Folder
Dim item As Object
Dim defItem As Object
Set myDestFolder = Session.Folders("mailAddress2").Folders("Inbox").Folders("Test")
Set mydeffolder = Session.GetDefaultFolder(olFolderInbox).Folders("Test3")
For Each item In myDestFolder.items
If TypeOf item Is MailItem Then
For Each defItem In mydeffolder.items
If TypeOf defItem Is MailItem Then
If item.senderEmailAddress = defItem.senderEmailAddress Then
If item.Body = defItem.Body Then
If item.UnRead = False Then
defItem.UnRead = False
'If necessary
'item.Save
Exit For
End If
End If
End If
End If
Set defItem = Nothing
Next
End If
Set item = Nothing
Next
Debug.Print "Done."
End Sub

Move email after being categorized

I want to move emails, once they are categorized, into a folder with the same name as the category.
What I found so far:
Private WithEvents Explorer As Outlook.Explorer
Private WithEvents Mail As Outlook.MailItem
Private MoveToThisFolder As Outlook.MAPIFolder
Friend Sub Application_Startup()
On Error Resume Next
Set Explorer = Application.ActiveExplorer
End Sub
Private Sub Explorer_SelectionChange()
Dim obj As Object
Dim Sel As Outlook.Selection
Set Mail = Nothing
Set Sel = Explorer.Selection
If Sel.Count > 0 Then
Set obj = Sel(1)
If TypeOf obj Is Outlook.MailItem Then
Set Mail = obj
End If
End If
End Sub
Private Sub Mail_PropertyChange(ByVal Name As String)
Dim Ns As Outlook.NameSpace
Dim Inbox As Outlook.MAPIFolder
Dim Subfolder As Outlook.MAPIFolder
Dim SubfolderName As String
If Name = "Categories" Then
Set Ns = Application.GetNamespace("MAPI")
Set Inbox = Ns.GetDefaultFolder(olFolderInbox)
SubfolderName = Mail.Categories
If Len(SubfolderName) = 0 Then Exit Sub
Set Subfolder = Inbox.Folders(SubfolderName)
If Subfolder.EntryID <> Mail.Parent.EntryID Then
Set MoveToThisFolder = Subfolder
EnableTimer 500, Me
End If
End If
End Sub
Friend Sub TimerEvent()
DisableTimer
If Mail Is Nothing Then Exit Sub
If MoveToThisFolder Is Nothing Then Exit Sub
Mail.Move MoveToThisFolder
Set Mail = Nothing
Set MoveToThisFolder = Nothing
End Sub
I have some problems with respect to Friend Sub TimerEvent () because it gives me
Sub or Function not compiled correctly
At the end i figured out in this way:
Private WithEvents xInboxFld As Outlook.Folder
Private WithEvents xInboxItems As Outlook.Items
Private Sub Application_Startup()
Set xInboxFld = Outlook.Application.Session.GetDefaultFolder(olFolderInbox)
Set xInboxItems = xInboxFld.Items
End Sub
Private Sub xInboxItems_ItemChange(ByVal Item As Object)
Dim xMailItem As Outlook.MailItem
Dim xFlds As Outlook.Folders
Dim xFld As Outlook.Folder
Dim xTargetFld As Outlook.Folder
Dim xFlag As Boolean
On Error Resume Next
If Item.Class = olMail Then
Set xMailItem = Item
xFlag = False
If xMailItem.Categories <> "" Then
Set xFlds = Application.Session.GetDefaultFolder(olFolderInbox).Folders
If xFlds.Count <> 0 Then
For Each xFld In xFlds
If xFld.Name = xMailItem.Categories Then
xFlag = True
End If
Next
End If
If xFlag = False Then
Application.Session.GetDefaultFolder(olFolderInbox).Folders.Add xMailItem.Categories, olFolderInbox
End If
Set xTargetFld = Application.Session.GetDefaultFolder(olFolderInbox).Folders(xMailItem.Categories)
xMailItem.Move xTargetFld
End If
End If
End Sub
Hope it could help!!!
The error is due to missing code for DisableTimer and EnableTimer.
The category has not yet updated when the code is triggered.
EnableTimer delays the move until after the category updates.
Without a delay, there would be an error when attempting to update, due to the item having been moved.
Attribution: http://www.vboffice.net/en/developers/trigger-actions-with-categories/

How can I compare all the titles of all RSS feeds and delete duplicates?

I'm wondering if there is a way to compare ALL TITLES in ALL RSS FEEDS and delete the duplicates.
I read through a lot of RSS Feeds, and it's obvious that a lot of people cross-post to several forums, and then I end up seeing the same RSS Feed multiple times.
I think the script will look something like this, but it doesn't seem to delete dupes.....
Option Explicit
Public Sub DupeRSS()
Dim olNs As Outlook.NameSpace
Dim RSS_Folder As Outlook.MAPIFolder
Set olNs = Application.GetNamespace("MAPI")
Set RSS_Folder = olNs.GetDefaultFolder(olFolderRssFeeds)
'Process Current Folder
Example RSS_Folder
End Sub
Public Sub Example(ByVal ParentFolder As Outlook.MAPIFolder)
Dim itm As Object, itms As Items, dupes As Object, i As Long, k As Variant
Set dupes = CreateObject("Scripting.Dictionary")
Set itms = ParentFolder.Items
For i = itms.Folders.Count To 1 Step -1
Set itm = itms(i)
If TypeOf itm Is PostItem Then
If dupes.Exists(itm.Subject) Then itm.Delete Else dupes(itm.Subject) = 0
Else
Example itm 'Recursive call for Folders
End If
Next i
'Show dictionary items
If dupes.Count > 0 Then
For Each k In dupes
Debug.Print k
Next
End If
Set itm = Nothing: Set itms = Nothing: Set dupes = Nothing
End Sub
Thanks to all!!
Maybe this is what your trying to do, the following code saves/adds all the Items subject line to the collection and then continues to search multiple folders and then deletes if it finds duplicates-
Option Explicit
Public Sub DupeRSS()
Dim olNs As Outlook.NameSpace
Dim RSS_Folder As Outlook.MAPIFolder
Dim DupItem As Object
Set DupItem = CreateObject("Scripting.Dictionary")
Set olNs = Application.GetNamespace("MAPI")
Set RSS_Folder = olNs.GetDefaultFolder(olFolderRssFeeds)
' // Process Current Folder
Example RSS_Folder, DupItem
End Sub
Public Sub Example(ByVal ParentFolder As Outlook.MAPIFolder, _
ByVal DupItem As Object)
Dim Folder As Outlook.MAPIFolder
Dim Item As Object
Dim Items As Items
Dim i As Long
Set Items = ParentFolder.Items
Debug.Print ParentFolder.Name
For i = Items.Count To 1 Step -1
DoEvents
If TypeOf Items(i) Is PostItem Then
Set Item = Items(i)
If DupItem.Exists(Item.Subject) Then
Debug.Print Item.Subject ' Print on Immediate Window
Debug.Print TypeName(Item) ' Print on Immediate Window
Item.Delete
Else
DupItem.Add Item.Subject, 0
Debug.Print DupItem.Count, Item.Subject
End If
End If
Next i
' // Recurse through subfolders
If ParentFolder.Folders.Count > 0 Then
For Each Folder In ParentFolder.Folders
Example Folder, DupItem
Debug.Print Folder.Name
Next
End If
Set Folder = Nothing
Set Item = Nothing
Set Items = Nothing
End Sub
Try the changes bellow
Option Explicit
'Required - VBA Editor -> Tools -> References: Microsfot Outlook XXX Object Library
'Required - VBA Editor -> Tools -> References: Microsfot Scripting Runtime (Dictionary)
Public Sub RemoveRSSduplicates()
Dim olNs As Outlook.Namespace, olApp As Object, rssFolder As Folder, d As Dictionary
Set olApp = GetObject(, "Outlook.Application")
Set olNs = olApp.GetNamespace("MAPI")
Set rssFolder = olNs.GetDefaultFolder(olFolderRssFeeds)
Set d = CreateObject("Scripting.Dictionary")
ProcessOutlookRSSFeeds rssFolder, d
End Sub
Public Sub ProcessOutlookRSSFeeds(ByVal rssFolder As Folder, ByRef d As Dictionary)
Dim fldr As Folder, itm As Object
For Each fldr In rssFolder.Folders
If fldr.Items.Count > 0 Then
For Each itm In fldr.Items
If TypeOf itm Is PostItem Then
If Not d.Exists(itm.Subject) Then d(itm.Subject) = 0 Else itm.Delete
End If
Next
End If
Next
End Sub
Note: avoid variable names that will hide other objects (ex. Dim Items As Items)

Macro not showing up in Macro menu when clicking F5

I have VBA code that auto forwards all emails to an external account. I can't get the macro to show up in the Macro menu when I click F5 to run it.
Sub AutoForwardAllSentItemsss(Item As Outlook.MailItem)
Dim strMsg As String
Dim autoFwd As Outlook.MailItem
Set autoFwd = Item.forward
autoFwd.Recipients.Add "test#test.com"
autoFwd.Send
Set autoFwd = Nothing
End Sub
Set up a rule with a run a script option. You will see it when you choose a script.
If that is not what you are asking then.
Sub ManuForwardAllSelectedItemsss_V1()
Dim Item As Object
Dim iSend As Long
For iSend = 1 To ActiveExplorer.Selection.Count
If TypeOf Item Is mailItem Then
Set Item = ActiveExplorer.Selection(iSend)
AutoForwardAllSentItemsss Item
End If
Next
Set Item = Nothing
MsgBox "Done"
End Sub
or
Sub ManuForwardAllSelectedItemsss_V2()
Dim manuFwd As Outlook.mailItem
Dim Item As mailItem
Dim iSend As Long
For iSend = 1 To ActiveExplorer.Selection.Count
Set Item = ActiveExplorer.Selection(iSend)
If TypeOf Item Is mailItem Then
Set manuFwd = Item.Forward
manuFwd.Recipients.Add "test#test.com"
manuFwd.Send
End If
Next
Set Item = Nothing
Set manuFwd = Nothing
End Sub

VBA outlook 2010 move

m.display works but m.move(A) does not.
The folder exist.
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
Dim arr() As String
Dim myInbox As Outlook.Folder
Dim A As Outlook.Folder
Set myNameSpace = Application.GetNamespace("MAPI")
Set myInbox =
myNameSpace.GetDefaultFolder(olFolderInbox)
Set A = myInbox.Folders("A")
Dim i As Integer
Dim m As MailItem
On Error Resume Next
arr = Split(EntryIDCollection, ",")
For i = 0 To UBound(arr)
Set m = Application.Session.GetItemFromID(arr(i))
If m.SenderEmailAddress = "notifications#transcore.com" Then
'MsgBox (m.Body)
m.Display
m.Move (A)
End If
Next
End Sub
Move is a function, not a sub. Move the message first, then display it:
set m = m.Move(A)
m.Display