Change From address while sending a new mail

Status
Not open for further replies.

Calvin

New Member
Outlook version
Outlook 2010 32 bit
Email Account
Exchange Server 2010
Hi all,
its the first time I write on this forum.
I hope someone of you could help me to solve a problem.

I would like to change the from address and add some tag to subject for each new email I send.
While adding tag to subject it would be very simple, isn't so for the From address field.
I've googled a lot and, for now, nothing helpded me in this task.
Now my question are
Is it possible using ItemSend event, or I should use another way?
Does someone know if and how is it possible change the from address?

Here's the code I've used to change the subject and to try to change the from address
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)'
Item.Subject = Item.Subject & "[myDepartment]" 'it works :)
Item.SentOnBehalfOfName = "department01" 'it doesn't :((((
End Sub

I've grant my user sendas right for the email address/mailbox I wish to use.

Thanks
Marco
 

Calvin

New Member
Outlook version
Outlook 2010 32 bit
Email Account
Exchange Server 2010
You need to change the address as the message form opens - this is done using inspector code, not itemsend. I'll dig up some examples.
Hi Diane,

I've tried to add this code:

Code:
Sub ChangeSentItem()
  Dim objInspector As Outlook.Inspector
  Dim objItem As Outlook.MailItem
  Set objInspector = Application.ActiveInspector
  Set objItem = objInspector.CurrentItem
  objItem.SentOnBehalfOfName = "snp02"
  objItem.Subject = objItem.Subject & " [SNP] [OUT] [SU2]"
  objItem.Categories = "BCC"
  objItem.Save
End Sub

If I open a new message and run manually the macro it works well.
After this, I've tried to add the code inside the sub Application_ItemSend, and, again, it doesn't work.

But, how is it possible to automate the process without run the macro each time manually?!?
Is it possible to run the macro, only for the new messages I send?

Thanks
Marco
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
if you want to change the account, you need to do it when you open the message - this sample changes the account on new messages and replies when you hit New Email or Reply.

Code:
Private WithEvents m_Inspectors As Outlook.Inspectors
Private WithEvents m_Inspector As Outlook.Inspector
 
Private Sub Application_Startup()
  Set m_Inspectors = Application.Inspectors
End Sub
 
Private Sub m_Inspectors_NewInspector(ByVal Inspector As Outlook.Inspector)
  Set m_Inspector = Inspector
End Sub
  
Private Sub m_Inspector_Activate()
Dim olNS As Outlook.NameSpace
Set olNS = Application.GetNamespace("MAPI")
If TypeName(m_Inspector.CurrentItem) <> "MailItem" Then
  Exit Sub
End If
' (2) this the default account
If m_Inspector.CurrentItem.SendUsingAccount <> olNS.Accounts.Item(2) Then
Set m_Inspector.CurrentItem.SendUsingAccount = olNS.Accounts.Item(2)
m_Inspector.CurrentItem.Display
End If
  Set m_Inspector = Nothing
  Set olNS = Nothing
End Sub
 

niton

Member
Outlook version
Outlook 2010 32 bit
Email Account
Exchange Server 2010
Try this:

Private Sub Application_ItemSend(ByVal item As Object, Cancel As Boolean)

Dim objItem As MailItem

If TypeOf item Is MailItem Then
Set objItem = item.Copy

Set objRecip = objItem.Recipients.Add(item.SentOnBehalfOfName)
objRecip.Type = olBCC
objRecip.Resolve

item.Delete
Cancel = True
objItem.SentOnBehalfOfName = "snp02"
'Debug.Print objItem.SentOnBehalfOfName
objItem.Subject = objItem.Subject & " [SNP] [OUT] [SU2]"
objItem.Send ' Try it. Application_ItemSend is not called again.
End If

End Sub
 

Calvin

New Member
Outlook version
Outlook 2010 32 bit
Email Account
Exchange Server 2010
Hi Diane, hi Niton.

thanks for your help. Your suggestion were decisive for me.
I think the main part of the script is completed. I have only to do some in-depth test (mail with big attachment, different outlook version, mailbox not attached and so on) and add some code to manage errors (any suggestion?).
As you can see the script copy the sent item in a shared mailbox and in a PF, but only if some recipient in bcc exists. This to allow users who can access PF or shared mailbox to view the bcc recipient of every email sent. The sender has to be always the same for every user, due to a company policy.
A question: on your opinion, can office patch, windows update, office service pack and so on interfere with the code (which is one of my big fear: after a windows update nothing works anymore)?!?

Here's the code:

Code:
Private Sub Application_ItemSend(ByVal item As Object, Cancel As Boolean)

  Dim objItem As Outlook.MailItem
  Dim strSubject As String
  Dim strOrigSubject As String
  If TypeOf item Is MailItem Then
  Set objItem = item.Copy
  item.Delete
  Cancel = True
  objItem.SentOnBehalfOfName = "snp02"
  objItem.Categories = "BCC"
  strOrigSubject = objItem.Subject
  If HasBCC(objItem) = 1 Then
  objItem.Subject = "[BCC] " & objItem.Subject & " [SNP] [OUT] [SU2]"
  Else
  objItem.Subject = objItem.Subject & " [SNP] [OUT] [SU2]"
  End If
  strSubject = objItem.Subject
  For Each objRecip In objItem.Recipients
  objRecip.Resolve
  Next
  objItem.Send
  Call Empty_Deleted_Items(strOrigSubject)
  End If
  If HasBCC(objItem) = 1 Then
  Call Copy_Sent_Item(strSubject)
  End If

End Sub

Function HasBCC(ByRef objItem As MailItem) As Integer

  'test for BCC recipients
  Dim objRecip As Outlook.Recipient
  Dim objRecips As Outlook.Recipients
  Set objRecips = objItem.Recipients
  For Each objRecip In objItem.Recipients
  If objRecip.Type = olBCC Then
  HasBCC = 1
  Exit For
  End If
  HasBCC = 0
  Next

End Function

Sub Empty_Deleted_Items(strDelSubject As String)
'  On Error Resume Next
'  Bug: this sub delete the messages looking at the subject only. If
some messages with the same subject as the email I'm sendig exists,
'  they will be deleted too. Try to find a more precise way to
identify the message to be deleted
  Dim objDeletedItems As MAPIFolder
  Dim objDelItem As MailItem
  Set objDeletedItems =Application.Session.GetDefaultFolder(olFolderDeletedItems)
  For Each objDelItem In objDeletedItems.Items
  If strDelSubject = objDelItem.Subject Then
  objDelItem.Delete
  End If
  Next
End Sub

Sub Copy_Sent_Item(strSentSubject As String)

'  On Error Resume Next
  Dim objNameSpace As NameSpace
  Dim strPFRoot As String
  Dim strSharedMBX As String
  Dim objSentItems As MAPIFolder
  Dim objSentItem As MailItem
  Dim objSentMBX As MailItem
  Dim objSentPF As MailItem
  Dim objSharedMBXInboxFolder As Folder
  Dim objPFDeptFolder As Folder
  strPFRoot = "Public Folders - " & (Application.Session.Accounts.item(1))
  strSharedMBX = "snp02"
  Set objNameSpace = Application.GetNamespace("MAPI")
  Set objSentItems = Application.Session.GetDefaultFolder(olFolderSentMail)
  MsgBox strSentSubject
  For Each objSentItem In objSentItems.Items
  If strSentSubject = objSentItem.Subject Then
  MsgBox objSentItem.Subject
  Set objSentMBX = objSentItem.Copy
  Set objSentPF = objSentItem.Copy
  Exit For
  End If
  Next
  Set objSharedMBXInboxFolder = objNameSpace.Folders(strSharedMBX).Folders("Inbox") 'inbox of shared mailbox dept.
  Set objPFDeptFolder = objNameSpace.Folders(strPFRoot).Folders("All Public Folders").Folders("MIGTEST").Folders("SNP02") 'inbox for PF dept.
  Call WaitFor(1) 'delay routine to give the time to copy item
  objSentMBX.Move objSharedMBXInboxFolder
  objSentPF.Move objPFDeptFolder

End Sub

Sub WaitFor(NumOfSeconds As Long)
'  On Error Resume Next
  Dim SngSec As Long
  SngSec = Timer + NumOfSeconds
  Do While Timer < SngSec
  Loop
End Sub

Every suggestion or comment is welcome :)
 
Status
Not open for further replies.
Similar threads
Thread starter Title Forum Replies Date
B Change from Address Outlook VBA and Custom Forms 0
S Example VBA Macro - To Conditionally Change the From Account and Add a BCC Address on Emails Outlook VBA and Custom Forms 11
B Do not change the From address in Outlook Templates Using Outlook 0
B Change default email for address book Using Outlook 1
Maybear Sudden change in Outlook, no image display, email no longer offers suggestions for address Using Outlook 8
P Change the Outlook.com "from" address for calendar event invites Using Outlook 9
D Change To address when it is sent to a specific address during specfic time. Using Outlook 2
K Automatically Change "From" Address When Replying As An Alias? Using Outlook 5
R Change Outlook 2010 Exchange server address via registry or script Using Outlook 5
C Outlook Automatically Change "From" address based on "To" address Using Outlook 4
S Change "This Week" flag start date behavior Using Outlook 1
N Help creating a VBA macro with conditional formatting to change the font color of all external emails to red Outlook VBA and Custom Forms 5
D Change Microsoft Account password - what to do to update on all devices Using Outlook 4
S Outlook 2016 Change how Outlook shows me contacts in emails Using Outlook 0
witzker HowTo Change message Class of contact form Outlook VBA and Custom Forms 0
Z Outlook 365 delete reminder you can’t make change to contents of this-read only folder Using Outlook 4
witzker Pls help to change the code for inserting date in Ol contact body Outlook VBA and Custom Forms 5
R How to Change Margins In Google Docs...? Using Outlook 0
e_a_g_l_e_p_i Outlook 2010 How can I change the font size on right side appointment pane Using Outlook 12
diver864 vba for a rule to automatically accept meeting requests with 'vacation' in subject, change to all-day event, change to free, don't send reply Outlook VBA and Custom Forms 1
B Change Font and Font size using VBA Outlook VBA and Custom Forms 9
D Change senders title Using Outlook 1
W Recurrence: delete older occurrences / change earliest start time Outlook VBA and Custom Forms 0
E Change sending account depending on Subjectline Outlook VBA and Custom Forms 0
J Outlook 2013 Change color of text in data fields of contacts in Outlook 2013? Using Outlook 10
B Change row background color of selected item Using Outlook 1
PGSystemTester VBA To Change AppointmentItem.BusyStatus From MeetingItem Before Send Using Outlook 0
X If you change expiration date of repeated task it dupplicates Using Outlook 1
E How to display "Change Folder" in Change Default Email Delivery Location in Exchange Outlook 2016 Using Outlook 1
B See "Change View" Drop Down as a List? Using Outlook 1
V Change start time based on message duration Outlook VBA and Custom Forms 2
R Folder pane width change Using Outlook 70
S Change VBA script to send HTML email instead of text Outlook VBA and Custom Forms 3
S Outlook 2010 unable to change default font Using Outlook 7
P How can I change my calendar view back Using Outlook 3
A Edit subject - and change conversationTopic - using VBA and redemption Outlook VBA and Custom Forms 2
T Change the selected Message in the Outlook window Outlook VBA and Custom Forms 2
geofferyh How to change the Attachment File Name? Outlook VBA and Custom Forms 1
W Appointment occurrences change the location property Using Outlook 0
T Scheduled footer change Using Outlook 2
B Change font of reminder of an email header Outlook VBA and Custom Forms 3
CWM030 Name Change? Exchange Server Administration 9
V not able to change name in customize Ribbon Outlook VBA and Custom Forms 1
JoeG Appointment Delete/Change Recurrence Outlook VBA and Custom Forms 0
C Change Subject Line in Selected Emails Outlook VBA and Custom Forms 1
V Change default default save location to Quick Access Using Outlook 1
C Change default "Save Sent Item To" folder Outlook VBA and Custom Forms 9
M Sudden change in From field - now very short Using Outlook 4
M cannot change delivery folders with IMAP accounts Using Outlook 0
S Email Format With Embedded Images and Tables Change Using Outlook 2

Similar threads

Top