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
Related
I have been tasked to create an automated report system where an report from Google Data Studios are uploaded to specific projects (On a site called Basecamp). The reports always include both a report within the body of the e-mail and an attached PDF file. The are sent to a Gmail account (data studios refuse to schedule towards a non-Google account). The filters within Gmail doesnt really work well with the Basecamp system so I use filters to re-route them towards a Outlook account. There I use rules to send each e-mail towards the correct client within Basecamp.
Here comes the problem, Basecamp shows both the body of the e-mail AND the attached PDF version which makes us show duplicates.
Is there a way to create a macro that first deletes all attachments (or body of an e-mail) and THEN forward the e-mail.
It cant be done manually it have to be a rule that does it automaticaly. Keep in mind that I am not a coder and have never done anything like this so please keep it simple for my dumb brain!
Thank you in advance!
Marcus
PS: I found a code that seems to be what I am after.
Public WithEvents ReceivedItems As Outlook.Items
Private Sub Application_Startup()
Set ReceivedItems = Outlook.Application.Session.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub ReceivedItems_ItemAdd(ByVal Item As Object)
Dim xForwardMail As Outlook.MailItem
Dim xEmail As MailItem
On Error Resume Next
If Item.Class <> olMail Then Exit Sub
Set xEmail = Item
If InStrRev(UCase(xEmail.Subject), UCase("kto feature")) = 0 Then Exit Sub 'change subject text to your need
If xEmail.Attachments.Count = 0 Then Exit Sub
Set xForwardMail = xEmail.Forward
With xForwardMail
.HTMLBody = ""
With .Recipients
.Add "skyyang#addin88.com" 'change address to your own
.ResolveAll
End With
.Send
End With
End Sub
I am trying to get that code to work, and changes the subject to a specific word and then route it to a final e-mail account that then filters out to correct clients. However the code doesnt seem to work, it DOES forward the e-mail but the attachment is still there. The code was found at https://www.extendoffice.com/documents/outlook/5359-outlook-forward-attachment-only.html#a1
It seems you need to modify the code slightly:
Public WithEvents ReceivedItems As Outlook.Items
Private Sub Application_Startup()
Set ReceivedItems = Outlook.Application.Session.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub ReceivedItems_ItemAdd(ByVal Item As Object)
Dim xForwardMail As Outlook.MailItem
Dim xEmail As MailItem
Dim myattachments as Outlook.Attachments
On Error Resume Next
If Item.Class <> olMail Then Exit Sub
Set xEmail = Item
If InStrRev(UCase(xEmail.Subject), UCase("kto feature")) = 0 Then Exit Sub 'change subject text to your need
If xEmail.Attachments.Count = 0 Then Exit Sub
Set xForwardMail = xEmail.Forward
Set myattachments = xForwardMail.Attachments
While myattachments.Count > 0
myattachments.Remove 1
Wend
With xForwardMail
.HTMLBody = ""
With .Recipients
.Add "skyyang#addin88.com" 'change address to your own
.ResolveAll
End With
.Send
End With
End Sub
The Remove method of the Attachments class removes an object from the collection.
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 receive mails, from two senders, with two subjects, to a specific address.
I set up a rule:
from: example#example.com or example2#example2.com
sent to: me#me.com
and with: Company return doc or Daily document Country in the subject
except if the subject contains "FW:"
to run a script:
Sub myRuleMacro(Item As Outlook.MailItem)
Dim selEmail As Outlook.MailItem
Set selEmail = ActiveExplorer.Selection.Item(1).Forward
selEmail.Recipients.Add "address#address.pl"
selEmail.Send
Set selEmail = Nothing
End Sub
The script works for the selected email but to select it I need to click it manually, or if any other email is already clicked/marked it forwards this marked email, not the one from the rule.
How to choose the mail from the rule to trigger the macro?
Basically I need the solution which will forward the email. I cannot use the forwarding rule due to company safety policies.
You all most got it, it should be
Example
Option Explicit
Public Sub myRuleMacro(Item As Outlook.MailItem)
Dim selEmail As Outlook.MailItem
If TypeOf Item Is Outlook.MailItem Then
Set selEmail = Item.Forward
selEmail.Subject = Item.Subject
selEmail.HTMLBody = Item.HTMLBody
selEmail.Recipients.Add "address#address.pl"
selEmail.Save
selEmail.Send
End If
End Sub
No need for Selection.Item and make sure to save it before sending it
The email that the rule is triggered on is already being passed to the sub Item as Outlook.MailItem -- Sub myRuleMacro(**Item As Outlook.MailItem**)
You're not using this provided item and selecting a DIFFERENT item when you use Set selEmail = ActiveExplorer.Selection.Item(1).Forward
You should be able to simply use Item.Forward
Try
Sub myRuleMacro(Item As Outlook.MailItem)
Dim newForward as MailItem
Set newForward = Item.Forward
newForward.Recipients.Add "address#address.pl"
newForward.Send
End Sub
EDITED: To include updates by #Tony Dallimore in comments.
Below is the code that I am running in ThisOutlookSession. The code is meant to check all incoming emails and if the email is from a certain email address and contains a specific string in the subject then a new email is created from a template and the triggering email is attached and the email is then sent out to a different email address. This portion all works fine.
Also to note I am using windows 10 and office 2016.
The problem that I am having is the email is converted to plain text unless it is displayed first. The template that I have created is saved as a HTML formatted message. I have tried adding lines such as
NewMsg.BodyFormat = olFormatHTML
NewMsg.save
But this doesn't seem to work as the email that is sent was still in the plain text format. If I add the following to that the message it basically works.
NewMsg.BodyFormat = olFormatRichText
NewMsg.save
NewMsg.BodyFormat = olFormatHTML
NewMsg.save
However the above block of code removes a lot of the formatting that was saved in my template such as different fonts/ font sizes.
Am I missing something about working with templates in VBA?
Also The problem that I am having with displaying the message first is two things. The obvious one is the flash that this causes because the message is briefly displayed. The second is my default signature is also added to the displayed message but I wanted to use a custom signature that I built into my template.
Here is my full code with sensitive information removed.
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")
' default local Inbox
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
If TypeName(item) = "MailItem" Then
Set Msg = item
If Msg.SenderEmailAddress <> "example#example.com" Then GoTo Skip
If InStr(1, Msg.Subject, "Specific String") > 0 Then 'checks if subject contains the proper string
Set NewMsg = Application.CreateItemFromTemplate("Template Path")
Msg.Subject = Replace(Msg.Subject, "Old Subject", "New subject")
Msg.Save
NewMsg.HTMLBody = NewMsg.HTMLBody
NewMsg.Attachments.Add Msg
NewMsg.Recipients.Add("Example#Example.com")
NewMsg.Subject = Msg.Subject
NewMsg.Save
NewMsg.Send
End If
End If
Skip:
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
End Sub
Reset the HTMLBody property - that will force HTML format:
Msg.HTMLBody = Msg.HTMLBody
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?