VBA for copying sent email to current folder under a shared mailbox

Status
Not open for further replies.

reubendayal

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Exchange Server 2013
Hi There,

I have the below code in my ThisOutlookSession, and I am trying to copy the email I am sending from a current folder (a sub folder under a shared mailbox). I have prepared the below code after referring several similar discussions online. But the code doesnt seem to do as desired.

The sent emails go to my official email's sent folder and nothing ever gets saved in the sent folder of the shared mailbox.

Thanks for your help!

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

Dim objOL As New Outlook.Application

Dim MyActiveFolder As Outlook.MAPIFolder
Dim CuFolder As String


Set objOL = CreateObject("Outlook.Application")
Set MyActiveFolder = objOL.ActiveExplorer.CurrentFolder

CuFolder = MyActiveFolder.Name

MsgBox CuFolder

If CuFolder <> "Inbox" Then
    Dim myItem As MailItem

    Set myItem = Application.ActiveInspector.CurrentItem

    Set Response.SaveSentMessageFolder = myItem.Parent
Else
End If
End Sub
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
You want to copy the message after its sent? All that is doing to saving sent items in the folder with the message you are replying to? Outlook has that option built in.... it's in File, options.

I think this is the problem:
Dim myItem As MailItem
Set myItem = Application.ActiveInspector.CurrentItem
Set Response.SaveSentMessageFolder = myItem.Parent

There is no current item. If you are getting current folder, move the message to that folder.
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
This works...
Code:
If CuFolder <> "Inbox" Then
    
    Set Response.SaveSentMessageFolder = MyActiveFolder
End If
End Sub
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
This is the full macro - you don't need to get the name of the folder or use cufolder.

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

Dim objOL As New Outlook.Application
Dim MyActiveFolder As Outlook.MAPIFolder

Set objOL = CreateObject("Outlook.Application")
Set MyActiveFolder = objOL.ActiveExplorer.currentFolder

If MyActiveFolder <> "Inbox" Then
Set Response.SaveSentMessageFolder = MyActiveFolder
End If
End Sub
 

reubendayal

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Exchange Server 2013
This is the full macro - you don't need to get the name of the folder or use cufolder.
Hi Diane,

Thank you for your replies and the reworked code.

However, the updated code still does not copy the sent email over to the current folder. It does show up in the sent folder for my individual account. Is there more required to be done because the current folder I am replying the email from is under a shared mailbox? Also, we in the team are given rights to reply using the shared mailbox's email ID.

Thanks again.
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
the current folder I am replying the email from is under a shared mailbox?
Yeah... that is the problem. You need to get the current path and move the mail. When i used move last night, an error said it wouldn't work with reading pain replies, so i went back to your method.

Second problem is sent items for shared mailboxes are not saved in the shared mailbox folder by default. They can be copied there later - so
You'll need to use move - but we need to get the path. We can do that using .parent or .erntryid
response.move myactivefolder

