Very similar requirement at first glance to Luke123's 'Append a Tag to Outlook' request.
Here, I need to append an autonumber Task ID (which is specific only to this requirement) into the Subject line of an Outlook Exchange (shared) mailbox.
This therefore needs to a) autonumber sequentially and b) run automatically as the e-mails land.
Pretty certain rules for shared mailboxes run server-side and are locked down by the business.
All ideas/help gratefully received.
This code will most likely need to be tweaked but should do what you want. You may need to take the existing Inbox items and give them a task ID in order to get the ball rolling. See my comments for explanation of the code as well as places you need to edit.
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Set olApp = Outlook.Application
' edit this line to reflect the actual mailbox name as displayed in Outlook
Set Items = Session.Folders("Mailbox - My Shared Mailbox").Folders("Inbox")
End Sub
Private Sub Items_ItemAdd(ByVal item As Object)
On Error GoTo ErrorHandler
Dim msg As Outlook.mailItem
Dim firstObj As Object
Dim i As Long
Dim firstMsg As Outlook.mailItem
Dim currentTaskID As String
Dim nextTaskID As Long
If TypeName(item) = "MailItem" Then ' it's an email
Set msg = item
' get first email from Inbox to determine next task ID
Do Until TypeName(firstObj) = "MailItem" Or i = Session.Folders("Mailbox - My Shared Mailbox").Folders("Inbox").Items.Count
i = i + 1
' might have to start at item #2?
Set firstObj = Session.GetDefaultFolder(olFolderInbox).Items(i)
Loop
' typecast the object to mailitem for Intellisense
If TypeName(firstObj) = "MailItem" Then
Set firstMsg = firstObj
Else
' display messagebox?
Goto ProgramExit
End If
' get task id and calculate next value, let's assume it's the last three chars of subject
' Ex: Subject: Incoming Email - TaskId: 001
currentTaskID = Right$(firstMsg.Subject, 3)
nextTaskID = CLng(currentTaskID) + 1
' put next task ID number into new email's subject
With msg
.Subject = msg.Subject & " - TaskId: " & nextTaskID
.Save
End With
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
Related
My task is to send an email containing a report and send another email containing another report to the same email thread by way of replying/forwarding to the sent email (excluding some recipients).
Option Explicit
Sub TestReply()
Dim objApp As Application
Dim objNewMail As Outlook.MailItem
Dim objReply As Outlook.MailItem
Set objApp = Outlook.Application
Set objNewMail = objApp.CreateItem(0)
' Outgoing email
With objNewMail
.Subject = "Test sending email"
.To = "abc#abc.com"
.HTMLBody = "This is the outgoing email."
.Send
End With
' Reply email
Set objReply = objNewMail.ReplyAll
With objReply
.HTMLBody = "This is the reply emal."
.Display
End With
Set objApp = Nothing
Set objNewMail = Nothing
Set objReply = Nothing
End Sub
I can't find a way to send the follow up email (either by reply or forward).
When I try the above code, it says error the item is moved/deleted. I guess it is becaused when the email is sent, the objNewMail odject is also terminated.
I tried adding RE: or FW: to the subject of the original email but then the two emails will not be in the same thread but independent emails.
An additional problem is that I have two email accounts in Outlook: my own email and team email and the reports are to be sent from the team email.
You can determine if an item added to the sent folder matches objNewMail.
In ThisOutlookSession
Option Explicit
Private WithEvents sentFolderItems As Items
Private Sub Application_Startup()
'Set sentFolderItems = Session.GetDefaultFolder(olFolderSentMail).Items
' Reference any folder by walking the folder tree
' assuming the team folder is in the navigation pane
Set sentFolderItems = Session.folders("team mailbox name").folders("Sent").Items
End Sub
Private Sub sentFolderItems_ItemAdd(ByVal Item As Object)
Dim myReplyAll As MailItem
If Item.Class = olMail Then
'do not use InStr unless you change some part of words in original subject
' or another reply will be generated
If Item.Subject = "Test sending email" Then
Set myReplyAll = Item.ReplyAll
With myReplyAll
.HTMLBody = "This is the reply email."
.Display
End With
End If
End If
End Sub
Sub TestReply()
Dim objNewMail As MailItem
'Set objNewMail = CreateItem(olMailItem)
' Add, not create, in non-default folder
Set objNewMail = Session.folders("team mailbox name").folders("Inbox").Items.Add
' Outgoing email
With objNewMail
.Subject = "Test sending email"
.To = "abc#abc.com"
.HTMLBody = "This is the outgoing email."
.Send
End With
End Sub
Note: Application. and Outlook. are not needed when code is in Outlook.
Call Send on the original email (objNewMail) only after you construct the reply.
Right so currently your code is doing this:
Creating a mail, sending it.
Trying to reply to the mailitem object which is already sent.
What you need is an event Hook to catch the mail when it's received by yourself. (assuming this is how you're reply all and removing some recipients for report 2)
Here is how you accomplish this:
First Create a WithEvents as Items call AllMyItems, then a hook in the AllMyItems_ItemAdd, then initialize the event when Outlook Starts using Application_Startup (a built in event)
Be very careful to identify criteria for forwarding / actioning the incoming mail item, since this event code will scan every mail sent to your main inbox and evaluate it. IF you want to further reduce the risk of forwarding a mail item to the wrong person, consider using an outlook rule to sort it into a custom folder, and then setting that folder's location as the Set AllMyItems = line instead of default folder
Option Explicit
'for the Default DL inbox
Private WithEvents AllMyItems As Items
Private Sub Application_Startup()
Dim olapp As Outlook.Application
Dim objNS As Outlook.NameSpace
Set olapp = Outlook.Application
Set objNS = olapp.GetNamespace("MAPI")
'Set myolitems = objNS.GetDefaultFolder(olFolderInbox).Items
'all my items in the main box
Set AllMyItems = objNS.GetDefaultFolder(olFolderInbox).Items
Set olapp = Nothing
Set objNS = Nothing
End Sub
Private Sub AllMyItems_ItemAdd(ByVal Item As Object)
On Error Resume Next
If TypeName(Item) <> "Mailitem" Then
If TypeName(Item) = "ReportItem" Then GoTo 0 'undeliverables shows as a report item
If TypeName(Item) = "MeetingItem" Then GoTo 0
Dim oItem As MailItem
Dim myForward As MailItem
Set oItem = Item
'use the next line to check for a property of the incoming mail, that distinguishes it from other mail, since this event will run on every mail item
If InStr(1, oItem.Subject, "Your public folder is almost full", vbTextCompare) > 0 Then
Set myForward = oItem.Forward
myForward.Recipients.Add "derp#derpinacorp.com"
myForward.Importance = olImportanceHigh
'MsgBox "uno momento"
myForward.Send
Else
End If
Else
End If
0:
End Sub
I am trying to change incoming emails subject line to only the last 11 characters of the subject line. When I use Item.Subject = Right(Item.Subject,11) it does not work.
Can someone assist?
Full code.
Sub ChangeSubjectForward(Item As Outlook.MailItem)
Item.Subject = Right(Item.Subject, 11)
Item.Save
End Sub
You could create a macro rule then run the below code:
Sub save_to_dir_test1(mymail As MailItem)
Dim strID As String
Dim objMail As Outlook.MailItem
strID = mymail.EntryID
Set objMail = Application.Session.GetItemFromID(strID)
objMail.Subject = Right(m.Subject, 11)
objMail.Save
Set objMail = Nothing
End Sub
For more information, please refer to this link:
Run a Script Rule: Change Subject then Forward Message
Getting the incoming email in outlook via VBA
I found another SO thread that says you can't modify the subject of a message without opening it first. We can use ActiveInspector to get a handle on the Item after we display it. Then we can change it, save it, and close it. I added a check to see if the subject is actually longer than 11 characters before we attempt to truncate it.
Try this:
Public Sub ChangeSubjectForward(ByRef Item As Outlook.MailItem)
Debug.Print Now ' This shows you when the code runs
If Len(Item.Subject) > 11 Then
Debug.Print "Subject is too long. Trimming..." ' This shows that we tried to truncate.
Item.Display 'Force the pop-up
Dim thisInspector As Inspector
Set thisInspector = Application.ActiveInspector
Set Item = thisInspector.CurrentItem ' Get the handle from the Inspector
Item.Subject = Right$(Item.Subject, 11)
Item.Save
Item.Close
End If
End Sub
can someone advise what have I done wrong on here? It is not picking up the emails the way it should (i.e. automatically download the attachments into a folder). There is no error messages, but simply no action (I went F8 but would not notice any irregularities).
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub Items_ItemAdd(ByVal item As Object)
On Error GoTo ErrorHandler
'Only act if it's a MailItem
Dim Msg As Outlook.MailItem
If TypeName(item) = "MailItem" Then
Set Msg = item
'Change variables to match need. Comment or delete any part unnecessary.
If (Msg.SenderName = "test123#gmail.com") And _
(Msg.Subject = "Test123") And _
(Msg.Attachments.Count >= 1) Then
'Set folder to save in.
Dim olDestFldr As Outlook.MAPIFolder
Dim myAttachments As Outlook.Attachments
Dim Att As String
'location to save in. Can be root drive or mapped network drive.
Const attPath As String = "C:\Test\Test1\"
' save attachment
Set myAttachments = item.Attachments
Att = myAttachments.item(1).DisplayName
myAttachments.item(1).SaveAsFile attPath & Att
Msg.UnRead = False
End If
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
Also, when I'm trying to F8 for errors, the VBA only goes through the first part of the code i.e. Private Sub Application_Startup(), I'm unable to test the other part {Private Sub Items_ItemAdd(ByVal item As Object)} cos the VBA simply denies going through it line by line (no error pop-ups or anything, it simply is not picking up the lines)
The problem is in the line
myAttachments.item(1).SaveAsFile attPath & Att
You are always picking attachment no 1, which might be something else than you think. Add a For Each around this, and you'll hopefully get some better results.
My guess is that your problem is this condition:
If (Msg.SenderName = "test123#gmail.com")
The MailItem.SenderName property returns the display name of the sender, which may not be the actual email address. You should be checking the MailItem.SenderEmailAddress property instead.
If the email you're trying to match is an Exchange address (ie, it's from someone in your office's Outlook account), the MailItem.SenderEmailAddress will return an incomprehensible string that you'll need to resolve to an actual email. In that case, you'd need to check the MailItem.Sender.GetExchangeUser().PrimarySmtpAddress property instead.
For that reason, I like to use an "emailMatches" function that checks both scenarios. Then your condition would be something like:
If emailMatches(Msg, "test123#company.com")
Here's the function I use:
Function emailMatches(mItem As Object, addressToMatch As String) As Boolean
Dim goAhead As Boolean
goAhead = False
If UCase(mItem.SenderEmailAddress) = UCase(addressToMatch) Then
goAhead = True
ElseIf Left(mItem.SenderEmailAddress, 5) = "/O=EX" Then
If UCase(mItem.Sender.GetExchangeUser().PrimarySmtpAddress) = UCase(addressToMatch) Then
goAhead = True
End If
End If
emailMatches = goAhead
End Function
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. 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.
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?
Edit
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.
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.
GitHub: outlook-move-to-thread
To update listbox and not allow duplicates in 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(),
' 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
Hello does anyone know how to create a VB Script that will add a rule in Outlook 2003 such that if I receive an email from user PersonA#mail.com it will forward that email to PersonB#mail.com.
I would also like to know if it possible to create a VB Script to remove the previously created rule.
I've done a little research and it seems possible to create a macro to do this, but I am completely lost as I am not familiar with the objects I need to be editing or have any sort of API.
Maybe I have to create a Macro to add the rules and this use a VB script to fire the Macro.
I would use straight VBA instead. The ItemAdd Event can be used to check your default Inbox for incoming messages and forward them. It is simple to edit the email addresses if you need to change the forwarding.
Ex:
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub Items_ItemAdd(ByVal item As Object)
On Error Goto ErrorHandler
Dim Msg As Outlook.MailItem
Dim newMsg As Outlook.MailItem
Dim recip As Outlook.Recipient
' *****************
' edit these to change forwarding rules
' *****************
Const INCOMING_EMAIL As String = "Persion#mail.com"
Const OUTGOING_EMAIL As String = "PersonB#mail.com"
If TypeName(item) = "MailItem" Then
Set Msg = item
If Msg.SenderEmailAddress = INCOMING_EMAIL Then
Set newMsg = Msg.Forward
With newMsg
Set recip = .Recipients.Add OUTGOING_EMAIL
recip.Type = olTo
.Send
End With
' *****************
' perhaps a msgbox?
' MsgBox "Message forwarded", vbInformation
' *****************
End If
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
This code should be placed in ThisOutlookSession module, then you must restart Outlook. If you need placement assistance see Where do I put my Outlook VBA code?