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

[reubendayal]

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!

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]

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]

This works...

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

 

[Diane Poremsky]

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]

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]

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]

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.

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]

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.

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:

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]

Are the sent messages going into the shared mailbox's sent folder?

 

[reubendayal]

Are the sent messages going into the shared mailbox's sent folder?

No. They go to my main account's sent folder. Also I have the send as right to send from the shared mailbox's email id.

 

[Diane Poremsky]

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 ).

 

[reubendayal]

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:

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]

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:

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]

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]

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]

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]

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.

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:

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]

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.