You apparently also need to have sendas rights - my test mailbox does not (it only has send on behalf of), so nothing is working for me, not even manually setting the move to folder. :( I'll need to change the permissions and try again.

You may or may not need to use the getfolderpath function - we might be able to use the .folderpath alone.
Working with VBA and non-default Outlook Folders
 

reubendayal

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Exchange Server 2013
Yeah... that is the problem. You need to get the current path and move the mail. When i used move last night, an error said it wouldn't work with reading pain replies, so i went back to your method.

Second problem is sent items for shared mailboxes are not saved in the shared mailbox folder by default. They can be copied there later - so
You'll need to use move - but we need to get the path. We can do that using .parent or .erntryid
response.move myactivefolder

You apparently also need to have sendas rights - my test mailbox does not (it only has send on behalf of), so nothing is working for me, not even manually setting the move to folder. :( I'll need to change the permissions and try again.

You may or may not need to use the getfolderpath function - we might be able to use the .folderpath alone.
Working with VBA and non-default Outlook Folders
Thanks again for your reply, Diane.

I have tried a few things but I dont seem to be going anywhere with this. Still no result in fact the below code throws an error on the last line "objCopy.Move (DestFldr)".

Not sure how to resolve this.

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

Dim objOL As New Outlook.Application
Dim MyActiveFolder As Outlook.MAPIFolder
Dim objSentFolder As Outlook.MAPIFolder
Dim NS As Outlook.NameSpace
Dim objOwner As Outlook.Recipient
Dim MyFolder As Folder
Dim strMailboxName As String
Dim objItem As Outlook.MailItem
Dim objCopy As Outlook.MailItem
Dim DestFldr As Folder

strMailboxName = "rdayal"

Set NS = Application.GetNamespace("MAPI")
Set objOwner = NS.CreateRecipient("rdayal")
  objOwner.Resolve

If objOwner.Resolved Then
MsgBox objOwner.Name
    Set MyFolder = Session.Folders(strMailboxName)
    Set MyFolder = MyFolder.Folders("Inbox").Parent.Folders("Sent Items")
'Set objSentFolder = objSentFolder.Folders("Inbox").Parent.Folders("Sent Items") 'NS.GetDefaultFolder(objOwner, olFolderSentMail) 'NS.GetSharedDefaultFolder.Folders("Inbox").Parent.Folders("Sent Items")
End If
MsgBox (MyFolder)

Set objOL = CreateObject("Outlook.Application")
Set MyActiveFolder = objOL.ActiveExplorer.CurrentFolder

If MyActiveFolder <> "Inbox" Then
'Set Response.SaveSentMessageFolder = MyActiveFolder
Set objItem = Application.ActiveExplorer.Selection.Item(1)
Set DestFldr = MyActiveFolder
' copy and move
Set objCopy = objItem.Copy
objCopy.Move (DestFldr)

End If
End Sub
 

reubendayal

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Exchange Server 2013
Thanks again for your reply, Diane.

I have tried a few things but I dont seem to be going anywhere with this. Still no result in fact the below code throws an error on the last line "objCopy.Move (DestFldr)".

Not sure how to resolve this.

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

Dim objOL As New Outlook.Application
Dim MyActiveFolder As Outlook.MAPIFolder
Dim objSentFolder As Outlook.MAPIFolder
Dim NS As Outlook.NameSpace
Dim objOwner As Outlook.Recipient
Dim MyFolder As Folder
Dim strMailboxName As String
Dim objItem As Outlook.MailItem
Dim objCopy As Outlook.MailItem
Dim DestFldr As Folder

strMailboxName = "rdayal"

Set NS = Application.GetNamespace("MAPI")
Set objOwner = NS.CreateRecipient("rdayal")
  objOwner.Resolve

If objOwner.Resolved Then
MsgBox objOwner.Name
    Set MyFolder = Session.Folders(strMailboxName)
    Set MyFolder = MyFolder.Folders("Inbox").Parent.Folders("Sent Items")
'Set objSentFolder = objSentFolder.Folders("Inbox").Parent.Folders("Sent Items") 'NS.GetDefaultFolder(objOwner, olFolderSentMail) 'NS.GetSharedDefaultFolder.Folders("Inbox").Parent.Folders("Sent Items")
End If
MsgBox (MyFolder)

Set objOL = CreateObject("Outlook.Application")
Set MyActiveFolder = objOL.ActiveExplorer.CurrentFolder

If MyActiveFolder <> "Inbox" Then
'Set Response.SaveSentMessageFolder = MyActiveFolder
Set objItem = Application.ActiveExplorer.Selection.Item(1)
Set DestFldr = MyActiveFolder
' copy and move
Set objCopy = objItem.Copy
objCopy.Move (DestFldr)

End If
End Sub
I tried your simple one liner change "Response.Move MyActiveFolder" and the sent email was copied here. but then I receive an error message - "The Send operation failed because the item was deleted before it was sent.". and the email saved in the current folder seems a bit different in its header above the recipients row. So the macro still needs refining. Here's the code I used now:
Code:
Private Sub Application_ItemSend(ByVal Response As Object, Cancel As Boolean)

Dim objOL As New Outlook.Application
Dim MyActiveFolder As Outlook.MAPIFolder

Set objOL = CreateObject("Outlook.Application")
Set MyActiveFolder = objOL.ActiveExplorer.CurrentFolder

If MyActiveFolder <> "Inbox" Then
'Response.Copy
Response.Move MyActiveFolder
'Response.Move (MyActiveFolder.FolderPath)
'MsgBox (Response)
End If
End Sub

Please help suggest what can be done. I am not familiar with using .parent or .entryid methods.

Thank you.
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
Are the sent messages going into the shared mailbox's sent folder?
 

reubendayal

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Exchange Server 2013
For that macro to work, messages need to be in the sent folder. But I think if outlook doesnt save them in the sent folder, they wont be found until they sync.
Save Sent Items in Shared Mailbox Sent Items folder

On the folder entryid, i couldnt get it to work (probably user error :)).
You were absolutely correct! I added the 'DelegateSentItemsStyle' to the registry. And everything worked like a charm. Now the email I am sending gets copied in to the current folder. :)

Thank you so much, Diane!!

Here's the final code should anyone else like to use it:

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

Dim objOL As New Outlook.Application
Dim MyActiveFolder As Outlook.MAPIFolder

Set objOL = CreateObject("Outlook.Application")
Set MyActiveFolder = objOL.ActiveExplorer.CurrentFolder

If MyActiveFolder <> "Inbox" Then

