How to save a copy of a sent email in a specified shared folder in outlook

[bradyboyy88]

There is a strange event in outlook such that if you send an email from a shared mailbox then the sent email shows up in the actual users sent folder and not the shared mailbox sent folder. So to get around this I want to save a copy of the sent email in the shared sent folder or a shared outlook folder. Any ideas of how I would do this? I have included my code for sending the email below:

Public Sub SendButton_EMAILClick()


    'Ensure no other queries are running
    If QueryRunning Then Exit Sub
    QueryRunning = True
    Userform1.MousePointer = fmMousePointerHourGlass
    
    
    'Create Email
    'Generate Outlook Email for L&E
    Dim OutApp As Outlook.Application
    Dim OutMail As Outlook.MailItem
    Dim QuitNewOutlook As Boolean
    Dim myInspector As Outlook.Inspector
    Dim Session As Outlook.Namespace
    
    On Error Resume Next
    Set OutApp = GetObject(, "Outlook.Application")
    
    On Error GoTo 0
  
    If OutApp Is Nothing Then
        Set OutApp = CreateObject("Outlook.Application")
        QuitNewOutlook = True
    End If
  
    Set Session = OutApp.GetNamespace("MAPI")
    Session.Logon
    
    On Error GoTo OutlookErrors
    Set OutMail = OutApp.CreateItem(0)
    Set OutlookEventClass.oMailItem = OutMail
    'Get a reference the inspector obj (the window the mail item is displayed in)
    
        With OutMail
            .SentOnBehalfOfName = Userform1.FromLabel_EMAIL.Caption ' This contains the shared mailbox name and as an example is sharedmailbox@xyz.com
            .To = Userform1.ToTextBox_Email.Text
            .CC = Userform1.CCTextbox_EMAIL.Text
            .BCC = Userform1.BCCTextbox_EMAIL.Text
            .Subject = Userform1.SubjectTextbox_EMAIL.Text
            .Body = Userform1.BodyTextbox_EMAIL.Text
            If Not Userform1.AttachmenLabel_EMAIL.Tag = "" Then
                .Attachments.Add (Userform1.AttachmenLabel_EMAIL.Tag)
            End If
            .Send
        End With


    If QuitNewOutlook Then
        OutApp.Quit
    End If
    
    Set OutMail = Nothing
    Set OutApp = Nothing
    
    Userform1.MousePointer = fmMousePointerDefault
    
    QueryRunning = False
    Exit Sub
OutlookErrors:


            Debug.Print Err.Number & " : " & Err.Description
            Call ActivateUniversalSplashScreen("Outlook Error! Either restart or try again later.", Userform1.UploadBlurrImage, True, "Error")
            If DatabaseMethods.SQLIsConnectionOpen Then
                DatabaseMethods.SQLCloseDatabaseConnection
            End If
        
            Set OutMail = Nothing
            
            If Not OutApp Is Nothing And QuitNewOutlook Then
                OutApp.Quit
            End If
            Set OutApp = Nothing
            QueryRunning = False
    
End Sub