The scenario:
Two teams: MainTeam and HelpingTeam
MainTeam uses a shared mailbox exclusively and a macro sends all emails "on behalf of MainTeam" instead of sending-as the shared mailbox.
HelpingTeam users are going to help the other team. They need to indicate email is sent "on behalf of MainTeam".
The shared mailbox has been added to the users on the HelpingTeam and in a new mail window, the email address for the shared mailbox is below their personal one. Using this "From" address would indicate they are trying to SendAs the mailbox, which we don't want.
I could show them how to add another "From" address and set it up to use their primary account to "SendonBehalfOf", but they do not want to be confused because now they will see two entries in their "From" list: the "SendAs" entry (Fixed, can not be removed) and the "SendonBehalfOf" entry (can be removed).
I am trying to change the email properties so email will be sent on behalf of the shared mailbox.
When sending the email from the shared mailbox using this macro, everything works.
When initiating the email from a personal mailbox and changing the sender to the "SendAs" account (the only shared account in the list), the properties in the macro appear to be correct, but Outlook does not process the change and the system denies the message.
I've made so many revisions that I've lost track of what works and what doesn't. Below is the most functional version as described above. The MsgBox entries are to help me keep track of what is going on behind the scenes:
Dim oAccount As Outlook.Account
Dim objItem As MailItem
Dim WithEvents objInspectors As Outlook.Inspectors
Dim WithEvents objMailItem As Outlook.MailItem
Dim WithEvents myOlExp As Outlook.Explorer
Dim Sender As Outlook.AddressEntry
Private Sub Application_Startup()
Initialize_handler
End Sub
Public Sub Initialize_handler()
Set objInspectors = Application.Inspectors
Set myOlExp = Application.ActiveExplorer
End Sub
Private Sub objInspectors_NewInspector(ByVal Inspector As Inspector)
If Inspector.CurrentItem.Class = olMail Then
Set objMailItem = Inspector.CurrentItem
If objMailItem.Sent = False Then
Call SetFromAddress(objMailItem)
End If
End If
End Sub
Public Sub SetFromAddress(objMailItem As Outlook.MailItem)
'To see which account user is trying to send from
MsgBox "[SetFromAddress] SendUsingAccount: " & objMailItem.SendUsingAccount
MsgBox "[SetFromAddress] SentOnBehalfOfName: " & objMailItem.SentOnBehalfOfName
'Check which account is in focus as primary
If objMailItem.SendUsingAccount = "MainTeam#company.com" Then
MsgBox "sendfromaddress if triggered"
'set sender to be the Shared Mailbox
objMailItem.SentOnBehalfOfName = "MainTeam#company.com"
'Find Primary O365 account and use that to send the email "on behalf of"
For Each oAccount In Application.Session.Accounts
If oAccount = "U.ser#company.com" Then
objMailItem.SendUsingAccount = oAccount
End If
Next
End If
MsgBox "SetFromAddress Sending As: " & objMailItem.SendUsingAccount
MsgBox "SetFromAddress OnBehalf: " & objMailItem.SentOnBehalfOfName
End Sub
'Below enables Outlook 2013/2016/365 Reading Pane Reply
Private Sub myOlExp_InlineResponse(ByVal objItem As Object)
Call SetFromAddress(objItem)
End Sub
'Added the sub below in case the user manually switchs from personal to shared mailbox
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
MsgBox "[ItemSend] SendUsingAccount: " & Item.SendUsingAccount
MsgBox "[ItemSend] SentOnBehalfOfName: " & Item.SentOnBehalfOfName
'Check if Shared Account
If Item.SentOnBehalfOfName = "MainTeam#company.com" Then
MsgBox "If triggered"
'set sender to be the Shared Mailbox
Item.SentOnBehalfOfName = "MainTeam#company.com"
'Find Primary O365 account and use that to send the email "on behalf of"
For Each oAccount In Application.Session.Accounts
If oAccount = "U.ser#company.com" Then
Item.SendUsingAccount = oAccount
End If
Next
End If
MsgBox "[ItemSend] SendUsingAccount: " & Item.SendUsingAccount
MsgBox "[ItemSend] SentOnBehalfOfName: " & Item.SentOnBehalfOfName
End Sub
30/11/2020
This is how I am working around the issue for now, but it fails if it's an in-line reply:
Private Sub Application_ItemSend(ByVal item As Object, Cancel As Boolean)
Dim oAccount As Outlook.Account
Dim objItem As MailItem
'To test later which account user is trying to send from
Set SendingAccount = item.SendUsingAccount
'Check if Shared Account
If SendingAccount = "MainTeam#company.com" Then
'Intecept email, stop it from sending, and create a new one "on behalf of"
If TypeOf item Is MailItem Then
Set objItem = item.Copy
item.Delete
Cancel = True
'set sender to be the Shared Mailbox
objItem.SentOnBehalfOfName = "MainTeam#company.com"
'Find Primary O365 account and use that to send the email "on behalf of"
For Each oAccount In Application.Session.Accounts
If oAccount = "U.ser#company.com" Then
objItem.SendUsingAccount = oAccount
End If
Next
End If
'send email
objItem.Send
End If
End Sub
Looks like I found a great work-around! While not the answer, it at least makes this code work. I basically sent the command to check names SendKeys "%k" (ALT+k), which checks both the sender and recipients field. While CTRL+k checks names on a new message, it will open the insert hyperlink window on a reply, which is why I went with ALT+k.
I added this at the end of the SetFromAddress and in for statement which checks for the correct sending account. I tested both inside and outside the for statement, but inside works every time.
Public Sub SetFromAddress(objMailItem As Outlook.MailItem)
'To see which account user is trying to send from
'Check which account is in focus as primary
If objMailItem.SendUsingAccount = "MainTeam#company.com" Then
'set sender to be the Shared Mailbox
objMailItem.SentOnBehalfOfName = "MainTeam#company.com"
'Find Primary O365 account and use that to send the email "on behalf of"
For Each oAccount In Application.Session.Accounts
If oAccount = "U.ser#company.com" Then
objMailItem.SendUsingAccount = oAccount
End If
Next
End If
SendKeys "%k
End Sub
and
For Each oAccount In Application.Session.Accounts
If oAccount = "U.ser#company.com" Then
objItem.SendUsingAccount = oAccount
sendkeys (%k)
End If
Next
End If
It's not perfect, but it will work for now until I can figure out how to tackle in-line responses.
I have to trick Outlook into accepting SentOnBehalfOfName. Your setup may differ.
Dim oAccount As account
Const mailAddressShared = "MainTeam#company.com"
Private Sub setSentOnBehalfName()
Dim currItem As MailItem
Set currItem = ActiveInspector.currentItem
Debug.Print currItem.subject
currItem.SentOnBehalfOfName = mailAddressShared
currItem.Save
End Sub
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Debug.Print "[ItemSend] SendUsingAccount: " & Item.SendUsingAccount
Debug.Print "[ItemSend] SentOnBehalfOfName: " & Item.SentOnBehalfOfName
Dim copiedItem As Object
'Check if Shared Account
If Item.SentOnBehalfOfName = mailAddressShared Then
' trick Outlook into accepting .SentOnBehalfOfName
Set copiedItem = Item.Copy
'assign shared mailbox
copiedItem.SentOnBehalfOfName = mailAddressShared
Debug.Print "copiedItem.SentOnBehalfOfName: " & copiedItem.SentOnBehalfOfName
ElseIf Item.SentOnBehalfOfName = "" Then
If MsgBox("Assign shared mailbox to SentOnBehalfOfName?", vbYesNo) = vbYes Then
' trick Outlook into accepting .SentOnBehalfOfName
Set copiedItem = Item.Copy
'assign shared mailbox
copiedItem.SentOnBehalfOfName = mailAddressShared
Debug.Print "copiedItem.SentOnBehalfOfName: " & copiedItem.SentOnBehalfOfName
End If
End If
'Find default account to send the email
If Not copiedItem Is Nothing Then
Item.Delete
Cancel = True ' cancels original item
For Each oAccount In Session.Accounts
If oAccount = Session.GetDefaultFolder(olFolderInbox).Parent Then
copiedItem.SendUsingAccount = oAccount
Exit For
End If
Next
Debug.Print "[ItemSend] copiedItem.SendUsingAccount: " & copiedItem.SendUsingAccount
Debug.Print "[ItemSend] copiedItem.SentOnBehalfOfName: " & copiedItem.SentOnBehalfOfName
copiedItem.Send ' does not re-trigger ItemSend
Else
Debug.Print "[ItemSend] Item.SendUsingAccount: " & Item.SendUsingAccount
Debug.Print "[ItemSend] Item.SentOnBehalfOfName: " & Item.SentOnBehalfOfName
For Each oAccount In Session.Accounts
If oAccount = Session.GetDefaultFolder(olFolderInbox).Parent Then
Item.SendUsingAccount = oAccount
Exit For
End If
Next
Debug.Print "[ItemSend] Item.SendUsingAccount: " & Item.SendUsingAccount
End If
End Sub
Related
I'm using the script below to auto convert emails to tasks:
Sub ConvertMailtoTask(Item As Outlook.MailItem)
Dim objTask As Outlook.TaskItem
Set objTask = Application.CreateItem(olTaskItem)
With objTask
.Subject = Item.Subject
.StartDate = Item.ReceivedTime
.Body = Item.Body
.Companies = Item.SenderEmailAddress
.Save
End With
Set objTask = Nothing
End Sub
I'd also like to auto send an email to the recipient everytime a task is completed without having to assing the task. I've tried the approach below but nothing gets returned. Any ideas why?
Sub Item_PropertyChange(ByVal Name)
Set oMsg = Application.CreateItem(olMailItem)
If Item.Status = 2 Then
With oMsg
.To = "myemailaddress"
.Subject = "Task Completed"
.Body = Item.Subject
.Send
End With
End If
End Sub
Triggering an event requires a set up like this:
In ThisOutlookSession
Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
Dim WithEvents myInspector As Inspectors
Dim WithEvents myTaskItem As TaskItem
Private Sub Application_Startup()
Set myInspector = Inspectors
End Sub
Private Sub myInspector_NewInspector(ByVal Inspector As Inspector)
If TypeOf Inspector.CurrentItem Is TaskItem Then
Set myTaskItem = Inspector.CurrentItem
End If
End Sub
Private Sub myTaskItem_PropertyChange(ByVal Name As String)
' More than one property may change simultaneously
Debug.Print Name
If Name = "Status" Then
'Status 2: completed
Debug.Print Name & " has changed to: "
Debug.Print " " & myTaskItem.Status
If myTaskItem.Status = 2 Then
' a) The last task opened remains in memory until another task is opened.
' A selected task marked complete by menu or ribbon button will not trigger code,
' unless it was the last task opened.
' Selected items are automatically saved. The usual case.
'
' b) Users may mark completed by accident.
'
' c) If in an inspector window, the change has not yet been saved.
MsgBox "Status of the last task that was opened now marked Completed." & vbCr & _
"If in an inspector window, the change has not yet been saved."
End If
End If
End Sub
This code is executed every time I select a message. I want this code to be executed only when I am composing new mail/replying/forwarding.
Private Sub Application_ItemLoad(ByVal Item As Object)
Dim oAccount As Outlook.Explorer
If TypeName(Item) = "MailItem" Then
MsgBox ("this is mail")
Set oAccount = Application.ActiveExplorer
MsgBox (oAccount.CurrentFolder.FolderPath)
End If
End Sub
What I am trying to achieve: When composing mail from specific account (account#mail.com) add recipient in CC field.
I am a noob in programming.
You can test the MailItem.Sent property to determine whether composing mail or reading received mail.
Private Sub Application_ItemLoad(ByVal Item As Object)
Dim oAccount As Outlook.Explorer
If TypeName(Item) = "MailItem" Then
If item.Sent Then
MsgBox "Not for processing"
Else
MsgBox "Processing this mail"
Set oAccount = Application.ActiveExplorer
MsgBox (oAccount.CurrentFolder.FolderPath)
End If
End If
End Sub
My users have their personal mailbox as their primary account and an auto-mapped shared mailbox configured in their Outlook 2010 client. The shared mailbox is an Office 365 shared mailbox and thus cannot be logged into to set it as the primary account.
I am trying to start a new email from the shared account's address.
Below is the VBA code I have been trying to use. I have allowed Macros in Outlook's trust center settings.
Public Sub New_Mail()
Dim oAccount As Outlook.Account
Dim oMail As Outlook.MailItem
For Each oAccount In Application.Session.Accounts
If oAccount = "sharedMailboxAddress#domain.tld" Then
Set oMail = Application.CreateItem(olMailItem)
oMail.SendUsingAccount = oAccount
oMail.Display
End If
Next
End Sub
Using the following code with the SentOnBehalfOfName property starts a new email from the shared mailbox's address. Thanks to Dmitry Streblechenko for pointing me in the right direction.
Sub New_Mail()
Dim objMsg As MailItem
Set objMsg = Application.CreateItem(olMailItem)
With objMsg
.SentOnBehalfOfName = "sharedMailboxAddress#domain.tld"
.Display
End With
Set objMsg = Nothing
End Sub
A delegate mailbox will not be in the Namespace.Accounts list.
Set the MailItem.SentOnBehalfOfName property instead.
What does not work in your code?
Use the smtpAddress property to select an account.
Example function:
Private Function GetAccountForEmailAddress(smtpAddress As String) As Outlook.account
Dim account As Outlook.account
For Each account In Application.Session.accounts
If LCase(account.smtpAddress) = LCase(smtpAddress) Then
Set GetAccountForEmailAddress = account
Exit Function
End If
Next account
MsgBox "No Account with SmtpAddress: " & smtpAddress & " exists!", vbCritical, "Oops!"
Set GetAccountForEmailAddress = Nothing
End Function
The debug.print line will show you the accounts.
Option Explicit
Public Sub New_Mail()
Dim oAccount As account
Dim oMail As mailItem
For Each oAccount In Session.Accounts
Debug.Print oAccount
If LCase(oAccount) = LCase("text copied from the immediate window") Then
Set oMail = CreateItem(olMailItem)
oMail.SendUsingAccount = oAccount
oMail.Display
End If
Next
ExitRoutine:
Set oMail = Nothing
End Sub
Not exactly the problem I had, but this question and the answers helped. My problem was to send from a particular mailbox while using many accounts. The one-liner answer was this:
OutMail.SendUsingAccount = OutApp.Session.Accounts.Item("address#domain.com")
I need to automatically save an attachment depending on what email it was sent to (not by senders).
I have 3 emails on the mail server pdf#, xml#, txt#. If email is sent to #pdf I need to save it on a network drive, and same goes for the other emails but to different locations.
All other code I have seen only take into account the sender not the sent to address.
You can handle the ItemSend event of the Application class where you can check out the To address (or the Recipients collection) and save the attachment if required. For example:
Public WithEvents myOlApp As Outlook.Application
Public Sub Initialize_handler()
Set myOlApp = Outlook.Application
End Sub
Private Sub myOlApp_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim prompt As String
prompt = "Are you sure you want to send " & Item.Subject & "?"
If MsgBox(prompt, vbYesNo + vbQuestion, "Sample") = vbNo Then
Cancel = True
End If
End Sub
The ItemSend event is fired whenever an Microsoft Outlook item is sent, either by the user through an Inspector (before the inspector is closed, but after the user clicks the Send button) or when the Send method for an Outlook item, such as MailItem, is used in a program.
You may find the Getting Started with VBA in Outlook 2010 article helpful.
Created 3x postlists and one rule in Outlook.
When email is sent to (add all the postlists) and has an attachment
run this script. ps. you have to edit all of the paths, foldernames and postlistnames.
Sub SaveAllAttachments(objitem As MailItem)
Dim objAttachments As Outlook.Attachments
Dim strName, strLocation As String
Dim dblCount, dblLoop As Double
Dim strSub As String
Dim iRcpCount, iRcp As Integer
strLocation = "O:\PDF\"
On Error GoTo ExitSub
If objitem.Class = olMail Then
Set objAttachments = objitem.Attachments
dblCount = objAttachments.Count
If dblCount <= 0 Then
GoTo 100
End If
strSub = ""
iRcpCount = objitem.Recipients.Count
For iRcp = 1 To iRcpCount
If objitem.Recipients(iRcp).Name = "Postlist1" Then
strSub = "Folder1onOdrive"
ElseIf objitem.Recipients(iRcp).Name = "Postlist2" Then
strSub = "Folder2onOdrive"
ElseIf objitem.Recipients(iRcp).Name = "Postlist3" Then
strSub = "Folder3onOdrive"
End If
Next iRcp
For dblLoop = 1 To dblCount
strName = objAttachments.Item(dblLoop).FileName
'strName = strLocation & strName
strName = strLocation & strSub & strName
'strName = strLocation & strName
objAttachments.Item(dblLoop).SaveAsFile strName
Next dblLoop
objitem.Delete
End If
100
ExitSub:
Set objAttachments = Nothing
Set objOutlook = Nothing
End Sub
I have the below vba coding in thisoutlooksession in outlook.
Basically this coding pops up a yes/no message box for all outgoing E-mails external to my organisation.
The coding works file, However, thisoutlooksession sometimes doesn't recognize that it has a coding in it.
However, when i open the coding window (Alt + F11) and place a break in the header, and run the coding, it starts working fine after that.
I have double/triple checked, there is no problem with the coding. it is something to do with the settings.
I have enabled all macros as well.
Any suggestions or thoughts as why this happens and how could this be overcome?
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
On Error Resume Next
If Item.Class <> olMail Then Exit Sub
Dim sCompanyDomain As String: sCompanyDomain = "tell.com"
Const PidTagSmtpAddress As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
On Error Resume Next
Dim oMail As MailItem: Set oMail = Item
Dim oRecipients As Recipients: Set oRecipients = oMail.Recipients
Dim bDisplayMsgBox As Boolean: bDisplayMsgBox = False
Dim sExternalAddresses As String
Dim oRecipient As Recipient
For Each oRecipient In oRecipients
Dim oProperties As PropertyAccessor: Set oProperties = oRecipient.PropertyAccessor
Dim smtpAddress As String: smtpAddress = oProperties.GetProperty(PidTagSmtpAddress)
Debug.Print smtpAddress
If (Len(smtpAddress) >= Len(sCompanyDomain)) Then
If (Right(LCase(smtpAddress), Len(sCompanyDomain)) <> sCompanyDomain) Then
' external address found
If (sExternalAddresses = "") Then
sExternalAddresses = smtpAddress
Else
sExternalAddresses = sExternalAddresses & ", " & smtpAddress
End If
bDisplayMsgBox = True
End If
End If
Next
If (bDisplayMsgBox) Then
Dim iAnswer As Integer
iAnswer = MsgBox("You are about to send this email externally to " & sExternalAddresses & vbCr & vbCr & "Do you want to continue?", vbExclamation + vbYesNo + vbDefaultButton2, "External Email Check")
If (iAnswer = vbNo) Then
Cancel = True
End If
End If
End Sub
As a last resort move the otm file to a backup folder.
Start Outlook to find an empty otm. Copy the code above into ThisOutlookSession.