Set Response.SaveSentMessageFolder = MyActiveFolder

End If
End Sub
 

reubendayal

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Exchange Server 2013
You were absolutely correct! I added the 'DelegateSentItemsStyle' to the registry. And everything worked like a charm. Now the email I am sending gets copied in to the current folder. :)

Thank you so much, Diane!!

Here's the final code should anyone else like to use it:

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

Dim objOL As New Outlook.Application
Dim MyActiveFolder As Outlook.MAPIFolder

Set objOL = CreateObject("Outlook.Application")
Set MyActiveFolder = objOL.ActiveExplorer.CurrentFolder

If MyActiveFolder <> "Inbox" Then

Set Response.SaveSentMessageFolder = MyActiveFolder

End If
End Sub
Hi agian Diane,

The code has been running great all day long and has saved me a lot of time. I am sure when I show this to my team they'd love it as well. I however am facing an issue if I have started composing a message and then move to another folder for whatever reason and then return to the email later to complete it, the current folder has changed as I had navigated to another folder doing whatever. Is it possible to use the ReplyAll event to catch the initial and original current folder and assign it to the email I am sending so when I hit send the sent copy is put in the correct current folder. Also, if I have more than one email being composed, then too the macro is making the same mistake. Normally, when I hit ReplyAll to an email, it usually is the folder I want my reply to be copied in to.

I have tried playing with some code, but I am unable to pass the current folder's value to the Items_send macro. Also I am unsure how to deal with a situation when there is more than one message being composed. Could you please help?

thank you!
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
You'd need to pick up the folder names on reply. I think. It might work to find the parent message on send -- i'll need to look into it. It should be a mapi property.
 

reubendayal

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Exchange Server 2013
You'd need to pick up the folder names on reply. I think. It might work to find the parent message on send -- i'll need to look into it. It should be a mapi property.

Hi Diane,
Could I gently follow up on this question? Do you have any suggestions on how could we get the parent message information? So the email doesnt get saved in other folders?

Thank you.
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
Entry id should work. I think. Or pick up the folder name and save it to a variable.

I'm out of town and won't be able to test anything until the end of next week.
 

reubendayal

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Exchange Server 2013
Entry id should work. I think. Or pick up the folder name and save it to a variable.

I'm out of town and won't be able to test anything until the end of next week.

Hi Diane,

So I have made some good progress with this. Incidentally as I am not a programmer and have taught myself a bit of programming by trial and error. Which means my progress is slow. :)

I have made the below code and put it in the This Outlooksession. And most of it seems to be firing well. The only case where I see the code fail is when I have more than one email opened and the current active folder is different from the actual source folder for that email. I do not know how to make these replies unique so the macro remembers the original active folder and saves the respective reply to that folder only.

Code:
Private Sub Application_ItemSend(ByVal Response As Object, Cancel As Boolean)
Dim objOL As New Outlook.Application
Dim MyActiveFolder As Outlook.MAPIFolder

Set objOL = CreateObject("Outlook.Application")
Set MyActiveFolder = objOL.ActiveExplorer.CurrentFolder

If Response.MessageClass = "IPM.Note" Then
    If MyCuFolder Is Nothing Then GoTo SaveResponse
   
        If MyActiveFolder <> MyCuFolder Then
            Set MyActiveFolder = MyCuFolder
        End If
SaveResponse:
        Set Response.SaveSentMessageFolder = MyActiveFolder
    MsgBox "This Email will be saved in the Folder: " & MyActiveFolder
Else

End If
Set MyCuFolder = Nothing
Set MyActiveFolder = Nothing
End Sub

And a similar code for the Forward event:

Code:
Private Sub oItem_Forward(ByVal Forward As Object, Cancel As Boolean)

Cancel = True
bDiscardEvents = True

Dim objOL As New Outlook.Application
Dim MyActiveFolder As Outlook.MAPIFolder

Set objOL = CreateObject("Outlook.Application")
Set MyActiveFolder = objOL.ActiveExplorer.CurrentFolder

If Response.MessageClass = "IPM.Note" And MyActiveFolder <> MyCuFolder Then
    Set MyActiveFolder = MyCuFolder
End If

oReply.Display

bDiscardEvents = False
Set oItem = Nothing

End Sub
 

reubendayal

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Exchange Server 2013
Code:
Option Explicit

Private WithEvents Items As Outlook.Items
Private WithEvents oExpl As Explorer
Private WithEvents oItem As MailItem
Private bDiscardEvents As Boolean
Dim oResponse As MailItem
Dim MyCuFolder As Outlook.MAPIFolder ' This is used to set the outgoing email to the its parent folder

Private Sub Application_Startup()
On Error Resume Next
Set Items = Session.GetDefaultFolder(olFolderSentMail).Items

