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
Related
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?
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
I took at a look at MailItem and didn't see anything that would indicate that I could shift select items.
I have code that functions however, the Set objItem = GetCurrentItem() line only takes one mail.
I'm looking to either ForEach through a folder, or ForEach through a selection.
I tried something like
Sub ListMailsInFolder()
Dim objNS As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder
Set objNS = GetNamespace("MAPI")
Set objFolder = objNS.Folders.GetFirst ' folders of your current account
Set objFolder = objFolder.Folders("Foldername").Folders("Subfoldername")
For Each Item In objFolder.Items
I don't have any idea what I'm doing.
Here is the code I'm trying to execute on multiple emails:
Sub HelpdeskNewTicket()
Dim helpdeskaddress As String
Dim objMail As Outlook.MailItem
Dim strbody As String
Dim oldmsg As String
Dim senderaddress As String
Dim addresstype As Integer
' Set this variable as your helpdesk e-mail address
helpdeskaddress = "danielbelamiinc#gmail.com"
Set objItem = GetCurrentItem()
Set objMail = objItem.Forward
' Sender E=mail Address
senderaddress = objItem.SenderEmailAddress
strbody = objItem.Body
objMail.To = helpdeskaddress
objMail.Subject = objItem.Subject
objMail.Body = strbody
'Automatically Send the ticket
objMail.Send
Set objItem = Nothing
Set objMail = Nothing
End Sub
Function GetCurrentItem() As Object
Dim objApp As Outlook.Application
Set objApp = Application
On Error Resume Next
Select Case TypeName(objApp.ActiveWindow)
Case "Explorer"
Set GetCurrentItem = _
objApp.ActiveExplorer.Selection.Item(1)
Case "Inspector"
Set GetCurrentItem = _
objApp.ActiveInspector.CurrentItem
Case Else
End Select
End Function
To loop through selection items use For...Next Statement Loop [MSDN]
Syntax
For counter = initial_value To end_value [Step step-counter]
Example on Selection Items
Option Explicit
Public Sub Example()
Dim Item As Outlook.mailitem
Dim i As Long
For i = ActiveExplorer.Selection.Count To 1 Step -1
Set Item = ActiveExplorer.Selection.Item(i)
Debug.Print Item.Subject
' Call Sub
Next
End Sub
Example on Folder Items
Option Explicit
Public Sub Example()
Dim Inbox As Outlook.folder
Set Inbox = Application.Session.GetDefaultFolder( _
olFolderInbox _
)
Dim Items As Outlook.Items
Set Items = Inbox.Items
Dim i As Long
For i = Items.Count To 1 Step -1
DoEvents
Debug.Print Items(i) 'Print on Immediate Window
Next
End Sub
DoEvents MSDN & Debug.Print SO Link
Description
loop executes a given number of times, as determined by a loop counter. To use the For...Next loop, you must assign a numeric value to a counter variable. This counter is either incremented or decremented automatically with each iteration of the loop. In For statement, you specify the value that is to be assigned to the counter initially and the maximum value the counter will reach for the block of code to be executed. The Next statement marks the end of the block of code that is to execute repeatedly, and also serves as a kind of flag that indicates the counter variable is to be modified.
CurrentFolder Property
Returns or sets a MAPIFolder object that represents the current folder displayed in the explorer. Use this property to change the folder the user is viewing.
I am trying to send a completed work email containing multiple PDF attachments, I wish send only the PDF files to the recipient and avoid any other atttachments such as excel files or image files only pdf to be forwarded.
P.S. note email may have more than 1 attachments with combination of pdfs, excels, images, however only pdfs have to be forwarded. I'm unable to find how to code that part. please see below my existing code.
Sub Send2Recipient()
' Send Completed Message to Recipient
On Error Resume Next
Dim oApp As Outlook.Application
Dim objFolder As Outlook.MAPIFolder
Set oApp = New Outlook.Application
Set objNS = Application.GetNamespace("MAPI")
Set objInbox = objNS.GetDefaultFolder(olFolderInbox)
Set objFolder = objInbox.Folders("Helpdesk")
Dim oEmail As Outlook.MailItem
Dim strFile As String
Dim sFileType As String
'Require that this procedure be called only when a message is selected
If Application.ActiveExplorer.Selection.Count = 0 Then
Exit Sub
End If
For Each objItem In Application.ActiveExplorer.Selection
If objFolder.DefaultItemType = olMailItem Then
If objItem.Class = olMail Then
Response = MsgBox("Forward message (" + item.Subject + ") to Appended Subject")
Set myforward = objItem.Forward
myforward.Body = "Scan Only"
myforward.Subject = "Scan Only"
myforward.Recipients.Add "DHL.GB01PREV#dhl.com"
myforward.Display
End If
End If
Next
End Sub
Updated VBA script
Sub Send2New()
' Send Completed Message to Accenture
On Error Resume Next
Dim oApp As Outlook.Application
Dim objFolder As Outlook.MAPIFolder
Set oApp = New Outlook.Application
Set objNS = Application.GetNamespace("MAPI")
Set objInbox = objNS.GetDefaultFolder(olFolderInbox)
'Set objFolder = objInbox.Folders("Helpdesk")
Dim oEmail As Outlook.MailItem
Dim strFile As String
Dim sFileType As String
Dim bk, fg As Integer
'Require that this procedure be called only when a message is selected
If Application.ActiveExplorer.Selection.Count = 0 Then
Exit Sub
End If
For Each objItem In Application.ActiveExplorer.Selection
If objFolder.DefaultItemType = olMailItem Then
If objItem.Class = olmail Then
Response = MsgBox("Forward message (" + Item.Subject + ") to Appended Subject")
Set myforward = objItem.Forward
myforward.Body = "Scan Only"
myforward.Subject = "Scan Only"
myforward.Recipients.Add "xyz#abc.com"
myforward.Display
bk = myforward.Attachments.Count
fg = 1
For i = 1 To bk
If InStr(LCase(myforward.Attachments(fg).FileName), ".pdf") = 0 Then
myforward.Attachments(fg).Delete
Else: fg = fg + 1
End If
Next i
End If
End If
Next
End Sub
I have created two macros for you.
The first, Investigate, outputs information about attachments to the Immediate Window. There are four types of attachment. A “standard” attachment is of type “By Value”. I have never seen an OLE attachment and do not know what such an attachment is. I have seen the other types but not for many years.
The second, ForwardEmailsWithoutNonPdfAttachments(), demonstrates the functionality you seek. I have sent emails containing a selection of attachments from my Gmail account to my Outlook account and have used the macro to send them back with the non-PDF attachments deleted. These attachments were all “By Value” attachments. I am not sure what would happen if you tried to forward emails with other types of attachments which is the reason for the first macro. This macro is not very elegant but it demonstrates the techniques necessary to meet your objective.
Option Explicit
Public Sub Investigate()
Dim AttachType As String
Dim Exp As Outlook.Explorer
Dim InxAttach As Long
Dim ItemCrnt As MailItem
Dim NumAttach As Long
Dim NumSelected As Long
Set Exp = Outlook.Application.ActiveExplorer
NumSelected = Exp.Selection.Count
If NumSelected = 0 Then
Debug.Print "No emails selected"
Else
For Each ItemCrnt In Exp.Selection
With ItemCrnt
Debug.Print "From: " & .SenderName & " | Subject: " & .Subject
For InxAttach = 1 To .Attachments.Count
' There are four types of attachment:
' * olByValue 1
' * olByReference 4
' * olEmbeddedItem 5
' * olOLE 6
With .Attachments(InxAttach)
Select Case .Type
Case olByValue
AttachType = "Val"
Case olEmbeddeditem
AttachType = "Ebd"
Case olByReference
AttachType = "Ref"
Case olOLE
AttachType = "OLE"
Case Else
AttachType = "Unk"
End Select
Debug.Print AttachType & " " & .FileName & " | " & .DisplayName
End With ' .Attachments(InxAttach)
Next ' ItemCrnt
End With
Next
End If
End Sub
Sub ForwardEmailsWithoutNonPdfAttachments()
Dim AttachType As String
Dim Exp As Outlook.Explorer
Dim InxAttach As Long
Dim ItemCopy As MailItem
Dim ItemOrig As MailItem
Dim NumAttach As Long
Dim NumSelected As Long
Set Exp = Outlook.Application.ActiveExplorer
NumSelected = Exp.Selection.Count
If NumSelected = 0 Then
Debug.Print "No emails selected"
Else
For Each ItemOrig In Exp.Selection
Set ItemCopy = ItemOrig.Copy
With ItemCopy
.Subject = "FW: " & .Subject
' Delete all original recipients
Do While .Recipients.Count > 0
.Recipients.Remove (1)
Loop
' Add new recipient
.Recipients.Add "tonydallimore23#gmail.com"
If .Attachments.Count > 0 Then
For InxAttach = .Attachments.Count To 1 Step -1
With .Attachments(InxAttach)
' This will stop the macro if an attachment is not a regular attachment
Debug.Assert .Type = olByValue
If LCase(Right$(.FileName, 4)) <> ".pdf" Then
.Delete
End If
End With ' .Attachments(InxAttach)
Next InxAttach
End If
.Send
End With ' ItemCopy
Set ItemCopy = Nothing
Next ItemOrig
End If
End Sub
got a little problem, I hope someone can help me.
(Outlook 2010 VBA)
this is my current code, what i need is when i click on a mail (only the mail i clicked on, not every mail in the folder/same place)
it has to check if the Sender of the mail is already in my contacts or in the
Addressbook 'All Users',
and if it's not a one of those yet, open the AddContact window and fill in his/her information
what doesn't work yet is:
most important of all, it doesn't run the script when i click on a mail
the current check if the contact already exsist doesn't work
and goes with a vbMsgBox (yes or no and response stuff) wich is not what i want/need
if the contact already exsist then nothing has to happen.
I hope i gave enough information and someone can help me out here :)
Sub AddAddressesToContacts(objMail As Outlook.MailItem)
Dim folContacts As Outlook.MAPIFolder
Dim colItems As Outlook.Items
Dim oContact As Outlook.ContactItem
Dim oMail As Outlook.MailItem
Dim obj As Object
Dim oNS As Outlook.NameSpace
''don't want or need a vbBox/ask box, this is a part of the current contactcheck
''wich doesn't work and is totaly wrong :P
Dim response As VbMsgBoxResult
Dim bContinue As Boolean
Dim sSenderName As String
On Error Resume Next
Set oNS = Application.GetNamespace("MAPI")
Set folContacts = oNS.GetDefaultFolder(olFolderContacts)
Set colItems = folContacts.Items
''this selects the mail that is currently selected.
''what i want is that the sender of the new incoming mail gets added to contacts
''(ofcourse, if that contact doesn't exsist yet)
''so the new incoming mail gotta be selected.
For Each obj In Application.ActiveExplorer.Selection
If obj.Class = olMail Then
Set oContact = Nothing
bContinue = True
sSenderName = ""
Set oMail = obj
sSenderName = oMail.SentOnBehalfOfName
If sSenderName = ";" Then
sSenderName = oMail.SenderName
End If
Set oContact = colItems.Find("[FullName] = '" & sSenderName & "'")
''this part till the --- is wrong, i need someting to check if the contact (the sender)
''already exsists. Any ideas?
If Not (oContact Is Nothing) Then
response = vbAbort
If response = vbAbort Then
bContinue = False
End If
End If
''---------
If bContinue Then
Set oContact = colItems.Add(olContactItem)
With oContact
.Email1Address = oMail.SenderEmailAddress
.Email1DisplayName = sSenderName
.Email1AddressType = oMail.SenderEmailType
.FullName = oMail.SenderName
'.Save
oContact.Display
End With
End If
End If
Next
Set folContacts = Nothing
Set colItems = Nothing
Set oContact = Nothing
Set oMail = Nothing
Set obj = Nothing
Set oNS = Nothing
End Sub
hey, i still have a last question,
'sets the name of the contact
Set oContact = colItems.Find("[FullName] = '" & sSenderName & "'")
'checks if the contact exsist, if it does exit the for loop
If Not oContact Is Nothing Then
Exit For
End If
End If
this checks if the name is already in contacts,
i need it that it checks if the E-mailaddress is in contacts or not,
can you help me with that?
i had someting like this in mind
set oSendermail = ?the e-mailaddress?
If Not oSendermail Is Nothing Then
Exit For
End If
End If
A solution (including test routine) could look as follows:
(assuming that we only consider external SMTP mails. Adjust the path to your contact folder and add some more error checking!)
Option Explicit
Private Declare Function GetTickCount Lib "kernel32.dll" () As Long
Sub AutoContactMessageRule(newMail As Outlook.mailItem)
' "script" routine to be called for each incoming Mail message
' This subroutine has to be linked to this mail type using
' Outlook's rule assistant
Dim EntryID As String
Dim StoreID As Variant
Dim mi As Outlook.mailItem
Dim contactFolder As Outlook.Folder
Dim contact As Outlook.ContactItem
On Error GoTo ErrorHandler
' we have to access the new mail via an application reference
' to avoid security warnings
EntryID = newMail.EntryID
StoreID = newMail.Parent.StoreID
Set mi = Application.Session.GetItemFromID(EntryID, StoreID)
With mi
If .SenderEmailType = "SMTP" Then
Set contactFolder = FindFolder("Kemper\_local\TestContacts")
Set contact = contactFolder.items.Find("[Email1Address]=" & Chr(34) & .SenderEmailAddress & Chr(34))
If Not TypeName(contact) <> "Nothing" Then
Set contact = contactFolder.items.Add(olContactItem)
contact.Email1Address = .SenderEmailAddress
contact.Email1AddressType = .SenderEmailType
contact.FullName = .SenderName
contact.Save
End If
End If
End With
Exit Sub
ErrorHandler:
MsgBox Err.Description, vbCritical, "Ooops!"
Err.Clear
On Error GoTo 0
End Sub
Private Function FindFolder(path As String) As Outlook.Folder
' Locate MAPI Folder.
' Separate sub-folder using '/' . Example: "My/2012/Letters"
Dim fd As Outlook.Folder
Dim subPath() As String
Dim I As Integer
Dim ns As NameSpace
Dim s As String
On Error GoTo ErrorHandler
s = Replace(path, "\", "/")
If InStr(s, "//") = 1 Then
s = Mid(s, 3)
End If
subPath = Split(s, "/", -1, 1)
Set ns = Application.GetNamespace("MAPI")
For I = 0 To UBound(subPath)
If I = 0 Then
Set fd = ns.Folders(subPath(0))
Else
Set fd = fd.Folders(subPath(I))
End If
If fd Is Nothing Then
Exit For
End If
Next
Set FindFolder = fd
Exit Function
ErrorHandler:
Set FindFolder = Nothing
End Function
Public Sub TestAutoContactMessageRule()
' Routine to test Mail Handlers AutoContactMessageRule()'
' without incoming mail messages
' select an existing mail before executing this routine
Dim objItem As Object
Dim objMail As Outlook.mailItem
Dim started As Long
For Each objItem In Application.ActiveExplorer.Selection
If TypeName(objItem) = "MailItem" Then
Set objMail = objItem
started = GetTickCount()
AutoContactMessageRule objMail
Debug.Print "elapsed " & (GetTickCount() - started) / 1000# & "s"
End If
Next
End Sub