I hired someone to write code which does the following when an email is highlighted.
FW Email
Insert already copied item from clipboard and paste in To Field (the copied email address)
Remove FW: from Subject line
Remove everything above the original message which includes the original email info/date/address etc.
It leaves a blank line above the first word of the body which is "Hello Name".
How can I delete that empty row so "Hello Name" is at the top of the email OR delete the "Hello Name" alltogether?
Sub ForwardFromClipboard2()
Dim tmpEmail As MailItem
Dim fwEmail As MailItem
For Each Item In Application.ActiveExplorer.Selection
If TypeName(Item) = "MailItem" Then
Set tmpEmail = Item.Forward
tmpEmail.Subject = Item.Subject
tmpEmail.To = GetClipBoardText
tmpEmail.Display
RemoveSign (tmpEmail.Subject)
Set tmpEmail = Nothing
End If
Next
End Sub
Sub RemoveSign(MySubject As String)
Dim objOL As Application
Dim objDoc As Object
Dim objSel As Object
Set objOL = Application
Set objDoc = objOL.ActiveInspector.WordEditor
Set objSel = objDoc.Application.Selection
' delete signature
If objDoc.Bookmarks.Exists("_MailOriginal") Then
Set objBkm = objDoc.Bookmarks("_MailOriginal")
objSel.Start = 0
objSel.End = objBkm.Start
objDoc.Windows(1).Selection.Delete
End If
' delete FROM:, TO:, SUBJECT:
Dim search As String
search = "Subject:"
Dim search2 As String
search2 = MySubject
For Each para In objDoc.Paragraphs
Dim txt As String
txt = para.Range.Text
If InStr(txt, search) Or InStr(txt, search2) Then
para.Range.Delete
Exit For
End If
Next
End Sub
Function GetClipBoardText() As String
Dim DataObj As MSForms.DataObject
Set DataObj = New MSForms.DataObject
On Error GoTo Whoa
DataObj.GetFromClipboard
myString = DataObj.GetText(1)
GetClipBoardText = myString
Exit Function
Whoa:
GetClipBoardText = ""
End Function
You can use the HTMLBody or the Word object model to edit the message body according to your needs. The Word object model provides the Delete method of the Range class which deletes the specified number of characters or words. See Chapter 17: Working with Item Bodies for more information.
Related
I tried to set a rule in Outlook only to learn that rules are not case-sensitive.
I want if an email is received and the subject includes "Test Email" (like This is a Test Email), then check the body.
If the body contains the word NO, in capital letters (not a part of a word), then move the email to a specific folder.
I found the below script for incoming emails that contain NO in the body.
How do I first check for "Test Email" in the title?
Private WithEvents InboxItems As Outlook.Items
Private m_Rules As Variant
Sub Application_Startup()
Dim i As Long
i = -1: ReDim m_Rules(1000)
i = i + 1: m_Rules(i) = Array("NO", "No Folder")
ReDim Preserve m_Rules(i)
Set InboxItems = Application.Session.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub InboxItems_ItemAdd(ByVal Item As Object)
Dim Folder As Outlook.MAPIFolder
Dim i As Long, Find As String
'Find = Item.Subject
Find = Item.Body
For i = 0 To UBound(m_Rules)
If InStr(1, Find, m_Rules(i)(0), vbBinaryCompare) Then
Set Folder = Application.Session.GetDefaultFolder(olFolderInbox)
Set Folder = Folder.Folders(m_Rules(i)(1))
Item.Move Folder
Exit For
End If
Next
End Sub
Here is a Regex search function which I use to filter received e-mail. Should be editable to what you desire
In ThisOutlookSession
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
On Error Resume Next
Call RegExFilterRules(EntryIDCollection)
End Sub
In a module
Sub RegExFilterRules(ItemID As String)
Dim ThisNamespace As Outlook.NameSpace: Set ThisNamespace = Application.GetNamespace("MAPI")
Dim Inbox As Outlook.MAPIFolder: Set Inbox = ThisNamespace.GetDefaultFolder(olFolderInbox)
Dim Junk As Outlook.MAPIFolder: Set Junk = ThisNamespace.GetDefaultFolder(olFolderJunk)
Dim oMsg As Outlook.MailItem: Set oMsg = ThisNamespace.GetItemFromID(ItemID, Inbox.StoreID)
If Not oMsg Is Nothing And oMsg.Class = olMail Then
If FindPattern(oMsg.Subject, "^M\d+$") Then oMsg.Move Junk ' oMsg.Delete
End If
End Sub
Private Function FindPattern(Str As String, Pattern As String) As Boolean
' Requires Reference: Microsoft Scripting Runtime
Dim RegEx As Object: Set RegEx = CreateObject("vbscript.RegExp")
With RegEx
.Global = True
.IgnoreCase = True
.MultiLine = True
.Pattern = Pattern
FindPattern = .Test(Str)
End With
End Function
I have an open Outlook meeting item.
I would enter the name of the recipients manually and run a macro which would copy the recipients to the clipboard.
Here is a screenshot where there are two recipients. The macro should copy two names into the clipboard.
My code copies the entire code not the recipient names.
Sub cellSel()
Dim clipboard As MSForms.DataObject
Dim str1 As String
Dim objWSS
Set objWSS = CreateObject("WScript.Shell")
objWSS.SendKeys "^a"
objWSS.SendKeys "^c"
Set clipboard = New MSForms.DataObject
clipboard.GetFromClipboard
If TypeName(ActiveWindow) = "Inspector" Then
If ActiveInspector.IsWordMail And ActiveInspector.EditorType = olEditorWord Then
MsgBox (clipboard.GetText)
With ActiveInspector.WordEditor.Application.ActiveDocument
With .Tables(1)
'.Cell(2, 2).Range.Select
.Cell(2, 3).Range.Text = clipboard.GetText
'.Cell(3, 2).Range.Text = clipboard.GetText
End With
End With
End If
End If
End Sub
Use the Recipients property to get the recipient names. The property returns a Recipients collection that represents all the recipients for the Outlook item.
Use Recipients (index), where index is the name or index number, to return a single Recipient object. The name can be a string representing the display name, the alias, or the full SMTP email address of the recipient.
Sub DemoMeetingRecipients()
Dim myAppointment As Outlook.AppointmentItem
Dim myPA As Outlook.PropertyAccessor
Dim d As Long
Dim myInt As Long
Set myAppointment = Application.ActiveInspector.CurrentItem
For d = 1 To myAppointment.Recipients.count
Debug.Print myAppointment.Recipients.item(d).name
Debug.Print myAppointment.Recipients.item(d).Type
Set myPA = myAppointment.Recipients.item(d).PropertyAccessor
myInt = myPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x39050003")
Debug.Print myInt
Debug.Print "---"
Next d
End Sub
I want to automatically create a greeting with the recipient's first name, on new messages.
For example, it should check the "To" field and if there is an email address, take the First Name from the contact and fill in the body of the message (ex. Dear [First Name],).
I don't know which method or event to use if I press New Message and which method or event to use to see if a recipient is added. (The macro should run every time a recepient is added.) If there are more then two recipients should be "Hello everyone,"
For a reply I am using the "Reply" event that occurs when the user selects the reply action.
Private Sub GMailItem_Reply(ByVal Response As Object, Cancel As Boolean)
AutoAddGreetingToReply Response
End Sub
This finds the recipient name and adds a greeting to the reply message.
I also tried with a Word document that contains merge fields to mail merge but it doesn't work. Here is the code that I am using for email merge.
Option Explicit
Public Sub MailMergeAttachments()
Dim Session As Outlook.NameSpace
Dim currentExplorer As Explorer
Dim Selection As Selection
Dim oContact As ContactItem
Dim oMail As MailItem
Dim attach As Attachment
Dim obj As Object
Dim oWord As Word.Application
Dim oDoc As Word.Document
Dim tmp As String
' Uses current user's profile
Dim enviro As String
enviro = CStr(Environ("USERPROFILE"))
' Get Word
Set oWord = GetObject(, "Word.Application")
Set oDoc = oWord.Documents(1)
tmp = oDoc.FullName
oDoc.Activate
oWord.Visible = True
Set currentExplorer = Application.ActiveExplorer
Set Selection = currentExplorer.Selection
If Not TypeOf Selection.Item(1) Is Outlook.ContactItem Then
MsgBox "You need to select Contacts first!"
Exit Sub
End If
For Each obj In Selection
'Test for ContactGroups
If TypeName(obj) = "ContactItem" Then
Set oContact = obj
Dim mText As String
Dim f As Word.Field
For Each f In oDoc.Fields
If f.Type = wdFieldMergeField Then
' match Word mergefields with Outlook fields
Select Case f.Code
Case " MERGEFIELD First "
mText = oContact.FirstName
Case " MERGEFIELD Last "
mText = oContact.LastName
Case " MERGEFIELD Company "
mText = oContact.CompanyName
End Select
f.Result.Text = mText
End If
Next
Set oMail = Application.CreateItem(olMailItem)
With oMail
.To = oContact.Email1Address
.Subject = Left(oDoc.Name, Len(oDoc.Name) - 5)
'The content of the document is used as the body for the email
.Body = oDoc.Content
.Attachments.Add enviro & "\Documents\instructions.pdf"
.Display ' .send
End With
End If
Next
Set oWord = Nothing
Set Session = Nothing
Set currentExplorer = Nothing
Set obj = Nothing
Set Selection = Nothing
End Sub
How do I run a macro when I select new message and how do I run it repeatedly when I enter new recipient/s and add personalised greeting in the body of the message?
I'm trying to "reply all", add text to the subject, add a recipient, and remove a recipient.
Sub Reply_All()
Dim olReply As mailitem
Dim strSubject As String
For Each olItem In Application.ActiveExplorer.Selection
Set olReply = olItem.ReplyAll
Set olRecip = olReply.Recipients.Add("EmailAddressGoesHere")
Set olRecip = olReply.Recipients.Remove("EmailAddressGoesHere")
strSubject = olReply.Subject
olReply.Subject = "(Added Subject Line Info - ) " & strSubject
olReply.Display
Next
End Sub
Everything works when I comment out the Recipients.Remove line.
I noticed that
Set olRecip = olReply.Recipients.Add("EmailAddressGoesHere")
has "Add Name As String"
While
Set olRecip = olReply.Recipients.Remove("EmailAddressGoesHere")
has "Remove Index As Long" as the yellow text that comes up when you type it into the script.
Loop through the recipients using a "for" loop from Count down to 1, check the Recipient.Address property. If it matches the value you are after, call Recipients.Remove passing the current loop index.
As Dmitry mentioned, you could refer to the below code:
Sub Reply_All()
Dim olReply As MailItem
Dim strSubject As String
For Each olItem In Application.ActiveExplorer.Selection
Set olReply = olItem.ReplyAll
For Each Address In EmailAddressGoesHere
olReply.Recipients.Add (Address)
Next
For Each Rec In olReply.Recipients
Rec.Delete
Next
strSubject = olReply.Subject
olReply.Subject = "(Added Subject Line Info - ) " & strSubject
olReply.Display
Next
End Sub
For more information, please refer to this link:
remove recipient from mail.recipient collection
Option Explicit
' Consider Option Explicit mandatory
' Tools | Options | Editor tab | Require Variable Declaration
Sub Reply_All_RemoveSingleOrMultipleCopiesAddress()
Dim olItem As Object
Dim olReply As MailItem
Dim i As Long
For Each olItem In ActiveExplorer.Selection
If olItem.Class = olMail Then
Set olReply = olItem.ReplyAll
'olReply.Display
' If the address could occur once or multiple times,
' start at the end and work backwards
For i = olReply.Recipients.count To 1 Step -1
'Debug.Print olReply.Recipients(i).Address
' "EmailAddressToBeRemoved" with the quotes as shown
If LCase(olReply.Recipients(i).Address) = LCase("EmailAddressToBeRemoved") Then
olReply.Recipients.remove (i)
End If
Next
olReply.Display
End If
Next
End Sub
Sub Reply_All_RemoveSingleAddressReliably()
Dim olItem As Object
Dim olReply As MailItem
Dim recip As recipient
For Each olItem In ActiveExplorer.Selection
If olItem.Class = olMail Then
Set olReply = olItem.ReplyAll
'olReply.Display
' If the address can appear once only,
' otherwise use a downward counting loop
For Each recip In olReply.Recipients
'Debug.Print recip.Address
' "EmailAddressToBeRemoved" with the quotes as shown
If LCase(recip.Address) = LCase("EmailAddressToBeRemoved") Then
' Delete not remove
recip.Delete
' No need to continue if only one instance of address can occur,
' otherwise you would unreliably delete anyway.
' The address immediately after a deleted address is skipped
' as it moves into the old position of the deleted address.
Exit For
End If
Next
olReply.Display
End If
Next
End Sub
To whom it may concern.
You can easily try a combination of the solutions offered for a quick result:
Set myRecipients = olReply.Recipients
Dim y As Long
y = myRecipients.Count
Do Until y = 0
If myRecipients(y) = "to be removed" Then
myRecipients(y).Delete
End If
y = y - 1
Loop
Every day I receive several automated e-mails which contain some information that needs to be forwarded to another e-mail address(es).
This e-mail address is in the automated e-mail, and will not always be the same. This e-mail address is located in a table, under the row labeled "Remarks". I've inserted a picture to illustrate this.
I would like to automate this process using Outlook VBA Macros. Some additional information:
1) I cannot use the "run a script" function under Rules.
2) The incoming e-mails are automated and will always be the same format.
What I need help is in:
1) Copying the e-mail address in the next column of the "remarks" row.
I have already managed to automate the process of recognizing the incoming e-mail (by its subject title) and auto-forwarding it to a predefined e-mail address and changing the forwarded email subject title.
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")
'Setting target folder as inbox
Set Items = objectNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub Items_ItemAdd(ByVal Item As Object)
On Error GoTo ErrorHandler
Dim Msg As Outlook.Mailitem
'act only if it is a mail item
If TypeName(Item) = "MailItem" Then
Set Msg = Item
'Detect emails with specified subject title
If Msg.Subject = "Test" Then
Set myForward = Item.Forward
myForward.Recipients.Add("test#gmail.com")
myForward.Subject = "FW: Success"
myForward.Save
myForward.Send
EndIf
EndIf
ProgramExit: Exit Sub
ErrorHandler:
MsgBox Err.Number & "-" & Err.Description
Resume ProgramExit
End Sub
According to my understand, You want to get address in email body.
You could use the below code:
Option Explicit
Sub Example()
Dim Item As MailItem
Dim RegExp As Object
Dim Search_Email As String
Dim Pattern As String
Dim Matches As Variant
Dim len1 As String
Dim result As String
Set RegExp = CreateObject("VbScript.RegExp")
Pattern = "remarks\s+(\b[A-Z0-9._%+-]+\b)"
For Each Item In ActiveExplorer.Selection
Search_Email = Item.Body
With RegExp
.Global = False
.Pattern = Pattern
.IgnoreCase = True
Set Matches = .Execute(Search_Email)
End With
If Matches.Count > 0 Then
len1 = Matches(0).Length() - 8
result = Mid(Matches(0), 12, len1)
result = result + "#gmail.com"
MsgBox result
Debug.Print Matches(0)
Else
Debug.Print "Not Found "
End If
Next
Set RegExp = Nothing
End Sub
For more information, you could refer to this link:
Extract Email address from a table in .HTMLbody