Set oExpl = Application.ActiveExplorer
bDiscardEvents = False

End Sub

These are followed by the ItemSend and then the forward events.

Thank you.
 
Status
Not open for further replies.
Similar threads
Thread starter Title Forum Replies Date
S Add VBA save code Using Outlook 0
C Auto Run VBA Code on new email Outlook VBA and Custom Forms 1
O VBA Cases with Listbox - Can you use Multi-Select? Outlook VBA and Custom Forms 4
O VBA Outlook Message Attachment - Array Index Out of Bounds Outlook VBA and Custom Forms 0
V Modifying the built in forms with VBA Outlook VBA and Custom Forms 4
S Excel VBA and shared calendar issue Outlook VBA and Custom Forms 4
L Macro/VBA to Reply All, with the original attachments Outlook VBA and Custom Forms 2
L VBA unknown character Outlook VBA and Custom Forms 2
G Move tasks up/down todo list by VBA Outlook VBA and Custom Forms 1
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
K Use VBA to find Sender and Recipient from Microsfot 365 Journaled Email Items Outlook VBA and Custom Forms 3
J Want to learn VBA Macros for Outlook. What book can you recommend? Outlook VBA and Custom Forms 2
F VBA code to dock Styles whenever I write or edit an email Outlook VBA and Custom Forms 0
C VBA to prompt for Sent folder destination Outlook VBA and Custom Forms 3
B Adding signature to bottom of VBA reply email Outlook VBA and Custom Forms 1
B Change Font and Font size using VBA Outlook VBA and Custom Forms 9
M Outlook 2013 reminder email by using Outlook vba Outlook VBA and Custom Forms 2
D.Moore VBA script fail after Office 365 update Using Outlook 8
R Limiting length of saved attachment in VBA Outlook VBA and Custom Forms 2
S Skype for business meeting vba code Outlook VBA and Custom Forms 1
C How to use VBA to show only items x days old or more Outlook VBA and Custom Forms 1
B VBA to convert email to task, insert text of email in task notes, and attach copy of original email Outlook VBA and Custom Forms 4
D Outlook VBA error extracting property data from GetRules collection Outlook VBA and Custom Forms 10
S Reference Custom Fields with VBA Outlook VBA and Custom Forms 2
PGSystemTester VBA To Change AppointmentItem.BusyStatus From MeetingItem Before Send Using Outlook 0
A VBA macro for 15 second loop in send and received just for 1 specific mailbox Outlook VBA and Custom Forms 1
O Email not leaving Outbox when using Excel VBA to sync Outlook account Outlook VBA and Custom Forms 4
G VBA Macro Calendar Printing Assistant 4
R Help Revising VBA macro to delete email over different time span Outlook VBA and Custom Forms 0
B VBA to Collapse Task Folder Groups Outlook VBA and Custom Forms 1
R Expand VBA Permanent Delete Code Outlook VBA and Custom Forms 6
shrydvd vba to secure zip attachments Outlook VBA and Custom Forms 3
M Adding Subject to this Link-Saving VBA Outlook VBA and Custom Forms 5
N VBA to delete duplicates by message-id on common pst for 2 or more emails Outlook VBA and Custom Forms 0
S Change VBA script to send HTML email instead of text Outlook VBA and Custom Forms 3
M VBA to auto forward message with new subject and body text Outlook VBA and Custom Forms 8
A Custom VBA to sort emails into folders Outlook VBA and Custom Forms 0
L Moving emails with similar subject and find the timings between the emails using outlook VBA macro Outlook VBA and Custom Forms 1
B Outlook Business Contact Manager with SQL to Excel, User Defined Fields in BCM don't sync in SQL. Can I use VBA code to copy 1 field to another? BCM (Business Contact Manager) 0
A Edit subject - and change conversationTopic - using VBA and redemption Outlook VBA and Custom Forms 2
N How can I increase/faster outlook VBA Macro Speed ? Using Outlook 2
N Outlook Email Rule execution through shortcut keys (VBA codes) Using Outlook 1
A VBA Code in Outlook disappears after first use Outlook VBA and Custom Forms 1
B Clear Offline Items (Mail Folder) via VBA Outlook VBA and Custom Forms 1
dweller Outlook 2010 Rule Ignores VBA Script Outlook VBA and Custom Forms 2
D.Moore Folder view settings by VBA macro Outlook VBA and Custom Forms 57
F VBA to ensure a code is entered in Subject title Outlook VBA and Custom Forms 1
B Vba to monitor time to respond to emails using a shared mailbox Outlook VBA and Custom Forms 5
N VBA Script to Open highlighted e-mail and Edit Message Outlook VBA and Custom Forms 5
G Outlook VBA and Google Calendar ("Events") Outlook VBA and Custom Forms 1

Similar threads

Top