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
Related
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
I send emails that I don't get any reply to. I need to keep track of this to send a follow-up email.
I want a macro that does the following:
Before sending an email, I set a reminder with the follow-up flag. This way, I can choose a custom time to follow up on this specific email.
If the sent email is marked with a follow-up flag it is automatically marked with category "blue".
If I get a reply before the timer I set, the task is cleared and the blue category is cleared.
If I don't get a reply before the timer runs out, the category changes to red and I get a notification reminder from Outlook.
This way I can sort my "sent" folder to the two categories to see what emails need follow up. Moreover, I get a reminder each time people don't respond in time.
The below code clears the follow-up flag if I received a reply within the set time.
I don't know how to assign a category to the sent item and to clear it.
Public WithEvents objInboxItems As Outlook.Items
Private Sub Application_Startup()
Set objInboxItems = Application.Session.GetDefaultFolder(olFolderInbox).Items
End Sub
'If receive the reply, clear the flag and remove the reminder
Private Sub objInboxItems_ItemAdd(ByVal Item As Object)
Dim objSentItems As Outlook.Items
Dim objVariant As Variant
Dim i As Long
Dim strSubject As String
Dim dSendTime As String
Set objSentItems = Outlook.Application.Session.GetDefaultFolder(olFolderSentMail).Items
If Item.Class = olMail Then
For i = 1 To objSentItems.Count
If objSentItems.Item(i).Class = olMail Then
Set objVariant = objSentItems.Item(i)
strSubject = LCase(objVariant.Subject)
dSendTime = objVariant.SentOn
If LCase(Item.Subject) = "re: " & strSubject Or InStr(LCase(Item.Subject), strSubject) > 0 Then
If Item.SentOn > dSendTime Then
With objVariant
.ClearTaskFlag
.ReminderSet = False
.Save
End With
End If
End If
End If
Next i
End If
End Sub
This is a class I used some time ago. Maybe you can grab some ideas
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "ThisOutlookSession"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Option Explicit
'Categorize Sent Items
'Place in ThisOutlookSession
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
On Error Resume Next
Dim insp As Outlook.Inspector
Dim stringCatReference() As Variant
stringCatReference = Array("CAM-", "CGI-", "COS-", "CON-", "HEXA-", "ITH-", "KALL-")
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 Sub
Else
Set insp = Application.ActiveInspector
If insp.CurrentItem.Class = olMail Then
Else
Exit Sub
End If
End If
If TypeOf Item Is Outlook.MailItem And IsInArray(Item.Subject, stringCatReference) = 0 Then
Set Item = Application.ActiveInspector.CurrentItem
Item.ShowCategoriesDialog
Item.Save
End If
End Sub
Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
Dim xInt As Integer
For xInt = 0 To UBound(arr)
IsInArray = InStr(stringToBeFound, arr(xInt)) > 0
If IsInArray = True Then Exit For
Next xInt
End Function
I want to add user to an existing DL using outlook VBA. For example. I have a DL which has email id as "testdl#contoso.com" and want add an existing user name "John.Wick#contoso.com". I also know that I can use DistListItem.AddMember to add user to an existing DL. But I am getting idea to find the existing distribution list. Please help me with this.
Sub Add_User_To_DL()
Dim myNameSpace AS Outlook.NameSpace
Dim myFolder AS Outlook.Folder
Dim myDistList AS Outlook.DistListItem
Dim myFolderItems AS Outlook.Items
Set myNameSpace = Application.GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(olFolderContacts)
myFolder.Display
End Sub
But this code just opens Contacts group window. What I want is , to open the specified DL and then add specified member to DL.
To find a distribution list that includes a specific address.
Option Explicit
Sub Find_ContactGroup_Given_Member()
Dim ContactGroup As String
Dim objItem As Object
Dim objContactsFolder As Folder
Dim i As Long
Set objContactsFolder = Session.GetDefaultFolder(olFolderContacts)
For Each objItem In objContactsFolder.Items
If TypeOf objItem Is DistListItem Then
Debug.Print objItem.DLName
For i = 1 To objItem.MemberCount
If objItem.GetMember(I).Address = "testdl#contoso.com" Then
Debug.Print objItem.GetMember(i).Name
objItem.Display
End If
Next i
End If
Next
End Sub
To reference a distribution list:
Option Explicit
Sub DistListDisplay()
Dim strDistListName As String
Dim objItem As Object
Dim objContactsFolder As Folder
Dim objContactGroup As DistListItem
Dim bFound As Boolean
strDistListName = InputBox("Name of an existing distribution list.", , "Test")
If Len(strDistListName) = 0 Then Exit Sub ' Cancel
Set objContactsFolder = Session.GetDefaultFolder(olFolderContacts)
For Each objItem In objContactsFolder.Items
If TypeOf objItem Is DistListItem Then
If objItem.DLName = strDistListName Then
Set objContactGroup = objItem
With objContactGroup
.Display
bFound = True
Exit For
End With
End If
End If
Next
If bFound = False Then
MsgBox strDistListName & " not found."
End If
End Sub
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)
I created a rule, that starts a VBA-script depending on the subject of a received email (Rule: Subject "MY_SUBJECT" -> start script).
The VBA script is then doing some stuff and then it should finally delete the original email.
This part is easy:
Sub doWorkAndDeleteMail(Item As Outlook.MailItem)
' doSomething:
' delete email from inbox
Item.Delete
End Sub
Now the email will sit in the deleted-items-folder. But what I need to achieve is, to also delete this mail from the deleted-items folder. Since I know the subject of this mail (because this triggered my rule in the first place), I tried the following approach:
Sub doWorkAndDeleteMail(Item As Outlook.MailItem)
' doSomething:
' delete email from inbox
Item.Delete
End Sub
' delete email from deleted items-folder
Dim deletedFolder As Outlook.Folder
Set deletedFolder = Application.GetNamespace("MAPI"). _
GetDefaultFolder(olFolderDeletedItems)
Dim i As Long
For i = myFolder.Items.Count To 1 Step -1
If (deletedFolder.Items(i).Subject) = "MY_SUBJECT" Then
deletedFolder.Items(i).Delete
Exit For
End If
Next if
End Sub
Well, this basically works: The mail with this subject will be found in the deleted-items-folder and it will be deleted, yes.
But sadly it does not work as expected:
This permanent deletion only works once I start the script a second time.
So the email which is triggering my script will never be deleted permanently in this script's actual run, but only in the next run (once the next email with the trigger-subject for my rule is received - but then this very next email won't be deleted, again).
Do you have any idea what I am doing wrong here? It somehow looks like I need to refresh my deleted-items folder somehow. Or do I have to comit my first Item.Delete somehow explicitly?
The problem was not recreated, but try stepping through this then run normally if it appears to do what you want.
Sub doWorkAndDeleteMail(Item As mailitem)
Dim currFolder As Folder
Dim DeletedFolder As Folder
Dim i As Long
Dim mySubject As String
Set currFolder = ActiveExplorer.CurrentFolder
mySubject = Item.Subject
Debug.Print mySubject
Set DeletedFolder = GetNamespace("MAPI").GetDefaultFolder(olFolderDeletedItems)
Set ActiveExplorer.CurrentFolder = DeletedFolder
Debug.Print "DeletedFolder.count before delete: " & DeletedFolder.Items.count
' delete email from deleted items-folder
Item.Delete
Debug.Print "DeletedFolder.count after delete: " & DeletedFolder.Items.count
' If necessary
'DoEvents
For i = DeletedFolder.Items.count To 1 Step -1
Debug.Print DeletedFolder.Items(i).Subject
If (DeletedFolder.Items(i).Subject) = mySubject Then
Debug.Print DeletedFolder.Items(i).Subject & " *** found ***"
DeletedFolder.Items(i).Delete
Exit For
End If
Next
Set ActiveExplorer.CurrentFolder = currFolder
End Sub
Tim Williams suggested another existing thread. I had a look at that already before and decided that appoach would be exactly the same representation of my bug. I did try it out, though (to show my motiviation :) ), but the behaviour is - as expected - exactly the same: Again the final deletion only works once the next time the script is triggered via rule:
Sub doWorkAndDeleteMail(Item As Outlook.MailItem)
' First set a property to find it again later
Item.UserProperties.Add "Deleted", olText
Item.Save
Item.Delete
'Now go through the deleted folder, search for the property and delete item
Dim objDeletedFolder As Outlook.Folder
Dim objItem As Object
Dim objProperty As Variant
Set objDeletedFolder = Application.GetNamespace("MAPI"). _
GetDefaultFolder(olFolderDeletedItems)
For Each objItem In objDeletedFolder.Items
Set objProperty = objItem.UserProperties.Find("Deleted")
If TypeName(objProperty) <> "Nothing" Then
objItem.Delete
End If
Next
End Sub
I would be really glad to get some help here. I also wanted to comment on that other thread, but my reputation is not enough, yet.
Try something like this, code goes under ThisOutlookSession
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olNs As Outlook.NameSpace
Dim DeletedFolder As Outlook.MAPIFolder
Set olNs = Application.GetNamespace("MAPI")
Set DeletedFolder = olNs.GetDefaultFolder(olFolderDeletedItems)
Set Items = DeletedFolder.Items
End Sub
Private Sub Items_ItemAdd(ByVal Item As Object)
Dim olNs As Outlook.NameSpace
Dim DeletedFolder As Outlook.MAPIFolder
Dim Items As Outlook.Items
Dim Filter As String
Dim i As Long
Set olNs = Application.GetNamespace("MAPI")
Set DeletedFolder = olNs.GetDefaultFolder(olFolderDeletedItems)
Filter = "[Subject] = 'MY_SUBJECT'"
Set Items = DeletedFolder.Items.Restrict(Filter)
If TypeOf Item Is Outlook.MailItem Then
For i = Items.Count To 1 Step -1
DoEvents
Items.Remove i
Next
End If
End Sub
Edit
Sub doWorkAndDeleteMail(Item As Outlook.MailItem)
' First set a property to find it again later
Item.UserProperties.Add "Deleted", olText
Item.Save
Item.Delete
'Now go through the deleted folder, search for the property and delete item
Dim olNs As Outlook.NameSpace
Dim DeletedFolder As Outlook.MAPIFolder
Dim Items As Outlook.Items
Dim Filter As String
Dim i As Long
Set olNs = Application.GetNamespace("MAPI")
Set DeletedFolder = olNs.GetDefaultFolder(olFolderDeletedItems)
Filter = "[Subject] = 'MY_SUBJECT'"
Set Items = DeletedFolder.Items.Restrict(Filter)
If TypeOf Item Is Outlook.MailItem Then
For i = Items.Count To 1 Step -1
DoEvents
Items.Remove i
Next
End If
End Sub
the Mailbox folder that you get can be used as a collection, meaning that you can remove the item directly, you will need the collection to be sent to the function but that should be managable :)
Sub doWorkAndDeleteMail(Mailbox As Outlook.Folder, Item As Outlook.MailItem)
' doSomething:
' delete email from inbox
For Ite = 1 To Mailbox.Items.Count
If Mailbox.Items(Ite).EntryID = Item.EntryID Then
Mailbox.Items.Remove Ite
Exit For
End If
Next
End Sub
Remember that IF you want to Delete more than 1 Item per call of "For Ite = 1 To Mailbox.Items.Count", you will need to subtract 1 from the check of the item within the For segment since when you remove a mail from it, it will reduce the rest of the mails index number by 1.
Hope you can still use this :)
Regards Sir Rolin