How to Change Outlook Save Sent Message Folder Using VBA within Excel

Question

I am using VBA through Excel 365 to send the current workbook via Outlook email. It works fine, except that it only saves the message to the default sent items folder. I need the message to be saved in an alternate folder in Outlook.

Cobbling together code from various sources, I came up with the following. The code compiles and runs without error, but the SaveSentMessage folder never gets updated. The value of ObjFolder always remains "Nothing" vs. picking up the location of the "Training" folder. The message gets saved in the default sent items folder instead of the desired folder.

I don't know what I'm doing wrong.

The workbook is used by several different people, but we will all be using the same shared email account (logged in via a separate Outlook profile).

Sub SendActiveWorkbookSavingToOtherFolder() 

   On Error Resume Next

   Dim appOutlook As Object
   Dim mItem As Object
   Dim objNS As Object    
   Dim objFolder As Object

   Set objNS = Application.getnamespace("MAPI")
   Set appOutlook = GetObject(, "Outlook.Application")        'Bind to existing instance of Outlook
   Set mItem = appOutlook.CreateItem(0) '<<---- number zero, not the letter
   Set objFolder = objNS.GetDefaultFolder(5).Parent.Folders("Training")    'used value of 5 to get sent items default folder as shown at https://learn.microsoft.com/en-us/office/vba/api/outlook.oldefaultfolders    

    'objFolder always has a value of "Nothing" even after running the line above

    'the folder "Training" is at the same level as Sent Items, Inbox, etc.

With mItem
      .To = "[email protected]"     
      .Subject = ActiveWorkbook.Name 
     .Attachments.Add ActiveWorkbook.FullName
     .SaveSentMessageFolder = objFolder
     .send
End With 

    'clean up objects
   Set mItem = Nothing
   Set appOutlook = Nothing 

End Sub 

Answer 1

Application is Excel so the bypassed error on

Set objNS = Application.GetNamespace("MAPI")

means objNS is Nothing and all folders based on objNS will be Nothing.

Option Explicit

Sub SendActiveWorkbookSavingToOtherFolder()

    ' Limit the scope of an error bypass to the minimum number of lines.
    'On Error Resume Next
    ' Ideally the scope is zero lines.
    'On Error GoTo 0
    
    Dim appOutlook As Object
    Dim mItem As Object
    Dim objNS As Object
    Dim objFolder As Object
    
    ' Application here is Excel not Outlook
    'Set objNS = Application.GetNamespace("MAPI")
    ' No error due to On Error Resume Next
    ' Since objNS is Nothing all folders based on objNS will be Nothing
    
    Set appOutlook = GetObject(, "Outlook.Application")    'Bind to existing instance of Outlook
    Set objNS = appOutlook.GetNamespace("MAPI")
    
    Set mItem = appOutlook.CreateItem(0) '<<---- number zero, not the letter
    
    'used value of 5 to get sent items default folder
    ' as shown at https://learn.microsoft.com/en-us/office/vba/api/outlook.oldefaultfolders
    Set objFolder = objNS.GetDefaultFolder(5)
    'Set appOutlook.ActiveExplorer.CurrentFolder = objFolder
    
    Set objFolder = objFolder.Parent
    'Set appOutlook.ActiveExplorer.CurrentFolder = objFolder
    
    'the folder "Training" is at the same level as Sent Items, Inbox, etc.
    Set objFolder = objFolder.Folders("Training")
    'Set appOutlook.ActiveExplorer.CurrentFolder = objFolder
    
    With mItem
        .To = "[email protected]"
        .Subject = "ActiveWorkbook.Name"
        .Attachments.Add ActiveWorkbook.FullName
        
        Set .SaveSentMessageFolder = objFolder
        'Debug.Print .SaveSentMessageFolder
        
        .Display
        '.Send
    End With
    
    
    'clean up objects
    Set mItem = Nothing
    Set appOutlook = Nothing
    Set objNS = Nothing
    Set objFolder = Nothing
    
End Sub