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

Status
Not open for further replies.

reubendayal

Senior Member
Outlook version
Outlook 365 64 bit
Email Account
Office 365 Exchange
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
 
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.
 
This works...
Code:
If CuFolder <> "Inbox" Then
    
    Set Response.SaveSentMessageFolder = MyActiveFolder
End If
End Sub
 
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
 
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.
 
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
 
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
 
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.
 
Are the sent messages going into the shared mailbox's sent folder?
 
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
 
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!
 
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.
 
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.
 
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.
 
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
 
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
H using VBA to edit subject line Outlook VBA and Custom Forms 0
G Get current open draft message body from VBA Outlook VBA and Custom Forms 1
Geldner Problem submitting SPAM using Outlook VBA Form Outlook VBA and Custom Forms 2
P VBA to add email address to Outlook 365 rule Outlook VBA and Custom Forms 0
M Outlook 2016 outlook vba to look into shared mailbox Outlook VBA and Custom Forms 0
V VBA Categories unrelated to visible calendar and Visual appointment Categories Outlook VBA and Custom Forms 2
D Outlook VBA forward the selected email to the original sender’s email ID (including the email used in TO, CC Field) from the email chain Outlook VBA and Custom Forms 3
R Outlook 365 VBA AUTO SEND WITH DELAY FOR EACH EMAIL Outlook VBA and Custom Forms 0
R Outlook 2019 VBA to List Meetings in Rooms Outlook VBA and Custom Forms 0
geoffnoakes Counting and/or listing fired reminders via VBA Using Outlook 1
O VBA - Regex - remove double line spacing Outlook VBA and Custom Forms 1
D.Moore Strange VBA error Outlook VBA and Custom Forms 4
B Modify VBA to create a RULE to block multiple messages Outlook VBA and Custom Forms 0
D Outlook 2021 Using vba code to delete all my spamfolders not only the default one. Outlook VBA and Custom Forms 0
K vba code to auto download email into a specific folder in local hard disk as and when any new email arrives in Inbox/subfolder Outlook VBA and Custom Forms 0
D VBA - unable to set rule condition 'on this computer only' Outlook VBA and Custom Forms 5
L Fetch, edit and forward an email with VBA outlook Outlook VBA and Custom Forms 2
BartH VBA no longer working in Outlook Outlook VBA and Custom Forms 1
W Can vba(for outlook) do these 2 things or not? Outlook VBA and Custom Forms 2
MattC Changing the font of an email with VBA Outlook VBA and Custom Forms 1
P MailItem.To Property with VBA not work Outlook VBA and Custom Forms 2
P Tweak vba so it can target another mailbox Outlook VBA and Custom Forms 1
A Outlook 2010 VBA fails to launch Outlook VBA and Custom Forms 2
richardwing Outlook 365 VBA to access "Other Actions" menu for incoming emails in outlook Outlook VBA and Custom Forms 0
W Create a Quick Step or VBA to SAVE AS PDF in G:|Data|Client File Outlook VBA and Custom Forms 1
J Outlook Rules VBA Run a Script - Multiple Rules Outlook VBA and Custom Forms 0
C Outlook (desktop app for Microsoft365) restarts every time I save my VBA? Using Outlook 1
D VBA Macro to Print and Save email to network location Outlook VBA and Custom Forms 1
TedSch Small vba to kill political email Outlook VBA and Custom Forms 3
E Outlook 365 Outlook/VBA Outlook VBA and Custom Forms 11
N VBA Macro To Save Emails Outlook VBA and Custom Forms 1
Z VBA Forward vs manual forward Outlook VBA and Custom Forms 2
J VBA Cannot programmatically input or change Value for User Defined field Using Outlook 1
J VBA for outlook to compare and sync between calendar Outlook VBA and Custom Forms 1
A Any way to force sort by/group by on search results with VBA? Outlook VBA and Custom Forms 1
E Default shape via VBA Outlook VBA and Custom Forms 4
A Change settings Send/receive VBA Outlook VBA and Custom Forms 0
Z Import Tasks from Access Using VBA including User Defined Fields Outlook VBA and Custom Forms 0
E Outlook VBA change GetDefaultFolder dynamically Outlook VBA and Custom Forms 6
justicefriends How to set a flag to follow up using VBA - for addressee in TO field Outlook VBA and Custom Forms 11
M add new attendee to existing meetings with VBA Outlook VBA and Custom Forms 5
D VBA code to select a signature from the signatures list Outlook VBA and Custom Forms 3
D Create advanced search (email) via VBA with LONG QUERY (>1024 char) Outlook VBA and Custom Forms 2
David McKay VBA to manually forward using odd options Outlook VBA and Custom Forms 1
FryW Need help modifying a VBA script for in coming emails to auto set custom reminder time Outlook VBA and Custom Forms 0
S vba outlook search string with special characters Outlook VBA and Custom Forms 1
S VBA search string with special characters Outlook VBA and Custom Forms 1
U Outlook 2019 VBA run-time error 424 Outlook VBA and Custom Forms 2
DDB VBA to Auto Insert Date and Time in the signature Outlook VBA and Custom Forms 2
F VBA to move email from Non Default folder to Sub folders as per details given in excel file Outlook VBA and Custom Forms 11

Similar threads

Back
Top