When replying to a meeting invite sent to a non-default account in Outlook 365 desktop, it typically responds from the default account. The following code fixed that problem, but recently stopped working correctly.
My replies used to say, "Yes, NONdefaultrecipientemail#gmail.com will attend" "From: nondefaultrecipientemail#gmail.com."
Now it says, "Yes, Defaultemail#gmail.com will attend" "From: nondefaultrecipientemail#gmail.com on behalf of Defaultemail#gmail.com."
Any ideas on why this no longer works and how to fix it?
Thanks!
Sub MeetingResponse(myAction As String)
'If a meeting request is sent to the non-default email address, replies, etc., will normally come from the default email.
'This macro changes the send from email address to the correct one.
Dim myNameSpace As Outlook.NameSpace
Dim myAppt As Outlook.AppointmentItem
Dim oMtgResponse, oReplyForward, oMtgRequest As Outlook.MeetingItem
Dim oAccount As Outlook.Account
Dim SendAcct As Variant
Dim SendEmailAddr As String
Dim FolderParent As String
Set myNameSpace = Application.GetNamespace("MAPI")
'Determine which account invite was sent to.
FolderParent = Application.ActiveExplorer.CurrentFolder.Parent
For Each oAccount In Application.Session.Accounts
If oAccount.DeliveryStore.GetDefaultFolder(olFolderInbox).Parent = FolderParent Then
SendAcct = oAccount.DisplayName
Exit For
End If
Next
Set oMtgRequest = GetCurrentItem()
If TypeName(oMtgRequest) <> "Nothing" Then
Set myAppt = oMtgRequest.GetAssociatedAppointment(True)
'Set send from account
For Each oAccount In Application.Session.Accounts
If oAccount = SendAcct Then
Select Case UCase(myAction)
Case "ACCEPT"
Set oMtgResponse = myAppt.Respond(olResponseAccepted, True)
oMtgResponse.SendUsingAccount = oAccount
oMtgResponse.Display
oMtgRequest.Delete
Case "DECLINE"
Set oMtgResponse = myAppt.Respond(olResponseDeclined, True)
oMtgResponse.SendUsingAccount = oAccount
oMtgResponse.Display
oMtgRequest.Delete
'Original inviter may be notified this was forwarded.
Case "FORWARD"
Set oReplyForward = oMtgRequest.Forward
oReplyForward.SendUsingAccount = oAccount
oReplyForward.Display
'Original inviter will not be notified this was forwarded.
'Creates new appointment based on original one.
Case "FORWARDSILENT", "FORWARD SILENT"
Dim oAppt As AppointmentItem
Set oAppt = Application.CreateItem(olAppointmentItem)
With oAppt
.MeetingStatus = olMeeting
.Subject = "Accepted: " & myAppt.Subject
.Start = myAppt.Start
.Duration = myAppt.Duration
.Location = myAppt.Location
.Body = myAppt.Body
.Display
.SendUsingAccount = oAccount
End With
Case "REPLY"
Set oReplyForward = oMtgRequest.reply
oReplyForward.SendUsingAccount = oAccount
oReplyForward.Display
Case "FORWARDASATTACHMENT", "FORWARD AS ATTACHMENT"
Case Else
MsgBox "Could not process! Incorrect action provided.", vbCritical + vbOKOnly
End Select
Exit For
End If
Next
End If
End Sub 'MeetingResponse
The MeetingItem.SendUsingAccount property allows setting an Account object that represents the account to use to send the MeetingItem. But in your code you are trying to set the property to a string which contains the display name of the Account chosen.
Declare an instance of the Account class in the code and initialize it in the following way:
FolderParent = Application.ActiveExplorer.CurrentFolder.Parent
For Each oAccount In Application.Session.Accounts
If oAccount.DeliveryStore.GetDefaultFolder(olFolderInbox).Parent = FolderParent Then
Set SendAcct = oAccount
Exit For
End If
Next
Then you can set the MeetingItem.SendUsingAccount property correctly:
oMtgResponse.SendUsingAccount = oAccount
Related
I have been able to create an automated email reply as I wanted. However, I wanted to add text in the body of the email and cc to add email address. How should I add it?
Sub FwdSelToAddr()
Dim objOL As Outlook.Application
Dim objItem As Object
Dim objFwd As Outlook.MailItem
Dim strAddr As String
Dim objRecip As Outlook.Recipient
Dim objReply As MailItem
On Error Resume Next
Set objOL = Application
Set objItem = objOL.ActiveExplorer.Selection(1)
If Not objItem Is Nothing Then
strAddr = ParseTextLinePair(objItem.Body, "Email:")
If strAddr <> "" Then
Set objFwd = objItem.Forward
objFwd.To = strAddr
objFwd.Display
Else
MsgBox "Could not extract address from message."
End If
End If
Set objOL = Nothing
Set objItem = Nothing
Set objFwd = Nothing
End Sub
This is what I have done so far. I just want to be able to add CC email address and text in the body in the automated reply.
You need to modify the code a bit by setting the Cc property and the HTMLBody one if you need to modify or update the message body:
If strAddr <> "" Then
Set objFwd = objItem.Forward
objFwd.To = strAddr
objFwd.Cc = "email#address.com"
objFwd.HTMLBody = "<b>Hello world</b>"
objFwd.Display
Else
Be aware, to preserve the message body from the original email you need to insert your content between the opening <body> and closing </body> tags. If you need to add in the beginning of the message paste your additional text right after the opening tag, if you intend to paste it in the end of message - paste right before the closing tag.
Also you may find the Recipients property of the MailItem class helpful. It allows a more convenient way for setting up recipients for the Outlook items. You can read more about that property in the article that I wrote for the technical blog - How To: Fill TO,CC and BCC fields in Outlook programmatically.
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 get the exchange online addresses from users, but I want to convert or somehow get the SMTP Address of them.
I am not sure how to get the SMTP Address from Email1Address.
Set objOL = CreateObject("Outlook.Application")
Set objNS = objOL.GetNamespace("MAPI")
Set objContactsFolder = objNS.GetDefaultFolder(olFolderContacts)
Set objItems = objContactsFolder.Items
For Each obj In objItems
'Test for contact and not distribution list
If obj.Class = olContact Then
Set objContact = obj
With objContact
If .Email1Address <>"" Then
'I want to add the SMTP-Address after the .LastNameAndFirstName of a User
strFileAs = .LastNameAndFirstName
.Email1DisplayName= strFileAs
.Save
End If
End With
End If
Err.Clear
Next
I used this for the email object, see if you can implement it:
dim email as string
If myItem.SenderEmailType = "EX" Then
email = myItem.Sender.GetExchangeUser.PrimarySmtpAddress
Else
email = myItem.SenderEmailAdress
End If
So I have multiple mailboxes under my Outlook account and I am trying to get them to generate reply template based on the mailbox I am replying from (one is private, one is shared). I have tried to base the condition on SenderName and SenderEmailAddress, but to no avail (reply email gets generated with the contents of the previous email retrieved but the text I intend to put in front of it is not there; the cause is that the value of oReply.SenderEmailAddress is empty as Else clause will write the stuff as intended).
(and yes, there are snippets from code enabling reply with attachments)
Sub ReplyWithAttachments()
Dim oReply As Outlook.MailItem
Dim oItem As Object
Dim sSignature As String
Set oItem = GetCurrentItem()
If Not oItem Is Nothing Then
Set oReply = oItem.Reply
If oReply.SenderEmailAddress = "mailbox.private#something.com" Then
sSignature = "Hello and welcome!"
ElseIf oReply.SenderEmailAddress = "mailbox.shared#something.com" Then
sSignature = "Go to hell!"
End If
CopyAttachments oItem, oReply
oReply.HTMLBody = sSignature & oReply.HTMLBody
oReply.Display
oItem.UnRead = False
End If
Set oReply = Nothing
Set oItem = Nothing
End Sub
Edit:
so I managed to get somewhere with
Set oReply = oItem.Reply
sMailBox = oReply.Sender.GetExchangeUser.Address
If sMailBox = "mailbox.private#something.com" Then
sSignature = "whatever"
ElseIf sMailBox = "mailbox.shared#something.com" Then
sSignature = "bla bla bla"
Else
sSignature = "Something"
The code works as intended for the shared mailbox but for the private one, it errors out with Object variable or With block variable not set pointing to .Sender
sMailBox = oReply.Sender.GetExchangeUser.Address
I have something that I use to get sender email (as its dependent on your email exchange)
Dim strSendersEmailAddress As String
If oItem.SenderEmailType = "EX" Then
strSendersEmailAddress = oItem.Sender.GetExchangeUser.PrimarySmtpAddress
Else
strSendersEmailAddress = oItem.SenderEmailAddress
End If
You will have to get the email address before you Set oReply = oItem.Reply
My VBA experience is incredibly limited.I have created basic macros for excel primarily by frankensteining multiple macros I find online together.
Here's what I am looking to do. Every morning I send out an email to a list of 200 customers, I open the new message from a list and the message auto populates (as it is a signature). Currently I then go through all these emails and add my subject and BCC. Could I possibly create a macro to open all of these emails, add my BCC, add my subject, and then send the emails.
Any and all help is much appreciated.
The following code defines an instance of Outlook.Application, and sets up a MailItem ready for sending. It uses a Dictionary object called EmailData to hold the various bits of info to populate To, BCC etc but those can be replaced with your own strings etc. I've pulled this from a function I wrote and made it a little more generic:
Public Function OL_SendMail()
Dim bOpenedOutlook, sComputer, iLoop, iAccount, sAttachArray, sAttachment
bOpenedOutlook = False
sComputer = "."
Dim oWMIService : Set oWMIService = GetObject("winmgmts:\\" & sComputer & "\root\cimv2")
Dim colItems : Set colItems = oWMIService.ExecQuery ("Select * from Win32_Process Where Name = 'outlook.exe'")
Dim oOutlook : Set oOutlook = CreateObject("Outlook.Application")
Dim oNamespace : Set oNamespace = oOutlook.GetNamespace("MAPI")
If colItems.Count = 0 Then
' Outlook isn't open, logging onto it...
oNamespace.Logon "Outlook",,False,True
bOpenedOutlook = True
End If
Dim oFolder : Set oFolder = oNamespace.GetDefaultFolder(olFolderInbox)
If EmailData("SendFrom") = "" Then
' default to first email account the user has access to
iAccount = 1
Else
' Checking to see if the account to send from is accessible by this user...
iAccount = 0
For iLoop = 1 To oOutlook.Session.Accounts.Count
If UCase(Trim(oOutlook.Session.Accounts.Item(iLoop))) = UCase(Trim(EmailData("SendFrom"))) Then
iAccount = iLoop
Exit For
End If
Next
If iAccount = 0 Then
sErrorMsg = "Cannot send email from specified account: " & EmailData("SendFrom") & " as this user doesn't appear to have access to it in Outlook!"
OL_SendMail = False
Exit Function
End If
End If
Dim oMailItem : Set oMailItem = oOutlook.CreateItem(olMailItem)
With oMailItem
Set .SendUsingAccount = oOutlook.Session.Accounts.Item(iAccount)
.To = EmailData("To")
.CC = EmailData("CC")
.BCC = EmailData("BCC")
.Subject = EmailData("Subject")
.Body = EmailData("Body")
sAttachArray = Split(EmailData("AttachmentPaths"), ";")
For Each sAttachment In sAttachArray
.Attachments.Add(sAttachment)
Next
.Recipients.ResolveAll
.Display ' debug mode - uncomment this to see email before it's sent out
End With
'Mail Item created and ready to send
'oMailItem.Send ' this is commented out so the mail doesn't auto send, allows checking of it!!
Set oMailItem = Nothing
Set oNamespace = Nothing
If bOpenedOutlook Then
'oOutlook.Quit
End If
Set oOutlook = Nothing
Set colItems = Nothing
Set oWMIService = Nothing
OL_SendMail = True
End Function